gitk: Restore scrolling position of diff pane on back/forward in history
[alt-git.git] / gitk
blob08a45e1b94a26938215d962fd96e928090ff13a7
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
183 lappend glflags $arg
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191 # These mean that we get a subset of the commits
192 set filtered 1
193 lappend glflags $arg
195 "-n" {
196 # This appears to be the only one that has a value as a
197 # separate word following it
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" {
203 set notflag [expr {!$notflag}]
204 lappend revargs $arg
206 "--all" {
207 lappend revargs $arg
209 "--merge" {
210 set vmergeonly($n) 1
211 # git rev-parse doesn't understand --merge
212 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 "-*" {
215 # Other flag arguments including -<n>
216 if {[string is digit -strict [string range $arg 1 end]]} {
217 set filtered 1
218 } else {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
221 set allknown 0
223 lappend glflags $arg
225 default {
226 # Non-flag arguments specify commits or ranges of commits
227 if {[string match "*...*" $arg]} {
228 lappend revargs --gitk-symmetric-diff-marker
230 lappend revargs $arg
234 set vdflags($n) $diffargs
235 set vflags($n) $glflags
236 set vrevs($n) $revargs
237 set vfiltered($n) $filtered
238 set vorigargs($n) $origargs
239 return $allknown
242 proc parseviewrevs {view revs} {
243 global vposids vnegids
245 if {$revs eq {}} {
246 set revs HEAD
248 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines [split $err "\n"]
252 set badrev {}
253 for {set l 0} {$l < [llength $errlines]} {incr l} {
254 set line [lindex $errlines $l]
255 if {!([string length $line] == 40 && [string is xdigit $line])} {
256 if {[string match "fatal:*" $line]} {
257 if {[string match "fatal: ambiguous argument*" $line]
258 && $badrev ne {}} {
259 if {[llength $badrev] == 1} {
260 set err "unknown revision $badrev"
261 } else {
262 set err "unknown revisions: [join $badrev ", "]"
264 } else {
265 set err [join [lrange $errlines $l end] "\n"]
267 break
269 lappend badrev $line
272 error_popup "[mc "Error parsing revisions:"] $err"
273 return {}
275 set ret {}
276 set pos {}
277 set neg {}
278 set sdm 0
279 foreach id [split $ids "\n"] {
280 if {$id eq "--gitk-symmetric-diff-marker"} {
281 set sdm 4
282 } elseif {[string match "^*" $id]} {
283 if {$sdm != 1} {
284 lappend ret $id
285 if {$sdm == 3} {
286 set sdm 0
289 lappend neg [string range $id 1 end]
290 } else {
291 if {$sdm != 2} {
292 lappend ret $id
293 } else {
294 lset ret end [lindex $ret end]...$id
296 lappend pos $id
298 incr sdm -1
300 set vposids($view) $pos
301 set vnegids($view) $neg
302 return $ret
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list {view} {
307 global startmsecs commitidx viewcomplete curview
308 global tclencoding
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges
311 global viewactive viewinstances vmergeonly
312 global mainheadid viewmainheadid viewmainheadid_orig
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs [clock clicks -milliseconds]
316 set commitidx($view) 0
317 # these are set this way for the error exits
318 set viewcomplete($view) 1
319 set viewactive($view) 0
320 varcinit $view
322 set args $viewargs($view)
323 if {$viewargscmd($view) ne {}} {
324 if {[catch {
325 set str [exec sh -c $viewargscmd($view)]
326 } err]} {
327 error_popup "[mc "Error executing --argscmd command:"] $err"
328 return 0
330 set args [concat $args [split $str "\n"]]
332 set vcanopt($view) [parseviewargs $view $args]
334 set files $viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files [unmerged_files $files]
337 if {$files eq {}} {
338 global nr_unmerged
339 if {$nr_unmerged == 0} {
340 error_popup [mc "No files selected: --merge specified but\
341 no files are unmerged."]
342 } else {
343 error_popup [mc "No files selected: --merge specified but\
344 no unmerged files are within file limit."]
346 return 0
349 set vfilelimit($view) $files
351 if {$vcanopt($view)} {
352 set revs [parseviewrevs $view $vrevs($view)]
353 if {$revs eq {}} {
354 return 0
356 set args [concat $vflags($view) $revs]
357 } else {
358 set args $vorigargs($view)
361 if {[catch {
362 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
363 --boundary $args "--" $files] r]
364 } err]} {
365 error_popup "[mc "Error executing git log:"] $err"
366 return 0
368 set i [reg_instance $fd]
369 set viewinstances($view) [list $i]
370 set viewmainheadid($view) $mainheadid
371 set viewmainheadid_orig($view) $mainheadid
372 if {$files ne {} && $mainheadid ne {}} {
373 get_viewmainhead $view
375 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
376 interestedin $viewmainheadid($view) dodiffindex
378 fconfigure $fd -blocking 0 -translation lf -eofchar {}
379 if {$tclencoding != {}} {
380 fconfigure $fd -encoding $tclencoding
382 filerun $fd [list getcommitlines $fd $i $view 0]
383 nowbusy $view [mc "Reading"]
384 set viewcomplete($view) 0
385 set viewactive($view) 1
386 return 1
389 proc stop_instance {inst} {
390 global commfd leftover
392 set fd $commfd($inst)
393 catch {
394 set pid [pid $fd]
396 if {$::tcl_platform(platform) eq {windows}} {
397 exec kill -f $pid
398 } else {
399 exec kill $pid
402 catch {close $fd}
403 nukefile $fd
404 unset commfd($inst)
405 unset leftover($inst)
408 proc stop_backends {} {
409 global commfd
411 foreach inst [array names commfd] {
412 stop_instance $inst
416 proc stop_rev_list {view} {
417 global viewinstances
419 foreach inst $viewinstances($view) {
420 stop_instance $inst
422 set viewinstances($view) {}
425 proc reset_pending_select {selid} {
426 global pending_select mainheadid selectheadid
428 if {$selid ne {}} {
429 set pending_select $selid
430 } elseif {$selectheadid ne {}} {
431 set pending_select $selectheadid
432 } else {
433 set pending_select $mainheadid
437 proc getcommits {selid} {
438 global canv curview need_redisplay viewactive
440 initlayout
441 if {[start_rev_list $curview]} {
442 reset_pending_select $selid
443 show_status [mc "Reading commits..."]
444 set need_redisplay 1
445 } else {
446 show_status [mc "No commits selected"]
450 proc updatecommits {} {
451 global curview vcanopt vorigargs vfilelimit viewinstances
452 global viewactive viewcomplete tclencoding
453 global startmsecs showneartags showlocalchanges
454 global mainheadid viewmainheadid viewmainheadid_orig pending_select
455 global isworktree
456 global varcid vposids vnegids vflags vrevs
458 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
459 rereadrefs
460 set view $curview
461 if {$mainheadid ne $viewmainheadid_orig($view)} {
462 if {$showlocalchanges} {
463 dohidelocalchanges
465 set viewmainheadid($view) $mainheadid
466 set viewmainheadid_orig($view) $mainheadid
467 if {$vfilelimit($view) ne {}} {
468 get_viewmainhead $view
471 if {$showlocalchanges} {
472 doshowlocalchanges
474 if {$vcanopt($view)} {
475 set oldpos $vposids($view)
476 set oldneg $vnegids($view)
477 set revs [parseviewrevs $view $vrevs($view)]
478 if {$revs eq {}} {
479 return
481 # note: getting the delta when negative refs change is hard,
482 # and could require multiple git log invocations, so in that
483 # case we ask git log for all the commits (not just the delta)
484 if {$oldneg eq $vnegids($view)} {
485 set newrevs {}
486 set npos 0
487 # take out positive refs that we asked for before or
488 # that we have already seen
489 foreach rev $revs {
490 if {[string length $rev] == 40} {
491 if {[lsearch -exact $oldpos $rev] < 0
492 && ![info exists varcid($view,$rev)]} {
493 lappend newrevs $rev
494 incr npos
496 } else {
497 lappend $newrevs $rev
500 if {$npos == 0} return
501 set revs $newrevs
502 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
504 set args [concat $vflags($view) $revs --not $oldpos]
505 } else {
506 set args $vorigargs($view)
508 if {[catch {
509 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
510 --boundary $args "--" $vfilelimit($view)] r]
511 } err]} {
512 error_popup "[mc "Error executing git log:"] $err"
513 return
515 if {$viewactive($view) == 0} {
516 set startmsecs [clock clicks -milliseconds]
518 set i [reg_instance $fd]
519 lappend viewinstances($view) $i
520 fconfigure $fd -blocking 0 -translation lf -eofchar {}
521 if {$tclencoding != {}} {
522 fconfigure $fd -encoding $tclencoding
524 filerun $fd [list getcommitlines $fd $i $view 1]
525 incr viewactive($view)
526 set viewcomplete($view) 0
527 reset_pending_select {}
528 nowbusy $view "Reading"
529 if {$showneartags} {
530 getallcommits
534 proc reloadcommits {} {
535 global curview viewcomplete selectedline currentid thickerline
536 global showneartags treediffs commitinterest cached_commitrow
537 global targetid
539 set selid {}
540 if {$selectedline ne {}} {
541 set selid $currentid
544 if {!$viewcomplete($curview)} {
545 stop_rev_list $curview
547 resetvarcs $curview
548 set selectedline {}
549 catch {unset currentid}
550 catch {unset thickerline}
551 catch {unset treediffs}
552 readrefs
553 changedrefs
554 if {$showneartags} {
555 getallcommits
557 clear_display
558 catch {unset commitinterest}
559 catch {unset cached_commitrow}
560 catch {unset targetid}
561 setcanvscroll
562 getcommits $selid
563 return 0
566 # This makes a string representation of a positive integer which
567 # sorts as a string in numerical order
568 proc strrep {n} {
569 if {$n < 16} {
570 return [format "%x" $n]
571 } elseif {$n < 256} {
572 return [format "x%.2x" $n]
573 } elseif {$n < 65536} {
574 return [format "y%.4x" $n]
576 return [format "z%.8x" $n]
579 # Procedures used in reordering commits from git log (without
580 # --topo-order) into the order for display.
582 proc varcinit {view} {
583 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
584 global vtokmod varcmod vrowmod varcix vlastins
586 set varcstart($view) {{}}
587 set vupptr($view) {0}
588 set vdownptr($view) {0}
589 set vleftptr($view) {0}
590 set vbackptr($view) {0}
591 set varctok($view) {{}}
592 set varcrow($view) {{}}
593 set vtokmod($view) {}
594 set varcmod($view) 0
595 set vrowmod($view) 0
596 set varcix($view) {{}}
597 set vlastins($view) {0}
600 proc resetvarcs {view} {
601 global varcid varccommits parents children vseedcount ordertok
603 foreach vid [array names varcid $view,*] {
604 unset varcid($vid)
605 unset children($vid)
606 unset parents($vid)
608 # some commits might have children but haven't been seen yet
609 foreach vid [array names children $view,*] {
610 unset children($vid)
612 foreach va [array names varccommits $view,*] {
613 unset varccommits($va)
615 foreach vd [array names vseedcount $view,*] {
616 unset vseedcount($vd)
618 catch {unset ordertok}
621 # returns a list of the commits with no children
622 proc seeds {v} {
623 global vdownptr vleftptr varcstart
625 set ret {}
626 set a [lindex $vdownptr($v) 0]
627 while {$a != 0} {
628 lappend ret [lindex $varcstart($v) $a]
629 set a [lindex $vleftptr($v) $a]
631 return $ret
634 proc newvarc {view id} {
635 global varcid varctok parents children vdatemode
636 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
637 global commitdata commitinfo vseedcount varccommits vlastins
639 set a [llength $varctok($view)]
640 set vid $view,$id
641 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
642 if {![info exists commitinfo($id)]} {
643 parsecommit $id $commitdata($id) 1
645 set cdate [lindex $commitinfo($id) 4]
646 if {![string is integer -strict $cdate]} {
647 set cdate 0
649 if {![info exists vseedcount($view,$cdate)]} {
650 set vseedcount($view,$cdate) -1
652 set c [incr vseedcount($view,$cdate)]
653 set cdate [expr {$cdate ^ 0xffffffff}]
654 set tok "s[strrep $cdate][strrep $c]"
655 } else {
656 set tok {}
658 set ka 0
659 if {[llength $children($vid)] > 0} {
660 set kid [lindex $children($vid) end]
661 set k $varcid($view,$kid)
662 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
663 set ki $kid
664 set ka $k
665 set tok [lindex $varctok($view) $k]
668 if {$ka != 0} {
669 set i [lsearch -exact $parents($view,$ki) $id]
670 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
671 append tok [strrep $j]
673 set c [lindex $vlastins($view) $ka]
674 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
675 set c $ka
676 set b [lindex $vdownptr($view) $ka]
677 } else {
678 set b [lindex $vleftptr($view) $c]
680 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
681 set c $b
682 set b [lindex $vleftptr($view) $c]
684 if {$c == $ka} {
685 lset vdownptr($view) $ka $a
686 lappend vbackptr($view) 0
687 } else {
688 lset vleftptr($view) $c $a
689 lappend vbackptr($view) $c
691 lset vlastins($view) $ka $a
692 lappend vupptr($view) $ka
693 lappend vleftptr($view) $b
694 if {$b != 0} {
695 lset vbackptr($view) $b $a
697 lappend varctok($view) $tok
698 lappend varcstart($view) $id
699 lappend vdownptr($view) 0
700 lappend varcrow($view) {}
701 lappend varcix($view) {}
702 set varccommits($view,$a) {}
703 lappend vlastins($view) 0
704 return $a
707 proc splitvarc {p v} {
708 global varcid varcstart varccommits varctok
709 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
711 set oa $varcid($v,$p)
712 set ac $varccommits($v,$oa)
713 set i [lsearch -exact $varccommits($v,$oa) $p]
714 if {$i <= 0} return
715 set na [llength $varctok($v)]
716 # "%" sorts before "0"...
717 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
718 lappend varctok($v) $tok
719 lappend varcrow($v) {}
720 lappend varcix($v) {}
721 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
722 set varccommits($v,$na) [lrange $ac $i end]
723 lappend varcstart($v) $p
724 foreach id $varccommits($v,$na) {
725 set varcid($v,$id) $na
727 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
728 lappend vlastins($v) [lindex $vlastins($v) $oa]
729 lset vdownptr($v) $oa $na
730 lset vlastins($v) $oa 0
731 lappend vupptr($v) $oa
732 lappend vleftptr($v) 0
733 lappend vbackptr($v) 0
734 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
735 lset vupptr($v) $b $na
739 proc renumbervarc {a v} {
740 global parents children varctok varcstart varccommits
741 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
743 set t1 [clock clicks -milliseconds]
744 set todo {}
745 set isrelated($a) 1
746 set kidchanged($a) 1
747 set ntot 0
748 while {$a != 0} {
749 if {[info exists isrelated($a)]} {
750 lappend todo $a
751 set id [lindex $varccommits($v,$a) end]
752 foreach p $parents($v,$id) {
753 if {[info exists varcid($v,$p)]} {
754 set isrelated($varcid($v,$p)) 1
758 incr ntot
759 set b [lindex $vdownptr($v) $a]
760 if {$b == 0} {
761 while {$a != 0} {
762 set b [lindex $vleftptr($v) $a]
763 if {$b != 0} break
764 set a [lindex $vupptr($v) $a]
767 set a $b
769 foreach a $todo {
770 if {![info exists kidchanged($a)]} continue
771 set id [lindex $varcstart($v) $a]
772 if {[llength $children($v,$id)] > 1} {
773 set children($v,$id) [lsort -command [list vtokcmp $v] \
774 $children($v,$id)]
776 set oldtok [lindex $varctok($v) $a]
777 if {!$vdatemode($v)} {
778 set tok {}
779 } else {
780 set tok $oldtok
782 set ka 0
783 set kid [last_real_child $v,$id]
784 if {$kid ne {}} {
785 set k $varcid($v,$kid)
786 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
787 set ki $kid
788 set ka $k
789 set tok [lindex $varctok($v) $k]
792 if {$ka != 0} {
793 set i [lsearch -exact $parents($v,$ki) $id]
794 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
795 append tok [strrep $j]
797 if {$tok eq $oldtok} {
798 continue
800 set id [lindex $varccommits($v,$a) end]
801 foreach p $parents($v,$id) {
802 if {[info exists varcid($v,$p)]} {
803 set kidchanged($varcid($v,$p)) 1
804 } else {
805 set sortkids($p) 1
808 lset varctok($v) $a $tok
809 set b [lindex $vupptr($v) $a]
810 if {$b != $ka} {
811 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
812 modify_arc $v $ka
814 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
815 modify_arc $v $b
817 set c [lindex $vbackptr($v) $a]
818 set d [lindex $vleftptr($v) $a]
819 if {$c == 0} {
820 lset vdownptr($v) $b $d
821 } else {
822 lset vleftptr($v) $c $d
824 if {$d != 0} {
825 lset vbackptr($v) $d $c
827 if {[lindex $vlastins($v) $b] == $a} {
828 lset vlastins($v) $b $c
830 lset vupptr($v) $a $ka
831 set c [lindex $vlastins($v) $ka]
832 if {$c == 0 || \
833 [string compare $tok [lindex $varctok($v) $c]] < 0} {
834 set c $ka
835 set b [lindex $vdownptr($v) $ka]
836 } else {
837 set b [lindex $vleftptr($v) $c]
839 while {$b != 0 && \
840 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
841 set c $b
842 set b [lindex $vleftptr($v) $c]
844 if {$c == $ka} {
845 lset vdownptr($v) $ka $a
846 lset vbackptr($v) $a 0
847 } else {
848 lset vleftptr($v) $c $a
849 lset vbackptr($v) $a $c
851 lset vleftptr($v) $a $b
852 if {$b != 0} {
853 lset vbackptr($v) $b $a
855 lset vlastins($v) $ka $a
858 foreach id [array names sortkids] {
859 if {[llength $children($v,$id)] > 1} {
860 set children($v,$id) [lsort -command [list vtokcmp $v] \
861 $children($v,$id)]
864 set t2 [clock clicks -milliseconds]
865 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
868 # Fix up the graph after we have found out that in view $v,
869 # $p (a commit that we have already seen) is actually the parent
870 # of the last commit in arc $a.
871 proc fix_reversal {p a v} {
872 global varcid varcstart varctok vupptr
874 set pa $varcid($v,$p)
875 if {$p ne [lindex $varcstart($v) $pa]} {
876 splitvarc $p $v
877 set pa $varcid($v,$p)
879 # seeds always need to be renumbered
880 if {[lindex $vupptr($v) $pa] == 0 ||
881 [string compare [lindex $varctok($v) $a] \
882 [lindex $varctok($v) $pa]] > 0} {
883 renumbervarc $pa $v
887 proc insertrow {id p v} {
888 global cmitlisted children parents varcid varctok vtokmod
889 global varccommits ordertok commitidx numcommits curview
890 global targetid targetrow
892 readcommit $id
893 set vid $v,$id
894 set cmitlisted($vid) 1
895 set children($vid) {}
896 set parents($vid) [list $p]
897 set a [newvarc $v $id]
898 set varcid($vid) $a
899 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
900 modify_arc $v $a
902 lappend varccommits($v,$a) $id
903 set vp $v,$p
904 if {[llength [lappend children($vp) $id]] > 1} {
905 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
906 catch {unset ordertok}
908 fix_reversal $p $a $v
909 incr commitidx($v)
910 if {$v == $curview} {
911 set numcommits $commitidx($v)
912 setcanvscroll
913 if {[info exists targetid]} {
914 if {![comes_before $targetid $p]} {
915 incr targetrow
921 proc insertfakerow {id p} {
922 global varcid varccommits parents children cmitlisted
923 global commitidx varctok vtokmod targetid targetrow curview numcommits
925 set v $curview
926 set a $varcid($v,$p)
927 set i [lsearch -exact $varccommits($v,$a) $p]
928 if {$i < 0} {
929 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
930 return
932 set children($v,$id) {}
933 set parents($v,$id) [list $p]
934 set varcid($v,$id) $a
935 lappend children($v,$p) $id
936 set cmitlisted($v,$id) 1
937 set numcommits [incr commitidx($v)]
938 # note we deliberately don't update varcstart($v) even if $i == 0
939 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
940 modify_arc $v $a $i
941 if {[info exists targetid]} {
942 if {![comes_before $targetid $p]} {
943 incr targetrow
946 setcanvscroll
947 drawvisible
950 proc removefakerow {id} {
951 global varcid varccommits parents children commitidx
952 global varctok vtokmod cmitlisted currentid selectedline
953 global targetid curview numcommits
955 set v $curview
956 if {[llength $parents($v,$id)] != 1} {
957 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
958 return
960 set p [lindex $parents($v,$id) 0]
961 set a $varcid($v,$id)
962 set i [lsearch -exact $varccommits($v,$a) $id]
963 if {$i < 0} {
964 puts "oops: removefakerow can't find [shortids $id] on arc $a"
965 return
967 unset varcid($v,$id)
968 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
969 unset parents($v,$id)
970 unset children($v,$id)
971 unset cmitlisted($v,$id)
972 set numcommits [incr commitidx($v) -1]
973 set j [lsearch -exact $children($v,$p) $id]
974 if {$j >= 0} {
975 set children($v,$p) [lreplace $children($v,$p) $j $j]
977 modify_arc $v $a $i
978 if {[info exist currentid] && $id eq $currentid} {
979 unset currentid
980 set selectedline {}
982 if {[info exists targetid] && $targetid eq $id} {
983 set targetid $p
985 setcanvscroll
986 drawvisible
989 proc first_real_child {vp} {
990 global children nullid nullid2
992 foreach id $children($vp) {
993 if {$id ne $nullid && $id ne $nullid2} {
994 return $id
997 return {}
1000 proc last_real_child {vp} {
1001 global children nullid nullid2
1003 set kids $children($vp)
1004 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1005 set id [lindex $kids $i]
1006 if {$id ne $nullid && $id ne $nullid2} {
1007 return $id
1010 return {}
1013 proc vtokcmp {v a b} {
1014 global varctok varcid
1016 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1017 [lindex $varctok($v) $varcid($v,$b)]]
1020 # This assumes that if lim is not given, the caller has checked that
1021 # arc a's token is less than $vtokmod($v)
1022 proc modify_arc {v a {lim {}}} {
1023 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1025 if {$lim ne {}} {
1026 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1027 if {$c > 0} return
1028 if {$c == 0} {
1029 set r [lindex $varcrow($v) $a]
1030 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1033 set vtokmod($v) [lindex $varctok($v) $a]
1034 set varcmod($v) $a
1035 if {$v == $curview} {
1036 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1037 set a [lindex $vupptr($v) $a]
1038 set lim {}
1040 set r 0
1041 if {$a != 0} {
1042 if {$lim eq {}} {
1043 set lim [llength $varccommits($v,$a)]
1045 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1047 set vrowmod($v) $r
1048 undolayout $r
1052 proc update_arcrows {v} {
1053 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1054 global varcid vrownum varcorder varcix varccommits
1055 global vupptr vdownptr vleftptr varctok
1056 global displayorder parentlist curview cached_commitrow
1058 if {$vrowmod($v) == $commitidx($v)} return
1059 if {$v == $curview} {
1060 if {[llength $displayorder] > $vrowmod($v)} {
1061 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1062 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1064 catch {unset cached_commitrow}
1066 set narctot [expr {[llength $varctok($v)] - 1}]
1067 set a $varcmod($v)
1068 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1069 # go up the tree until we find something that has a row number,
1070 # or we get to a seed
1071 set a [lindex $vupptr($v) $a]
1073 if {$a == 0} {
1074 set a [lindex $vdownptr($v) 0]
1075 if {$a == 0} return
1076 set vrownum($v) {0}
1077 set varcorder($v) [list $a]
1078 lset varcix($v) $a 0
1079 lset varcrow($v) $a 0
1080 set arcn 0
1081 set row 0
1082 } else {
1083 set arcn [lindex $varcix($v) $a]
1084 if {[llength $vrownum($v)] > $arcn + 1} {
1085 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1086 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1088 set row [lindex $varcrow($v) $a]
1090 while {1} {
1091 set p $a
1092 incr row [llength $varccommits($v,$a)]
1093 # go down if possible
1094 set b [lindex $vdownptr($v) $a]
1095 if {$b == 0} {
1096 # if not, go left, or go up until we can go left
1097 while {$a != 0} {
1098 set b [lindex $vleftptr($v) $a]
1099 if {$b != 0} break
1100 set a [lindex $vupptr($v) $a]
1102 if {$a == 0} break
1104 set a $b
1105 incr arcn
1106 lappend vrownum($v) $row
1107 lappend varcorder($v) $a
1108 lset varcix($v) $a $arcn
1109 lset varcrow($v) $a $row
1111 set vtokmod($v) [lindex $varctok($v) $p]
1112 set varcmod($v) $p
1113 set vrowmod($v) $row
1114 if {[info exists currentid]} {
1115 set selectedline [rowofcommit $currentid]
1119 # Test whether view $v contains commit $id
1120 proc commitinview {id v} {
1121 global varcid
1123 return [info exists varcid($v,$id)]
1126 # Return the row number for commit $id in the current view
1127 proc rowofcommit {id} {
1128 global varcid varccommits varcrow curview cached_commitrow
1129 global varctok vtokmod
1131 set v $curview
1132 if {![info exists varcid($v,$id)]} {
1133 puts "oops rowofcommit no arc for [shortids $id]"
1134 return {}
1136 set a $varcid($v,$id)
1137 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1138 update_arcrows $v
1140 if {[info exists cached_commitrow($id)]} {
1141 return $cached_commitrow($id)
1143 set i [lsearch -exact $varccommits($v,$a) $id]
1144 if {$i < 0} {
1145 puts "oops didn't find commit [shortids $id] in arc $a"
1146 return {}
1148 incr i [lindex $varcrow($v) $a]
1149 set cached_commitrow($id) $i
1150 return $i
1153 # Returns 1 if a is on an earlier row than b, otherwise 0
1154 proc comes_before {a b} {
1155 global varcid varctok curview
1157 set v $curview
1158 if {$a eq $b || ![info exists varcid($v,$a)] || \
1159 ![info exists varcid($v,$b)]} {
1160 return 0
1162 if {$varcid($v,$a) != $varcid($v,$b)} {
1163 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1164 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1166 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1169 proc bsearch {l elt} {
1170 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1171 return 0
1173 set lo 0
1174 set hi [llength $l]
1175 while {$hi - $lo > 1} {
1176 set mid [expr {int(($lo + $hi) / 2)}]
1177 set t [lindex $l $mid]
1178 if {$elt < $t} {
1179 set hi $mid
1180 } elseif {$elt > $t} {
1181 set lo $mid
1182 } else {
1183 return $mid
1186 return $lo
1189 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1190 proc make_disporder {start end} {
1191 global vrownum curview commitidx displayorder parentlist
1192 global varccommits varcorder parents vrowmod varcrow
1193 global d_valid_start d_valid_end
1195 if {$end > $vrowmod($curview)} {
1196 update_arcrows $curview
1198 set ai [bsearch $vrownum($curview) $start]
1199 set start [lindex $vrownum($curview) $ai]
1200 set narc [llength $vrownum($curview)]
1201 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1202 set a [lindex $varcorder($curview) $ai]
1203 set l [llength $displayorder]
1204 set al [llength $varccommits($curview,$a)]
1205 if {$l < $r + $al} {
1206 if {$l < $r} {
1207 set pad [ntimes [expr {$r - $l}] {}]
1208 set displayorder [concat $displayorder $pad]
1209 set parentlist [concat $parentlist $pad]
1210 } elseif {$l > $r} {
1211 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1212 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1214 foreach id $varccommits($curview,$a) {
1215 lappend displayorder $id
1216 lappend parentlist $parents($curview,$id)
1218 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1219 set i $r
1220 foreach id $varccommits($curview,$a) {
1221 lset displayorder $i $id
1222 lset parentlist $i $parents($curview,$id)
1223 incr i
1226 incr r $al
1230 proc commitonrow {row} {
1231 global displayorder
1233 set id [lindex $displayorder $row]
1234 if {$id eq {}} {
1235 make_disporder $row [expr {$row + 1}]
1236 set id [lindex $displayorder $row]
1238 return $id
1241 proc closevarcs {v} {
1242 global varctok varccommits varcid parents children
1243 global cmitlisted commitidx vtokmod
1245 set missing_parents 0
1246 set scripts {}
1247 set narcs [llength $varctok($v)]
1248 for {set a 1} {$a < $narcs} {incr a} {
1249 set id [lindex $varccommits($v,$a) end]
1250 foreach p $parents($v,$id) {
1251 if {[info exists varcid($v,$p)]} continue
1252 # add p as a new commit
1253 incr missing_parents
1254 set cmitlisted($v,$p) 0
1255 set parents($v,$p) {}
1256 if {[llength $children($v,$p)] == 1 &&
1257 [llength $parents($v,$id)] == 1} {
1258 set b $a
1259 } else {
1260 set b [newvarc $v $p]
1262 set varcid($v,$p) $b
1263 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1264 modify_arc $v $b
1266 lappend varccommits($v,$b) $p
1267 incr commitidx($v)
1268 set scripts [check_interest $p $scripts]
1271 if {$missing_parents > 0} {
1272 foreach s $scripts {
1273 eval $s
1278 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1279 # Assumes we already have an arc for $rwid.
1280 proc rewrite_commit {v id rwid} {
1281 global children parents varcid varctok vtokmod varccommits
1283 foreach ch $children($v,$id) {
1284 # make $rwid be $ch's parent in place of $id
1285 set i [lsearch -exact $parents($v,$ch) $id]
1286 if {$i < 0} {
1287 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1289 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1290 # add $ch to $rwid's children and sort the list if necessary
1291 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1292 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1293 $children($v,$rwid)]
1295 # fix the graph after joining $id to $rwid
1296 set a $varcid($v,$ch)
1297 fix_reversal $rwid $a $v
1298 # parentlist is wrong for the last element of arc $a
1299 # even if displayorder is right, hence the 3rd arg here
1300 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1304 # Mechanism for registering a command to be executed when we come
1305 # across a particular commit. To handle the case when only the
1306 # prefix of the commit is known, the commitinterest array is now
1307 # indexed by the first 4 characters of the ID. Each element is a
1308 # list of id, cmd pairs.
1309 proc interestedin {id cmd} {
1310 global commitinterest
1312 lappend commitinterest([string range $id 0 3]) $id $cmd
1315 proc check_interest {id scripts} {
1316 global commitinterest
1318 set prefix [string range $id 0 3]
1319 if {[info exists commitinterest($prefix)]} {
1320 set newlist {}
1321 foreach {i script} $commitinterest($prefix) {
1322 if {[string match "$i*" $id]} {
1323 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1324 } else {
1325 lappend newlist $i $script
1328 if {$newlist ne {}} {
1329 set commitinterest($prefix) $newlist
1330 } else {
1331 unset commitinterest($prefix)
1334 return $scripts
1337 proc getcommitlines {fd inst view updating} {
1338 global cmitlisted leftover
1339 global commitidx commitdata vdatemode
1340 global parents children curview hlview
1341 global idpending ordertok
1342 global varccommits varcid varctok vtokmod vfilelimit
1344 set stuff [read $fd 500000]
1345 # git log doesn't terminate the last commit with a null...
1346 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1347 set stuff "\0"
1349 if {$stuff == {}} {
1350 if {![eof $fd]} {
1351 return 1
1353 global commfd viewcomplete viewactive viewname
1354 global viewinstances
1355 unset commfd($inst)
1356 set i [lsearch -exact $viewinstances($view) $inst]
1357 if {$i >= 0} {
1358 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1360 # set it blocking so we wait for the process to terminate
1361 fconfigure $fd -blocking 1
1362 if {[catch {close $fd} err]} {
1363 set fv {}
1364 if {$view != $curview} {
1365 set fv " for the \"$viewname($view)\" view"
1367 if {[string range $err 0 4] == "usage"} {
1368 set err "Gitk: error reading commits$fv:\
1369 bad arguments to git log."
1370 if {$viewname($view) eq "Command line"} {
1371 append err \
1372 " (Note: arguments to gitk are passed to git log\
1373 to allow selection of commits to be displayed.)"
1375 } else {
1376 set err "Error reading commits$fv: $err"
1378 error_popup $err
1380 if {[incr viewactive($view) -1] <= 0} {
1381 set viewcomplete($view) 1
1382 # Check if we have seen any ids listed as parents that haven't
1383 # appeared in the list
1384 closevarcs $view
1385 notbusy $view
1387 if {$view == $curview} {
1388 run chewcommits
1390 return 0
1392 set start 0
1393 set gotsome 0
1394 set scripts {}
1395 while 1 {
1396 set i [string first "\0" $stuff $start]
1397 if {$i < 0} {
1398 append leftover($inst) [string range $stuff $start end]
1399 break
1401 if {$start == 0} {
1402 set cmit $leftover($inst)
1403 append cmit [string range $stuff 0 [expr {$i - 1}]]
1404 set leftover($inst) {}
1405 } else {
1406 set cmit [string range $stuff $start [expr {$i - 1}]]
1408 set start [expr {$i + 1}]
1409 set j [string first "\n" $cmit]
1410 set ok 0
1411 set listed 1
1412 if {$j >= 0 && [string match "commit *" $cmit]} {
1413 set ids [string range $cmit 7 [expr {$j - 1}]]
1414 if {[string match {[-^<>]*} $ids]} {
1415 switch -- [string index $ids 0] {
1416 "-" {set listed 0}
1417 "^" {set listed 2}
1418 "<" {set listed 3}
1419 ">" {set listed 4}
1421 set ids [string range $ids 1 end]
1423 set ok 1
1424 foreach id $ids {
1425 if {[string length $id] != 40} {
1426 set ok 0
1427 break
1431 if {!$ok} {
1432 set shortcmit $cmit
1433 if {[string length $shortcmit] > 80} {
1434 set shortcmit "[string range $shortcmit 0 80]..."
1436 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1437 exit 1
1439 set id [lindex $ids 0]
1440 set vid $view,$id
1442 if {!$listed && $updating && ![info exists varcid($vid)] &&
1443 $vfilelimit($view) ne {}} {
1444 # git log doesn't rewrite parents for unlisted commits
1445 # when doing path limiting, so work around that here
1446 # by working out the rewritten parent with git rev-list
1447 # and if we already know about it, using the rewritten
1448 # parent as a substitute parent for $id's children.
1449 if {![catch {
1450 set rwid [exec git rev-list --first-parent --max-count=1 \
1451 $id -- $vfilelimit($view)]
1452 }]} {
1453 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1454 # use $rwid in place of $id
1455 rewrite_commit $view $id $rwid
1456 continue
1461 set a 0
1462 if {[info exists varcid($vid)]} {
1463 if {$cmitlisted($vid) || !$listed} continue
1464 set a $varcid($vid)
1466 if {$listed} {
1467 set olds [lrange $ids 1 end]
1468 } else {
1469 set olds {}
1471 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1472 set cmitlisted($vid) $listed
1473 set parents($vid) $olds
1474 if {![info exists children($vid)]} {
1475 set children($vid) {}
1476 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1477 set k [lindex $children($vid) 0]
1478 if {[llength $parents($view,$k)] == 1 &&
1479 (!$vdatemode($view) ||
1480 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1481 set a $varcid($view,$k)
1484 if {$a == 0} {
1485 # new arc
1486 set a [newvarc $view $id]
1488 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1489 modify_arc $view $a
1491 if {![info exists varcid($vid)]} {
1492 set varcid($vid) $a
1493 lappend varccommits($view,$a) $id
1494 incr commitidx($view)
1497 set i 0
1498 foreach p $olds {
1499 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1500 set vp $view,$p
1501 if {[llength [lappend children($vp) $id]] > 1 &&
1502 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1503 set children($vp) [lsort -command [list vtokcmp $view] \
1504 $children($vp)]
1505 catch {unset ordertok}
1507 if {[info exists varcid($view,$p)]} {
1508 fix_reversal $p $a $view
1511 incr i
1514 set scripts [check_interest $id $scripts]
1515 set gotsome 1
1517 if {$gotsome} {
1518 global numcommits hlview
1520 if {$view == $curview} {
1521 set numcommits $commitidx($view)
1522 run chewcommits
1524 if {[info exists hlview] && $view == $hlview} {
1525 # we never actually get here...
1526 run vhighlightmore
1528 foreach s $scripts {
1529 eval $s
1532 return 2
1535 proc chewcommits {} {
1536 global curview hlview viewcomplete
1537 global pending_select
1539 layoutmore
1540 if {$viewcomplete($curview)} {
1541 global commitidx varctok
1542 global numcommits startmsecs
1544 if {[info exists pending_select]} {
1545 update
1546 reset_pending_select {}
1548 if {[commitinview $pending_select $curview]} {
1549 selectline [rowofcommit $pending_select] 1
1550 } else {
1551 set row [first_real_row]
1552 selectline $row 1
1555 if {$commitidx($curview) > 0} {
1556 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1557 #puts "overall $ms ms for $numcommits commits"
1558 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1559 } else {
1560 show_status [mc "No commits selected"]
1562 notbusy layout
1564 return 0
1567 proc do_readcommit {id} {
1568 global tclencoding
1570 # Invoke git-log to handle automatic encoding conversion
1571 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1572 # Read the results using i18n.logoutputencoding
1573 fconfigure $fd -translation lf -eofchar {}
1574 if {$tclencoding != {}} {
1575 fconfigure $fd -encoding $tclencoding
1577 set contents [read $fd]
1578 close $fd
1579 # Remove the heading line
1580 regsub {^commit [0-9a-f]+\n} $contents {} contents
1582 return $contents
1585 proc readcommit {id} {
1586 if {[catch {set contents [do_readcommit $id]}]} return
1587 parsecommit $id $contents 1
1590 proc parsecommit {id contents listed} {
1591 global commitinfo cdate
1593 set inhdr 1
1594 set comment {}
1595 set headline {}
1596 set auname {}
1597 set audate {}
1598 set comname {}
1599 set comdate {}
1600 set hdrend [string first "\n\n" $contents]
1601 if {$hdrend < 0} {
1602 # should never happen...
1603 set hdrend [string length $contents]
1605 set header [string range $contents 0 [expr {$hdrend - 1}]]
1606 set comment [string range $contents [expr {$hdrend + 2}] end]
1607 foreach line [split $header "\n"] {
1608 set tag [lindex $line 0]
1609 if {$tag == "author"} {
1610 set audate [lindex $line end-1]
1611 set auname [lrange $line 1 end-2]
1612 } elseif {$tag == "committer"} {
1613 set comdate [lindex $line end-1]
1614 set comname [lrange $line 1 end-2]
1617 set headline {}
1618 # take the first non-blank line of the comment as the headline
1619 set headline [string trimleft $comment]
1620 set i [string first "\n" $headline]
1621 if {$i >= 0} {
1622 set headline [string range $headline 0 $i]
1624 set headline [string trimright $headline]
1625 set i [string first "\r" $headline]
1626 if {$i >= 0} {
1627 set headline [string trimright [string range $headline 0 $i]]
1629 if {!$listed} {
1630 # git log indents the comment by 4 spaces;
1631 # if we got this via git cat-file, add the indentation
1632 set newcomment {}
1633 foreach line [split $comment "\n"] {
1634 append newcomment " "
1635 append newcomment $line
1636 append newcomment "\n"
1638 set comment $newcomment
1640 if {$comdate != {}} {
1641 set cdate($id) $comdate
1643 set commitinfo($id) [list $headline $auname $audate \
1644 $comname $comdate $comment]
1647 proc getcommit {id} {
1648 global commitdata commitinfo
1650 if {[info exists commitdata($id)]} {
1651 parsecommit $id $commitdata($id) 1
1652 } else {
1653 readcommit $id
1654 if {![info exists commitinfo($id)]} {
1655 set commitinfo($id) [list [mc "No commit information available"]]
1658 return 1
1661 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1662 # and are present in the current view.
1663 # This is fairly slow...
1664 proc longid {prefix} {
1665 global varcid curview
1667 set ids {}
1668 foreach match [array names varcid "$curview,$prefix*"] {
1669 lappend ids [lindex [split $match ","] 1]
1671 return $ids
1674 proc readrefs {} {
1675 global tagids idtags headids idheads tagobjid
1676 global otherrefids idotherrefs mainhead mainheadid
1677 global selecthead selectheadid
1679 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1680 catch {unset $v}
1682 set refd [open [list | git show-ref -d] r]
1683 while {[gets $refd line] >= 0} {
1684 if {[string index $line 40] ne " "} continue
1685 set id [string range $line 0 39]
1686 set ref [string range $line 41 end]
1687 if {![string match "refs/*" $ref]} continue
1688 set name [string range $ref 5 end]
1689 if {[string match "remotes/*" $name]} {
1690 if {![string match "*/HEAD" $name]} {
1691 set headids($name) $id
1692 lappend idheads($id) $name
1694 } elseif {[string match "heads/*" $name]} {
1695 set name [string range $name 6 end]
1696 set headids($name) $id
1697 lappend idheads($id) $name
1698 } elseif {[string match "tags/*" $name]} {
1699 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1700 # which is what we want since the former is the commit ID
1701 set name [string range $name 5 end]
1702 if {[string match "*^{}" $name]} {
1703 set name [string range $name 0 end-3]
1704 } else {
1705 set tagobjid($name) $id
1707 set tagids($name) $id
1708 lappend idtags($id) $name
1709 } else {
1710 set otherrefids($name) $id
1711 lappend idotherrefs($id) $name
1714 catch {close $refd}
1715 set mainhead {}
1716 set mainheadid {}
1717 catch {
1718 set mainheadid [exec git rev-parse HEAD]
1719 set thehead [exec git symbolic-ref HEAD]
1720 if {[string match "refs/heads/*" $thehead]} {
1721 set mainhead [string range $thehead 11 end]
1724 set selectheadid {}
1725 if {$selecthead ne {}} {
1726 catch {
1727 set selectheadid [exec git rev-parse --verify $selecthead]
1732 # skip over fake commits
1733 proc first_real_row {} {
1734 global nullid nullid2 numcommits
1736 for {set row 0} {$row < $numcommits} {incr row} {
1737 set id [commitonrow $row]
1738 if {$id ne $nullid && $id ne $nullid2} {
1739 break
1742 return $row
1745 # update things for a head moved to a child of its previous location
1746 proc movehead {id name} {
1747 global headids idheads
1749 removehead $headids($name) $name
1750 set headids($name) $id
1751 lappend idheads($id) $name
1754 # update things when a head has been removed
1755 proc removehead {id name} {
1756 global headids idheads
1758 if {$idheads($id) eq $name} {
1759 unset idheads($id)
1760 } else {
1761 set i [lsearch -exact $idheads($id) $name]
1762 if {$i >= 0} {
1763 set idheads($id) [lreplace $idheads($id) $i $i]
1766 unset headids($name)
1769 proc make_transient {window origin} {
1770 global have_tk85
1772 # In MacOS Tk 8.4 transient appears to work by setting
1773 # overrideredirect, which is utterly useless, since the
1774 # windows get no border, and are not even kept above
1775 # the parent.
1776 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1778 wm transient $window $origin
1780 # Windows fails to place transient windows normally, so
1781 # schedule a callback to center them on the parent.
1782 if {[tk windowingsystem] eq {win32}} {
1783 after idle [list tk::PlaceWindow $window widget $origin]
1787 proc show_error {w top msg} {
1788 message $w.m -text $msg -justify center -aspect 400
1789 pack $w.m -side top -fill x -padx 20 -pady 20
1790 button $w.ok -text [mc OK] -command "destroy $top"
1791 pack $w.ok -side bottom -fill x
1792 bind $top <Visibility> "grab $top; focus $top"
1793 bind $top <Key-Return> "destroy $top"
1794 bind $top <Key-space> "destroy $top"
1795 bind $top <Key-Escape> "destroy $top"
1796 tkwait window $top
1799 proc error_popup {msg {owner .}} {
1800 set w .error
1801 toplevel $w
1802 make_transient $w $owner
1803 show_error $w $w $msg
1806 proc confirm_popup {msg {owner .}} {
1807 global confirm_ok
1808 set confirm_ok 0
1809 set w .confirm
1810 toplevel $w
1811 make_transient $w $owner
1812 message $w.m -text $msg -justify center -aspect 400
1813 pack $w.m -side top -fill x -padx 20 -pady 20
1814 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1815 pack $w.ok -side left -fill x
1816 button $w.cancel -text [mc Cancel] -command "destroy $w"
1817 pack $w.cancel -side right -fill x
1818 bind $w <Visibility> "grab $w; focus $w"
1819 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1820 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1821 bind $w <Key-Escape> "destroy $w"
1822 tkwait window $w
1823 return $confirm_ok
1826 proc setoptions {} {
1827 option add *Panedwindow.showHandle 1 startupFile
1828 option add *Panedwindow.sashRelief raised startupFile
1829 option add *Button.font uifont startupFile
1830 option add *Checkbutton.font uifont startupFile
1831 option add *Radiobutton.font uifont startupFile
1832 option add *Menu.font uifont startupFile
1833 option add *Menubutton.font uifont startupFile
1834 option add *Label.font uifont startupFile
1835 option add *Message.font uifont startupFile
1836 option add *Entry.font uifont startupFile
1839 # Make a menu and submenus.
1840 # m is the window name for the menu, items is the list of menu items to add.
1841 # Each item is a list {mc label type description options...}
1842 # mc is ignored; it's so we can put mc there to alert xgettext
1843 # label is the string that appears in the menu
1844 # type is cascade, command or radiobutton (should add checkbutton)
1845 # description depends on type; it's the sublist for cascade, the
1846 # command to invoke for command, or {variable value} for radiobutton
1847 proc makemenu {m items} {
1848 menu $m
1849 if {[tk windowingsystem] eq {aqua}} {
1850 set Meta1 Cmd
1851 } else {
1852 set Meta1 Ctrl
1854 foreach i $items {
1855 set name [mc [lindex $i 1]]
1856 set type [lindex $i 2]
1857 set thing [lindex $i 3]
1858 set params [list $type]
1859 if {$name ne {}} {
1860 set u [string first "&" [string map {&& x} $name]]
1861 lappend params -label [string map {&& & & {}} $name]
1862 if {$u >= 0} {
1863 lappend params -underline $u
1866 switch -- $type {
1867 "cascade" {
1868 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1869 lappend params -menu $m.$submenu
1871 "command" {
1872 lappend params -command $thing
1874 "radiobutton" {
1875 lappend params -variable [lindex $thing 0] \
1876 -value [lindex $thing 1]
1879 set tail [lrange $i 4 end]
1880 regsub -all {\yMeta1\y} $tail $Meta1 tail
1881 eval $m add $params $tail
1882 if {$type eq "cascade"} {
1883 makemenu $m.$submenu $thing
1888 # translate string and remove ampersands
1889 proc mca {str} {
1890 return [string map {&& & & {}} [mc $str]]
1893 proc makewindow {} {
1894 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1895 global tabstop
1896 global findtype findtypemenu findloc findstring fstring geometry
1897 global entries sha1entry sha1string sha1but
1898 global diffcontextstring diffcontext
1899 global ignorespace
1900 global maincursor textcursor curtextcursor
1901 global rowctxmenu fakerowmenu mergemax wrapcomment
1902 global highlight_files gdttype
1903 global searchstring sstring
1904 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1905 global headctxmenu progresscanv progressitem progresscoords statusw
1906 global fprogitem fprogcoord lastprogupdate progupdatepending
1907 global rprogitem rprogcoord rownumsel numcommits
1908 global have_tk85
1910 # The "mc" arguments here are purely so that xgettext
1911 # sees the following string as needing to be translated
1912 makemenu .bar {
1913 {mc "File" cascade {
1914 {mc "Update" command updatecommits -accelerator F5}
1915 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1916 {mc "Reread references" command rereadrefs}
1917 {mc "List references" command showrefs -accelerator F2}
1918 {mc "Quit" command doquit -accelerator Meta1-Q}
1920 {mc "Edit" cascade {
1921 {mc "Preferences" command doprefs}
1923 {mc "View" cascade {
1924 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1925 {mc "Edit view..." command editview -state disabled -accelerator F4}
1926 {mc "Delete view" command delview -state disabled}
1927 {xx "" separator}
1928 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1930 {mc "Help" cascade {
1931 {mc "About gitk" command about}
1932 {mc "Key bindings" command keys}
1935 . configure -menu .bar
1937 # the gui has upper and lower half, parts of a paned window.
1938 panedwindow .ctop -orient vertical
1940 # possibly use assumed geometry
1941 if {![info exists geometry(pwsash0)]} {
1942 set geometry(topheight) [expr {15 * $linespc}]
1943 set geometry(topwidth) [expr {80 * $charspc}]
1944 set geometry(botheight) [expr {15 * $linespc}]
1945 set geometry(botwidth) [expr {50 * $charspc}]
1946 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1947 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1950 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1951 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1952 frame .tf.histframe
1953 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1955 # create three canvases
1956 set cscroll .tf.histframe.csb
1957 set canv .tf.histframe.pwclist.canv
1958 canvas $canv \
1959 -selectbackground $selectbgcolor \
1960 -background $bgcolor -bd 0 \
1961 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1962 .tf.histframe.pwclist add $canv
1963 set canv2 .tf.histframe.pwclist.canv2
1964 canvas $canv2 \
1965 -selectbackground $selectbgcolor \
1966 -background $bgcolor -bd 0 -yscrollincr $linespc
1967 .tf.histframe.pwclist add $canv2
1968 set canv3 .tf.histframe.pwclist.canv3
1969 canvas $canv3 \
1970 -selectbackground $selectbgcolor \
1971 -background $bgcolor -bd 0 -yscrollincr $linespc
1972 .tf.histframe.pwclist add $canv3
1973 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1974 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1976 # a scroll bar to rule them
1977 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1978 pack $cscroll -side right -fill y
1979 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1980 lappend bglist $canv $canv2 $canv3
1981 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1983 # we have two button bars at bottom of top frame. Bar 1
1984 frame .tf.bar
1985 frame .tf.lbar -height 15
1987 set sha1entry .tf.bar.sha1
1988 set entries $sha1entry
1989 set sha1but .tf.bar.sha1label
1990 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1991 -command gotocommit -width 8
1992 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1993 pack .tf.bar.sha1label -side left
1994 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1995 trace add variable sha1string write sha1change
1996 pack $sha1entry -side left -pady 2
1998 image create bitmap bm-left -data {
1999 #define left_width 16
2000 #define left_height 16
2001 static unsigned char left_bits[] = {
2002 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2003 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2004 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2006 image create bitmap bm-right -data {
2007 #define right_width 16
2008 #define right_height 16
2009 static unsigned char right_bits[] = {
2010 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2011 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2012 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2014 button .tf.bar.leftbut -image bm-left -command goback \
2015 -state disabled -width 26
2016 pack .tf.bar.leftbut -side left -fill y
2017 button .tf.bar.rightbut -image bm-right -command goforw \
2018 -state disabled -width 26
2019 pack .tf.bar.rightbut -side left -fill y
2021 label .tf.bar.rowlabel -text [mc "Row"]
2022 set rownumsel {}
2023 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2024 -relief sunken -anchor e
2025 label .tf.bar.rowlabel2 -text "/"
2026 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2027 -relief sunken -anchor e
2028 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2029 -side left
2030 global selectedline
2031 trace add variable selectedline write selectedline_change
2033 # Status label and progress bar
2034 set statusw .tf.bar.status
2035 label $statusw -width 15 -relief sunken
2036 pack $statusw -side left -padx 5
2037 set h [expr {[font metrics uifont -linespace] + 2}]
2038 set progresscanv .tf.bar.progress
2039 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2040 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2041 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2042 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2043 pack $progresscanv -side right -expand 1 -fill x
2044 set progresscoords {0 0}
2045 set fprogcoord 0
2046 set rprogcoord 0
2047 bind $progresscanv <Configure> adjustprogress
2048 set lastprogupdate [clock clicks -milliseconds]
2049 set progupdatepending 0
2051 # build up the bottom bar of upper window
2052 label .tf.lbar.flabel -text "[mc "Find"] "
2053 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2054 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2055 label .tf.lbar.flab2 -text " [mc "commit"] "
2056 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2057 -side left -fill y
2058 set gdttype [mc "containing:"]
2059 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2060 [mc "containing:"] \
2061 [mc "touching paths:"] \
2062 [mc "adding/removing string:"]]
2063 trace add variable gdttype write gdttype_change
2064 pack .tf.lbar.gdttype -side left -fill y
2066 set findstring {}
2067 set fstring .tf.lbar.findstring
2068 lappend entries $fstring
2069 entry $fstring -width 30 -font textfont -textvariable findstring
2070 trace add variable findstring write find_change
2071 set findtype [mc "Exact"]
2072 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2073 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2074 trace add variable findtype write findcom_change
2075 set findloc [mc "All fields"]
2076 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2077 [mc "Comments"] [mc "Author"] [mc "Committer"]
2078 trace add variable findloc write find_change
2079 pack .tf.lbar.findloc -side right
2080 pack .tf.lbar.findtype -side right
2081 pack $fstring -side left -expand 1 -fill x
2083 # Finish putting the upper half of the viewer together
2084 pack .tf.lbar -in .tf -side bottom -fill x
2085 pack .tf.bar -in .tf -side bottom -fill x
2086 pack .tf.histframe -fill both -side top -expand 1
2087 .ctop add .tf
2088 .ctop paneconfigure .tf -height $geometry(topheight)
2089 .ctop paneconfigure .tf -width $geometry(topwidth)
2091 # now build up the bottom
2092 panedwindow .pwbottom -orient horizontal
2094 # lower left, a text box over search bar, scroll bar to the right
2095 # if we know window height, then that will set the lower text height, otherwise
2096 # we set lower text height which will drive window height
2097 if {[info exists geometry(main)]} {
2098 frame .bleft -width $geometry(botwidth)
2099 } else {
2100 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2102 frame .bleft.top
2103 frame .bleft.mid
2104 frame .bleft.bottom
2106 button .bleft.top.search -text [mc "Search"] -command dosearch
2107 pack .bleft.top.search -side left -padx 5
2108 set sstring .bleft.top.sstring
2109 entry $sstring -width 20 -font textfont -textvariable searchstring
2110 lappend entries $sstring
2111 trace add variable searchstring write incrsearch
2112 pack $sstring -side left -expand 1 -fill x
2113 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2114 -command changediffdisp -variable diffelide -value {0 0}
2115 radiobutton .bleft.mid.old -text [mc "Old version"] \
2116 -command changediffdisp -variable diffelide -value {0 1}
2117 radiobutton .bleft.mid.new -text [mc "New version"] \
2118 -command changediffdisp -variable diffelide -value {1 0}
2119 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2120 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2121 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2122 -from 1 -increment 1 -to 10000000 \
2123 -validate all -validatecommand "diffcontextvalidate %P" \
2124 -textvariable diffcontextstring
2125 .bleft.mid.diffcontext set $diffcontext
2126 trace add variable diffcontextstring write diffcontextchange
2127 lappend entries .bleft.mid.diffcontext
2128 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2129 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2130 -command changeignorespace -variable ignorespace
2131 pack .bleft.mid.ignspace -side left -padx 5
2132 set ctext .bleft.bottom.ctext
2133 text $ctext -background $bgcolor -foreground $fgcolor \
2134 -state disabled -font textfont \
2135 -yscrollcommand scrolltext -wrap none \
2136 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2137 if {$have_tk85} {
2138 $ctext conf -tabstyle wordprocessor
2140 scrollbar .bleft.bottom.sb -command "$ctext yview"
2141 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2142 -width 10
2143 pack .bleft.top -side top -fill x
2144 pack .bleft.mid -side top -fill x
2145 grid $ctext .bleft.bottom.sb -sticky nsew
2146 grid .bleft.bottom.sbhorizontal -sticky ew
2147 grid columnconfigure .bleft.bottom 0 -weight 1
2148 grid rowconfigure .bleft.bottom 0 -weight 1
2149 grid rowconfigure .bleft.bottom 1 -weight 0
2150 pack .bleft.bottom -side top -fill both -expand 1
2151 lappend bglist $ctext
2152 lappend fglist $ctext
2154 $ctext tag conf comment -wrap $wrapcomment
2155 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2156 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2157 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2158 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2159 $ctext tag conf m0 -fore red
2160 $ctext tag conf m1 -fore blue
2161 $ctext tag conf m2 -fore green
2162 $ctext tag conf m3 -fore purple
2163 $ctext tag conf m4 -fore brown
2164 $ctext tag conf m5 -fore "#009090"
2165 $ctext tag conf m6 -fore magenta
2166 $ctext tag conf m7 -fore "#808000"
2167 $ctext tag conf m8 -fore "#009000"
2168 $ctext tag conf m9 -fore "#ff0080"
2169 $ctext tag conf m10 -fore cyan
2170 $ctext tag conf m11 -fore "#b07070"
2171 $ctext tag conf m12 -fore "#70b0f0"
2172 $ctext tag conf m13 -fore "#70f0b0"
2173 $ctext tag conf m14 -fore "#f0b070"
2174 $ctext tag conf m15 -fore "#ff70b0"
2175 $ctext tag conf mmax -fore darkgrey
2176 set mergemax 16
2177 $ctext tag conf mresult -font textfontbold
2178 $ctext tag conf msep -font textfontbold
2179 $ctext tag conf found -back yellow
2181 .pwbottom add .bleft
2182 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2184 # lower right
2185 frame .bright
2186 frame .bright.mode
2187 radiobutton .bright.mode.patch -text [mc "Patch"] \
2188 -command reselectline -variable cmitmode -value "patch"
2189 radiobutton .bright.mode.tree -text [mc "Tree"] \
2190 -command reselectline -variable cmitmode -value "tree"
2191 grid .bright.mode.patch .bright.mode.tree -sticky ew
2192 pack .bright.mode -side top -fill x
2193 set cflist .bright.cfiles
2194 set indent [font measure mainfont "nn"]
2195 text $cflist \
2196 -selectbackground $selectbgcolor \
2197 -background $bgcolor -foreground $fgcolor \
2198 -font mainfont \
2199 -tabs [list $indent [expr {2 * $indent}]] \
2200 -yscrollcommand ".bright.sb set" \
2201 -cursor [. cget -cursor] \
2202 -spacing1 1 -spacing3 1
2203 lappend bglist $cflist
2204 lappend fglist $cflist
2205 scrollbar .bright.sb -command "$cflist yview"
2206 pack .bright.sb -side right -fill y
2207 pack $cflist -side left -fill both -expand 1
2208 $cflist tag configure highlight \
2209 -background [$cflist cget -selectbackground]
2210 $cflist tag configure bold -font mainfontbold
2212 .pwbottom add .bright
2213 .ctop add .pwbottom
2215 # restore window width & height if known
2216 if {[info exists geometry(main)]} {
2217 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2218 if {$w > [winfo screenwidth .]} {
2219 set w [winfo screenwidth .]
2221 if {$h > [winfo screenheight .]} {
2222 set h [winfo screenheight .]
2224 wm geometry . "${w}x$h"
2228 if {[tk windowingsystem] eq {aqua}} {
2229 set M1B M1
2230 } else {
2231 set M1B Control
2234 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2235 pack .ctop -fill both -expand 1
2236 bindall <1> {selcanvline %W %x %y}
2237 #bindall <B1-Motion> {selcanvline %W %x %y}
2238 if {[tk windowingsystem] == "win32"} {
2239 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2240 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2241 } else {
2242 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2243 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2244 if {[tk windowingsystem] eq "aqua"} {
2245 bindall <MouseWheel> {
2246 set delta [expr {- (%D)}]
2247 allcanvs yview scroll $delta units
2251 bindall <2> "canvscan mark %W %x %y"
2252 bindall <B2-Motion> "canvscan dragto %W %x %y"
2253 bindkey <Home> selfirstline
2254 bindkey <End> sellastline
2255 bind . <Key-Up> "selnextline -1"
2256 bind . <Key-Down> "selnextline 1"
2257 bind . <Shift-Key-Up> "dofind -1 0"
2258 bind . <Shift-Key-Down> "dofind 1 0"
2259 bindkey <Key-Right> "goforw"
2260 bindkey <Key-Left> "goback"
2261 bind . <Key-Prior> "selnextpage -1"
2262 bind . <Key-Next> "selnextpage 1"
2263 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2264 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2265 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2266 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2267 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2268 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2269 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2270 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2271 bindkey <Key-space> "$ctext yview scroll 1 pages"
2272 bindkey p "selnextline -1"
2273 bindkey n "selnextline 1"
2274 bindkey z "goback"
2275 bindkey x "goforw"
2276 bindkey i "selnextline -1"
2277 bindkey k "selnextline 1"
2278 bindkey j "goback"
2279 bindkey l "goforw"
2280 bindkey b prevfile
2281 bindkey d "$ctext yview scroll 18 units"
2282 bindkey u "$ctext yview scroll -18 units"
2283 bindkey / {dofind 1 1}
2284 bindkey <Key-Return> {dofind 1 1}
2285 bindkey ? {dofind -1 1}
2286 bindkey f nextfile
2287 bind . <F5> updatecommits
2288 bind . <$M1B-F5> reloadcommits
2289 bind . <F2> showrefs
2290 bind . <Shift-F4> {newview 0}
2291 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2292 bind . <F4> edit_or_newview
2293 bind . <$M1B-q> doquit
2294 bind . <$M1B-f> {dofind 1 1}
2295 bind . <$M1B-g> {dofind 1 0}
2296 bind . <$M1B-r> dosearchback
2297 bind . <$M1B-s> dosearch
2298 bind . <$M1B-equal> {incrfont 1}
2299 bind . <$M1B-plus> {incrfont 1}
2300 bind . <$M1B-KP_Add> {incrfont 1}
2301 bind . <$M1B-minus> {incrfont -1}
2302 bind . <$M1B-KP_Subtract> {incrfont -1}
2303 wm protocol . WM_DELETE_WINDOW doquit
2304 bind . <Destroy> {stop_backends}
2305 bind . <Button-1> "click %W"
2306 bind $fstring <Key-Return> {dofind 1 1}
2307 bind $sha1entry <Key-Return> {gotocommit; break}
2308 bind $sha1entry <<PasteSelection>> clearsha1
2309 bind $cflist <1> {sel_flist %W %x %y; break}
2310 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2311 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2312 global ctxbut
2313 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2314 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2316 set maincursor [. cget -cursor]
2317 set textcursor [$ctext cget -cursor]
2318 set curtextcursor $textcursor
2320 set rowctxmenu .rowctxmenu
2321 makemenu $rowctxmenu {
2322 {mc "Diff this -> selected" command {diffvssel 0}}
2323 {mc "Diff selected -> this" command {diffvssel 1}}
2324 {mc "Make patch" command mkpatch}
2325 {mc "Create tag" command mktag}
2326 {mc "Write commit to file" command writecommit}
2327 {mc "Create new branch" command mkbranch}
2328 {mc "Cherry-pick this commit" command cherrypick}
2329 {mc "Reset HEAD branch to here" command resethead}
2331 $rowctxmenu configure -tearoff 0
2333 set fakerowmenu .fakerowmenu
2334 makemenu $fakerowmenu {
2335 {mc "Diff this -> selected" command {diffvssel 0}}
2336 {mc "Diff selected -> this" command {diffvssel 1}}
2337 {mc "Make patch" command mkpatch}
2339 $fakerowmenu configure -tearoff 0
2341 set headctxmenu .headctxmenu
2342 makemenu $headctxmenu {
2343 {mc "Check out this branch" command cobranch}
2344 {mc "Remove this branch" command rmbranch}
2346 $headctxmenu configure -tearoff 0
2348 global flist_menu
2349 set flist_menu .flistctxmenu
2350 makemenu $flist_menu {
2351 {mc "Highlight this too" command {flist_hl 0}}
2352 {mc "Highlight this only" command {flist_hl 1}}
2353 {mc "External diff" command {external_diff}}
2354 {mc "Blame parent commit" command {external_blame 1}}
2356 $flist_menu configure -tearoff 0
2358 global diff_menu
2359 set diff_menu .diffctxmenu
2360 makemenu $diff_menu {
2361 {mc "Show origin of this line" command show_line_source}
2362 {mc "Run git gui blame on this line" command {external_blame_diff}}
2364 $diff_menu configure -tearoff 0
2367 # Windows sends all mouse wheel events to the current focused window, not
2368 # the one where the mouse hovers, so bind those events here and redirect
2369 # to the correct window
2370 proc windows_mousewheel_redirector {W X Y D} {
2371 global canv canv2 canv3
2372 set w [winfo containing -displayof $W $X $Y]
2373 if {$w ne ""} {
2374 set u [expr {$D < 0 ? 5 : -5}]
2375 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2376 allcanvs yview scroll $u units
2377 } else {
2378 catch {
2379 $w yview scroll $u units
2385 # Update row number label when selectedline changes
2386 proc selectedline_change {n1 n2 op} {
2387 global selectedline rownumsel
2389 if {$selectedline eq {}} {
2390 set rownumsel {}
2391 } else {
2392 set rownumsel [expr {$selectedline + 1}]
2396 # mouse-2 makes all windows scan vertically, but only the one
2397 # the cursor is in scans horizontally
2398 proc canvscan {op w x y} {
2399 global canv canv2 canv3
2400 foreach c [list $canv $canv2 $canv3] {
2401 if {$c == $w} {
2402 $c scan $op $x $y
2403 } else {
2404 $c scan $op 0 $y
2409 proc scrollcanv {cscroll f0 f1} {
2410 $cscroll set $f0 $f1
2411 drawvisible
2412 flushhighlights
2415 # when we make a key binding for the toplevel, make sure
2416 # it doesn't get triggered when that key is pressed in the
2417 # find string entry widget.
2418 proc bindkey {ev script} {
2419 global entries
2420 bind . $ev $script
2421 set escript [bind Entry $ev]
2422 if {$escript == {}} {
2423 set escript [bind Entry <Key>]
2425 foreach e $entries {
2426 bind $e $ev "$escript; break"
2430 # set the focus back to the toplevel for any click outside
2431 # the entry widgets
2432 proc click {w} {
2433 global ctext entries
2434 foreach e [concat $entries $ctext] {
2435 if {$w == $e} return
2437 focus .
2440 # Adjust the progress bar for a change in requested extent or canvas size
2441 proc adjustprogress {} {
2442 global progresscanv progressitem progresscoords
2443 global fprogitem fprogcoord lastprogupdate progupdatepending
2444 global rprogitem rprogcoord
2446 set w [expr {[winfo width $progresscanv] - 4}]
2447 set x0 [expr {$w * [lindex $progresscoords 0]}]
2448 set x1 [expr {$w * [lindex $progresscoords 1]}]
2449 set h [winfo height $progresscanv]
2450 $progresscanv coords $progressitem $x0 0 $x1 $h
2451 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2452 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2453 set now [clock clicks -milliseconds]
2454 if {$now >= $lastprogupdate + 100} {
2455 set progupdatepending 0
2456 update
2457 } elseif {!$progupdatepending} {
2458 set progupdatepending 1
2459 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2463 proc doprogupdate {} {
2464 global lastprogupdate progupdatepending
2466 if {$progupdatepending} {
2467 set progupdatepending 0
2468 set lastprogupdate [clock clicks -milliseconds]
2469 update
2473 proc savestuff {w} {
2474 global canv canv2 canv3 mainfont textfont uifont tabstop
2475 global stuffsaved findmergefiles maxgraphpct
2476 global maxwidth showneartags showlocalchanges
2477 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2478 global cmitmode wrapcomment datetimeformat limitdiffs
2479 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2480 global autoselect extdifftool perfile_attrs markbgcolor
2482 if {$stuffsaved} return
2483 if {![winfo viewable .]} return
2484 catch {
2485 set f [open "~/.gitk-new" w]
2486 puts $f [list set mainfont $mainfont]
2487 puts $f [list set textfont $textfont]
2488 puts $f [list set uifont $uifont]
2489 puts $f [list set tabstop $tabstop]
2490 puts $f [list set findmergefiles $findmergefiles]
2491 puts $f [list set maxgraphpct $maxgraphpct]
2492 puts $f [list set maxwidth $maxwidth]
2493 puts $f [list set cmitmode $cmitmode]
2494 puts $f [list set wrapcomment $wrapcomment]
2495 puts $f [list set autoselect $autoselect]
2496 puts $f [list set showneartags $showneartags]
2497 puts $f [list set showlocalchanges $showlocalchanges]
2498 puts $f [list set datetimeformat $datetimeformat]
2499 puts $f [list set limitdiffs $limitdiffs]
2500 puts $f [list set bgcolor $bgcolor]
2501 puts $f [list set fgcolor $fgcolor]
2502 puts $f [list set colors $colors]
2503 puts $f [list set diffcolors $diffcolors]
2504 puts $f [list set markbgcolor $markbgcolor]
2505 puts $f [list set diffcontext $diffcontext]
2506 puts $f [list set selectbgcolor $selectbgcolor]
2507 puts $f [list set extdifftool $extdifftool]
2508 puts $f [list set perfile_attrs $perfile_attrs]
2510 puts $f "set geometry(main) [wm geometry .]"
2511 puts $f "set geometry(topwidth) [winfo width .tf]"
2512 puts $f "set geometry(topheight) [winfo height .tf]"
2513 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2514 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2515 puts $f "set geometry(botwidth) [winfo width .bleft]"
2516 puts $f "set geometry(botheight) [winfo height .bleft]"
2518 puts -nonewline $f "set permviews {"
2519 for {set v 0} {$v < $nextviewnum} {incr v} {
2520 if {$viewperm($v)} {
2521 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2524 puts $f "}"
2525 close $f
2526 file rename -force "~/.gitk-new" "~/.gitk"
2528 set stuffsaved 1
2531 proc resizeclistpanes {win w} {
2532 global oldwidth
2533 if {[info exists oldwidth($win)]} {
2534 set s0 [$win sash coord 0]
2535 set s1 [$win sash coord 1]
2536 if {$w < 60} {
2537 set sash0 [expr {int($w/2 - 2)}]
2538 set sash1 [expr {int($w*5/6 - 2)}]
2539 } else {
2540 set factor [expr {1.0 * $w / $oldwidth($win)}]
2541 set sash0 [expr {int($factor * [lindex $s0 0])}]
2542 set sash1 [expr {int($factor * [lindex $s1 0])}]
2543 if {$sash0 < 30} {
2544 set sash0 30
2546 if {$sash1 < $sash0 + 20} {
2547 set sash1 [expr {$sash0 + 20}]
2549 if {$sash1 > $w - 10} {
2550 set sash1 [expr {$w - 10}]
2551 if {$sash0 > $sash1 - 20} {
2552 set sash0 [expr {$sash1 - 20}]
2556 $win sash place 0 $sash0 [lindex $s0 1]
2557 $win sash place 1 $sash1 [lindex $s1 1]
2559 set oldwidth($win) $w
2562 proc resizecdetpanes {win w} {
2563 global oldwidth
2564 if {[info exists oldwidth($win)]} {
2565 set s0 [$win sash coord 0]
2566 if {$w < 60} {
2567 set sash0 [expr {int($w*3/4 - 2)}]
2568 } else {
2569 set factor [expr {1.0 * $w / $oldwidth($win)}]
2570 set sash0 [expr {int($factor * [lindex $s0 0])}]
2571 if {$sash0 < 45} {
2572 set sash0 45
2574 if {$sash0 > $w - 15} {
2575 set sash0 [expr {$w - 15}]
2578 $win sash place 0 $sash0 [lindex $s0 1]
2580 set oldwidth($win) $w
2583 proc allcanvs args {
2584 global canv canv2 canv3
2585 eval $canv $args
2586 eval $canv2 $args
2587 eval $canv3 $args
2590 proc bindall {event action} {
2591 global canv canv2 canv3
2592 bind $canv $event $action
2593 bind $canv2 $event $action
2594 bind $canv3 $event $action
2597 proc about {} {
2598 global uifont
2599 set w .about
2600 if {[winfo exists $w]} {
2601 raise $w
2602 return
2604 toplevel $w
2605 wm title $w [mc "About gitk"]
2606 make_transient $w .
2607 message $w.m -text [mc "
2608 Gitk - a commit viewer for git
2610 Copyright © 2005-2008 Paul Mackerras
2612 Use and redistribute under the terms of the GNU General Public License"] \
2613 -justify center -aspect 400 -border 2 -bg white -relief groove
2614 pack $w.m -side top -fill x -padx 2 -pady 2
2615 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2616 pack $w.ok -side bottom
2617 bind $w <Visibility> "focus $w.ok"
2618 bind $w <Key-Escape> "destroy $w"
2619 bind $w <Key-Return> "destroy $w"
2622 proc keys {} {
2623 set w .keys
2624 if {[winfo exists $w]} {
2625 raise $w
2626 return
2628 if {[tk windowingsystem] eq {aqua}} {
2629 set M1T Cmd
2630 } else {
2631 set M1T Ctrl
2633 toplevel $w
2634 wm title $w [mc "Gitk key bindings"]
2635 make_transient $w .
2636 message $w.m -text "
2637 [mc "Gitk key bindings:"]
2639 [mc "<%s-Q> Quit" $M1T]
2640 [mc "<Home> Move to first commit"]
2641 [mc "<End> Move to last commit"]
2642 [mc "<Up>, p, i Move up one commit"]
2643 [mc "<Down>, n, k Move down one commit"]
2644 [mc "<Left>, z, j Go back in history list"]
2645 [mc "<Right>, x, l Go forward in history list"]
2646 [mc "<PageUp> Move up one page in commit list"]
2647 [mc "<PageDown> Move down one page in commit list"]
2648 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2649 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2650 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2651 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2652 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2653 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2654 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2655 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2656 [mc "<Delete>, b Scroll diff view up one page"]
2657 [mc "<Backspace> Scroll diff view up one page"]
2658 [mc "<Space> Scroll diff view down one page"]
2659 [mc "u Scroll diff view up 18 lines"]
2660 [mc "d Scroll diff view down 18 lines"]
2661 [mc "<%s-F> Find" $M1T]
2662 [mc "<%s-G> Move to next find hit" $M1T]
2663 [mc "<Return> Move to next find hit"]
2664 [mc "/ Move to next find hit, or redo find"]
2665 [mc "? Move to previous find hit"]
2666 [mc "f Scroll diff view to next file"]
2667 [mc "<%s-S> Search for next hit in diff view" $M1T]
2668 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2669 [mc "<%s-KP+> Increase font size" $M1T]
2670 [mc "<%s-plus> Increase font size" $M1T]
2671 [mc "<%s-KP-> Decrease font size" $M1T]
2672 [mc "<%s-minus> Decrease font size" $M1T]
2673 [mc "<F5> Update"]
2675 -justify left -bg white -border 2 -relief groove
2676 pack $w.m -side top -fill both -padx 2 -pady 2
2677 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2678 bind $w <Key-Escape> [list destroy $w]
2679 pack $w.ok -side bottom
2680 bind $w <Visibility> "focus $w.ok"
2681 bind $w <Key-Escape> "destroy $w"
2682 bind $w <Key-Return> "destroy $w"
2685 # Procedures for manipulating the file list window at the
2686 # bottom right of the overall window.
2688 proc treeview {w l openlevs} {
2689 global treecontents treediropen treeheight treeparent treeindex
2691 set ix 0
2692 set treeindex() 0
2693 set lev 0
2694 set prefix {}
2695 set prefixend -1
2696 set prefendstack {}
2697 set htstack {}
2698 set ht 0
2699 set treecontents() {}
2700 $w conf -state normal
2701 foreach f $l {
2702 while {[string range $f 0 $prefixend] ne $prefix} {
2703 if {$lev <= $openlevs} {
2704 $w mark set e:$treeindex($prefix) "end -1c"
2705 $w mark gravity e:$treeindex($prefix) left
2707 set treeheight($prefix) $ht
2708 incr ht [lindex $htstack end]
2709 set htstack [lreplace $htstack end end]
2710 set prefixend [lindex $prefendstack end]
2711 set prefendstack [lreplace $prefendstack end end]
2712 set prefix [string range $prefix 0 $prefixend]
2713 incr lev -1
2715 set tail [string range $f [expr {$prefixend+1}] end]
2716 while {[set slash [string first "/" $tail]] >= 0} {
2717 lappend htstack $ht
2718 set ht 0
2719 lappend prefendstack $prefixend
2720 incr prefixend [expr {$slash + 1}]
2721 set d [string range $tail 0 $slash]
2722 lappend treecontents($prefix) $d
2723 set oldprefix $prefix
2724 append prefix $d
2725 set treecontents($prefix) {}
2726 set treeindex($prefix) [incr ix]
2727 set treeparent($prefix) $oldprefix
2728 set tail [string range $tail [expr {$slash+1}] end]
2729 if {$lev <= $openlevs} {
2730 set ht 1
2731 set treediropen($prefix) [expr {$lev < $openlevs}]
2732 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2733 $w mark set d:$ix "end -1c"
2734 $w mark gravity d:$ix left
2735 set str "\n"
2736 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2737 $w insert end $str
2738 $w image create end -align center -image $bm -padx 1 \
2739 -name a:$ix
2740 $w insert end $d [highlight_tag $prefix]
2741 $w mark set s:$ix "end -1c"
2742 $w mark gravity s:$ix left
2744 incr lev
2746 if {$tail ne {}} {
2747 if {$lev <= $openlevs} {
2748 incr ht
2749 set str "\n"
2750 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2751 $w insert end $str
2752 $w insert end $tail [highlight_tag $f]
2754 lappend treecontents($prefix) $tail
2757 while {$htstack ne {}} {
2758 set treeheight($prefix) $ht
2759 incr ht [lindex $htstack end]
2760 set htstack [lreplace $htstack end end]
2761 set prefixend [lindex $prefendstack end]
2762 set prefendstack [lreplace $prefendstack end end]
2763 set prefix [string range $prefix 0 $prefixend]
2765 $w conf -state disabled
2768 proc linetoelt {l} {
2769 global treeheight treecontents
2771 set y 2
2772 set prefix {}
2773 while {1} {
2774 foreach e $treecontents($prefix) {
2775 if {$y == $l} {
2776 return "$prefix$e"
2778 set n 1
2779 if {[string index $e end] eq "/"} {
2780 set n $treeheight($prefix$e)
2781 if {$y + $n > $l} {
2782 append prefix $e
2783 incr y
2784 break
2787 incr y $n
2792 proc highlight_tree {y prefix} {
2793 global treeheight treecontents cflist
2795 foreach e $treecontents($prefix) {
2796 set path $prefix$e
2797 if {[highlight_tag $path] ne {}} {
2798 $cflist tag add bold $y.0 "$y.0 lineend"
2800 incr y
2801 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2802 set y [highlight_tree $y $path]
2805 return $y
2808 proc treeclosedir {w dir} {
2809 global treediropen treeheight treeparent treeindex
2811 set ix $treeindex($dir)
2812 $w conf -state normal
2813 $w delete s:$ix e:$ix
2814 set treediropen($dir) 0
2815 $w image configure a:$ix -image tri-rt
2816 $w conf -state disabled
2817 set n [expr {1 - $treeheight($dir)}]
2818 while {$dir ne {}} {
2819 incr treeheight($dir) $n
2820 set dir $treeparent($dir)
2824 proc treeopendir {w dir} {
2825 global treediropen treeheight treeparent treecontents treeindex
2827 set ix $treeindex($dir)
2828 $w conf -state normal
2829 $w image configure a:$ix -image tri-dn
2830 $w mark set e:$ix s:$ix
2831 $w mark gravity e:$ix right
2832 set lev 0
2833 set str "\n"
2834 set n [llength $treecontents($dir)]
2835 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2836 incr lev
2837 append str "\t"
2838 incr treeheight($x) $n
2840 foreach e $treecontents($dir) {
2841 set de $dir$e
2842 if {[string index $e end] eq "/"} {
2843 set iy $treeindex($de)
2844 $w mark set d:$iy e:$ix
2845 $w mark gravity d:$iy left
2846 $w insert e:$ix $str
2847 set treediropen($de) 0
2848 $w image create e:$ix -align center -image tri-rt -padx 1 \
2849 -name a:$iy
2850 $w insert e:$ix $e [highlight_tag $de]
2851 $w mark set s:$iy e:$ix
2852 $w mark gravity s:$iy left
2853 set treeheight($de) 1
2854 } else {
2855 $w insert e:$ix $str
2856 $w insert e:$ix $e [highlight_tag $de]
2859 $w mark gravity e:$ix right
2860 $w conf -state disabled
2861 set treediropen($dir) 1
2862 set top [lindex [split [$w index @0,0] .] 0]
2863 set ht [$w cget -height]
2864 set l [lindex [split [$w index s:$ix] .] 0]
2865 if {$l < $top} {
2866 $w yview $l.0
2867 } elseif {$l + $n + 1 > $top + $ht} {
2868 set top [expr {$l + $n + 2 - $ht}]
2869 if {$l < $top} {
2870 set top $l
2872 $w yview $top.0
2876 proc treeclick {w x y} {
2877 global treediropen cmitmode ctext cflist cflist_top
2879 if {$cmitmode ne "tree"} return
2880 if {![info exists cflist_top]} return
2881 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2882 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2883 $cflist tag add highlight $l.0 "$l.0 lineend"
2884 set cflist_top $l
2885 if {$l == 1} {
2886 $ctext yview 1.0
2887 return
2889 set e [linetoelt $l]
2890 if {[string index $e end] ne "/"} {
2891 showfile $e
2892 } elseif {$treediropen($e)} {
2893 treeclosedir $w $e
2894 } else {
2895 treeopendir $w $e
2899 proc setfilelist {id} {
2900 global treefilelist cflist jump_to_here
2902 treeview $cflist $treefilelist($id) 0
2903 if {$jump_to_here ne {}} {
2904 set f [lindex $jump_to_here 0]
2905 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2906 showfile $f
2911 image create bitmap tri-rt -background black -foreground blue -data {
2912 #define tri-rt_width 13
2913 #define tri-rt_height 13
2914 static unsigned char tri-rt_bits[] = {
2915 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2916 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2917 0x00, 0x00};
2918 } -maskdata {
2919 #define tri-rt-mask_width 13
2920 #define tri-rt-mask_height 13
2921 static unsigned char tri-rt-mask_bits[] = {
2922 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2923 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2924 0x08, 0x00};
2926 image create bitmap tri-dn -background black -foreground blue -data {
2927 #define tri-dn_width 13
2928 #define tri-dn_height 13
2929 static unsigned char tri-dn_bits[] = {
2930 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2931 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2932 0x00, 0x00};
2933 } -maskdata {
2934 #define tri-dn-mask_width 13
2935 #define tri-dn-mask_height 13
2936 static unsigned char tri-dn-mask_bits[] = {
2937 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2938 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2939 0x00, 0x00};
2942 image create bitmap reficon-T -background black -foreground yellow -data {
2943 #define tagicon_width 13
2944 #define tagicon_height 9
2945 static unsigned char tagicon_bits[] = {
2946 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2947 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2948 } -maskdata {
2949 #define tagicon-mask_width 13
2950 #define tagicon-mask_height 9
2951 static unsigned char tagicon-mask_bits[] = {
2952 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2953 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2955 set rectdata {
2956 #define headicon_width 13
2957 #define headicon_height 9
2958 static unsigned char headicon_bits[] = {
2959 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2960 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2962 set rectmask {
2963 #define headicon-mask_width 13
2964 #define headicon-mask_height 9
2965 static unsigned char headicon-mask_bits[] = {
2966 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2967 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2969 image create bitmap reficon-H -background black -foreground green \
2970 -data $rectdata -maskdata $rectmask
2971 image create bitmap reficon-o -background black -foreground "#ddddff" \
2972 -data $rectdata -maskdata $rectmask
2974 proc init_flist {first} {
2975 global cflist cflist_top difffilestart
2977 $cflist conf -state normal
2978 $cflist delete 0.0 end
2979 if {$first ne {}} {
2980 $cflist insert end $first
2981 set cflist_top 1
2982 $cflist tag add highlight 1.0 "1.0 lineend"
2983 } else {
2984 catch {unset cflist_top}
2986 $cflist conf -state disabled
2987 set difffilestart {}
2990 proc highlight_tag {f} {
2991 global highlight_paths
2993 foreach p $highlight_paths {
2994 if {[string match $p $f]} {
2995 return "bold"
2998 return {}
3001 proc highlight_filelist {} {
3002 global cmitmode cflist
3004 $cflist conf -state normal
3005 if {$cmitmode ne "tree"} {
3006 set end [lindex [split [$cflist index end] .] 0]
3007 for {set l 2} {$l < $end} {incr l} {
3008 set line [$cflist get $l.0 "$l.0 lineend"]
3009 if {[highlight_tag $line] ne {}} {
3010 $cflist tag add bold $l.0 "$l.0 lineend"
3013 } else {
3014 highlight_tree 2 {}
3016 $cflist conf -state disabled
3019 proc unhighlight_filelist {} {
3020 global cflist
3022 $cflist conf -state normal
3023 $cflist tag remove bold 1.0 end
3024 $cflist conf -state disabled
3027 proc add_flist {fl} {
3028 global cflist
3030 $cflist conf -state normal
3031 foreach f $fl {
3032 $cflist insert end "\n"
3033 $cflist insert end $f [highlight_tag $f]
3035 $cflist conf -state disabled
3038 proc sel_flist {w x y} {
3039 global ctext difffilestart cflist cflist_top cmitmode
3041 if {$cmitmode eq "tree"} return
3042 if {![info exists cflist_top]} return
3043 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3044 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3045 $cflist tag add highlight $l.0 "$l.0 lineend"
3046 set cflist_top $l
3047 if {$l == 1} {
3048 $ctext yview 1.0
3049 } else {
3050 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3054 proc pop_flist_menu {w X Y x y} {
3055 global ctext cflist cmitmode flist_menu flist_menu_file
3056 global treediffs diffids
3058 stopfinding
3059 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3060 if {$l <= 1} return
3061 if {$cmitmode eq "tree"} {
3062 set e [linetoelt $l]
3063 if {[string index $e end] eq "/"} return
3064 } else {
3065 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3067 set flist_menu_file $e
3068 set xdiffstate "normal"
3069 if {$cmitmode eq "tree"} {
3070 set xdiffstate "disabled"
3072 # Disable "External diff" item in tree mode
3073 $flist_menu entryconf 2 -state $xdiffstate
3074 tk_popup $flist_menu $X $Y
3077 proc find_ctext_fileinfo {line} {
3078 global ctext_file_names ctext_file_lines
3080 set ok [bsearch $ctext_file_lines $line]
3081 set tline [lindex $ctext_file_lines $ok]
3083 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3084 return {}
3085 } else {
3086 return [list [lindex $ctext_file_names $ok] $tline]
3090 proc pop_diff_menu {w X Y x y} {
3091 global ctext diff_menu flist_menu_file
3092 global diff_menu_txtpos diff_menu_line
3093 global diff_menu_filebase
3095 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3096 set diff_menu_line [lindex $diff_menu_txtpos 0]
3097 # don't pop up the menu on hunk-separator or file-separator lines
3098 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3099 return
3101 stopfinding
3102 set f [find_ctext_fileinfo $diff_menu_line]
3103 if {$f eq {}} return
3104 set flist_menu_file [lindex $f 0]
3105 set diff_menu_filebase [lindex $f 1]
3106 tk_popup $diff_menu $X $Y
3109 proc flist_hl {only} {
3110 global flist_menu_file findstring gdttype
3112 set x [shellquote $flist_menu_file]
3113 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3114 set findstring $x
3115 } else {
3116 append findstring " " $x
3118 set gdttype [mc "touching paths:"]
3121 proc save_file_from_commit {filename output what} {
3122 global nullfile
3124 if {[catch {exec git show $filename -- > $output} err]} {
3125 if {[string match "fatal: bad revision *" $err]} {
3126 return $nullfile
3128 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3129 return {}
3131 return $output
3134 proc external_diff_get_one_file {diffid filename diffdir} {
3135 global nullid nullid2 nullfile
3136 global gitdir
3138 if {$diffid == $nullid} {
3139 set difffile [file join [file dirname $gitdir] $filename]
3140 if {[file exists $difffile]} {
3141 return $difffile
3143 return $nullfile
3145 if {$diffid == $nullid2} {
3146 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3147 return [save_file_from_commit :$filename $difffile index]
3149 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3150 return [save_file_from_commit $diffid:$filename $difffile \
3151 "revision $diffid"]
3154 proc external_diff {} {
3155 global gitktmpdir nullid nullid2
3156 global flist_menu_file
3157 global diffids
3158 global diffnum
3159 global gitdir extdifftool
3161 if {[llength $diffids] == 1} {
3162 # no reference commit given
3163 set diffidto [lindex $diffids 0]
3164 if {$diffidto eq $nullid} {
3165 # diffing working copy with index
3166 set diffidfrom $nullid2
3167 } elseif {$diffidto eq $nullid2} {
3168 # diffing index with HEAD
3169 set diffidfrom "HEAD"
3170 } else {
3171 # use first parent commit
3172 global parentlist selectedline
3173 set diffidfrom [lindex $parentlist $selectedline 0]
3175 } else {
3176 set diffidfrom [lindex $diffids 0]
3177 set diffidto [lindex $diffids 1]
3180 # make sure that several diffs wont collide
3181 if {![info exists gitktmpdir]} {
3182 set gitktmpdir [file join [file dirname $gitdir] \
3183 [format ".gitk-tmp.%s" [pid]]]
3184 if {[catch {file mkdir $gitktmpdir} err]} {
3185 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3186 unset gitktmpdir
3187 return
3189 set diffnum 0
3191 incr diffnum
3192 set diffdir [file join $gitktmpdir $diffnum]
3193 if {[catch {file mkdir $diffdir} err]} {
3194 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3195 return
3198 # gather files to diff
3199 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3200 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3202 if {$difffromfile ne {} && $difftofile ne {}} {
3203 set cmd [concat | [shellsplit $extdifftool] \
3204 [list $difffromfile $difftofile]]
3205 if {[catch {set fl [open $cmd r]} err]} {
3206 file delete -force $diffdir
3207 error_popup "$extdifftool: [mc "command failed:"] $err"
3208 } else {
3209 fconfigure $fl -blocking 0
3210 filerun $fl [list delete_at_eof $fl $diffdir]
3215 proc find_hunk_blamespec {base line} {
3216 global ctext
3218 # Find and parse the hunk header
3219 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3220 if {$s_lix eq {}} return
3222 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3223 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3224 s_line old_specs osz osz1 new_line nsz]} {
3225 return
3228 # base lines for the parents
3229 set base_lines [list $new_line]
3230 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3231 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3232 old_spec old_line osz]} {
3233 return
3235 lappend base_lines $old_line
3238 # Now scan the lines to determine offset within the hunk
3239 set max_parent [expr {[llength $base_lines]-2}]
3240 set dline 0
3241 set s_lno [lindex [split $s_lix "."] 0]
3243 # Determine if the line is removed
3244 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3245 if {[string match {[-+ ]*} $chunk]} {
3246 set removed_idx [string first "-" $chunk]
3247 # Choose a parent index
3248 if {$removed_idx >= 0} {
3249 set parent $removed_idx
3250 } else {
3251 set unchanged_idx [string first " " $chunk]
3252 if {$unchanged_idx >= 0} {
3253 set parent $unchanged_idx
3254 } else {
3255 # blame the current commit
3256 set parent -1
3259 # then count other lines that belong to it
3260 for {set i $line} {[incr i -1] > $s_lno} {} {
3261 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3262 # Determine if the line is removed
3263 set removed_idx [string first "-" $chunk]
3264 if {$parent >= 0} {
3265 set code [string index $chunk $parent]
3266 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3267 incr dline
3269 } else {
3270 if {$removed_idx < 0} {
3271 incr dline
3275 incr parent
3276 } else {
3277 set parent 0
3280 incr dline [lindex $base_lines $parent]
3281 return [list $parent $dline]
3284 proc external_blame_diff {} {
3285 global currentid cmitmode
3286 global diff_menu_txtpos diff_menu_line
3287 global diff_menu_filebase flist_menu_file
3289 if {$cmitmode eq "tree"} {
3290 set parent_idx 0
3291 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3292 } else {
3293 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3294 if {$hinfo ne {}} {
3295 set parent_idx [lindex $hinfo 0]
3296 set line [lindex $hinfo 1]
3297 } else {
3298 set parent_idx 0
3299 set line 0
3303 external_blame $parent_idx $line
3306 # Find the SHA1 ID of the blob for file $fname in the index
3307 # at stage 0 or 2
3308 proc index_sha1 {fname} {
3309 set f [open [list | git ls-files -s $fname] r]
3310 while {[gets $f line] >= 0} {
3311 set info [lindex [split $line "\t"] 0]
3312 set stage [lindex $info 2]
3313 if {$stage eq "0" || $stage eq "2"} {
3314 close $f
3315 return [lindex $info 1]
3318 close $f
3319 return {}
3322 proc external_blame {parent_idx {line {}}} {
3323 global flist_menu_file
3324 global nullid nullid2
3325 global parentlist selectedline currentid
3327 if {$parent_idx > 0} {
3328 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3329 } else {
3330 set base_commit $currentid
3333 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3334 error_popup [mc "No such commit"]
3335 return
3338 set cmdline [list git gui blame]
3339 if {$line ne {} && $line > 1} {
3340 lappend cmdline "--line=$line"
3342 lappend cmdline $base_commit $flist_menu_file
3343 if {[catch {eval exec $cmdline &} err]} {
3344 error_popup "[mc "git gui blame: command failed:"] $err"
3348 proc show_line_source {} {
3349 global cmitmode currentid parents curview blamestuff blameinst
3350 global diff_menu_line diff_menu_filebase flist_menu_file
3351 global nullid nullid2 gitdir
3353 set from_index {}
3354 if {$cmitmode eq "tree"} {
3355 set id $currentid
3356 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3357 } else {
3358 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3359 if {$h eq {}} return
3360 set pi [lindex $h 0]
3361 if {$pi == 0} {
3362 mark_ctext_line $diff_menu_line
3363 return
3365 incr pi -1
3366 if {$currentid eq $nullid} {
3367 if {$pi > 0} {
3368 # must be a merge in progress...
3369 if {[catch {
3370 # get the last line from .git/MERGE_HEAD
3371 set f [open [file join $gitdir MERGE_HEAD] r]
3372 set id [lindex [split [read $f] "\n"] end-1]
3373 close $f
3374 } err]} {
3375 error_popup [mc "Couldn't read merge head: %s" $err]
3376 return
3378 } elseif {$parents($curview,$currentid) eq $nullid2} {
3379 # need to do the blame from the index
3380 if {[catch {
3381 set from_index [index_sha1 $flist_menu_file]
3382 } err]} {
3383 error_popup [mc "Error reading index: %s" $err]
3384 return
3387 } else {
3388 set id [lindex $parents($curview,$currentid) $pi]
3390 set line [lindex $h 1]
3392 set blameargs {}
3393 if {$from_index ne {}} {
3394 lappend blameargs | git cat-file blob $from_index
3396 lappend blameargs | git blame -p -L$line,+1
3397 if {$from_index ne {}} {
3398 lappend blameargs --contents -
3399 } else {
3400 lappend blameargs $id
3402 lappend blameargs -- $flist_menu_file
3403 if {[catch {
3404 set f [open $blameargs r]
3405 } err]} {
3406 error_popup [mc "Couldn't start git blame: %s" $err]
3407 return
3409 fconfigure $f -blocking 0
3410 set i [reg_instance $f]
3411 set blamestuff($i) {}
3412 set blameinst $i
3413 filerun $f [list read_line_source $f $i]
3416 proc stopblaming {} {
3417 global blameinst
3419 if {[info exists blameinst]} {
3420 stop_instance $blameinst
3421 unset blameinst
3425 proc read_line_source {fd inst} {
3426 global blamestuff curview commfd blameinst nullid nullid2
3428 while {[gets $fd line] >= 0} {
3429 lappend blamestuff($inst) $line
3431 if {![eof $fd]} {
3432 return 1
3434 unset commfd($inst)
3435 unset blameinst
3436 fconfigure $fd -blocking 1
3437 if {[catch {close $fd} err]} {
3438 error_popup [mc "Error running git blame: %s" $err]
3439 return 0
3442 set fname {}
3443 set line [split [lindex $blamestuff($inst) 0] " "]
3444 set id [lindex $line 0]
3445 set lnum [lindex $line 1]
3446 if {[string length $id] == 40 && [string is xdigit $id] &&
3447 [string is digit -strict $lnum]} {
3448 # look for "filename" line
3449 foreach l $blamestuff($inst) {
3450 if {[string match "filename *" $l]} {
3451 set fname [string range $l 9 end]
3452 break
3456 if {$fname ne {}} {
3457 # all looks good, select it
3458 if {$id eq $nullid} {
3459 # blame uses all-zeroes to mean not committed,
3460 # which would mean a change in the index
3461 set id $nullid2
3463 if {[commitinview $id $curview]} {
3464 selectline [rowofcommit $id] 1 [list $fname $lnum]
3465 } else {
3466 error_popup [mc "That line comes from commit %s, \
3467 which is not in this view" [shortids $id]]
3469 } else {
3470 puts "oops couldn't parse git blame output"
3472 return 0
3475 # delete $dir when we see eof on $f (presumably because the child has exited)
3476 proc delete_at_eof {f dir} {
3477 while {[gets $f line] >= 0} {}
3478 if {[eof $f]} {
3479 if {[catch {close $f} err]} {
3480 error_popup "[mc "External diff viewer failed:"] $err"
3482 file delete -force $dir
3483 return 0
3485 return 1
3488 # Functions for adding and removing shell-type quoting
3490 proc shellquote {str} {
3491 if {![string match "*\['\"\\ \t]*" $str]} {
3492 return $str
3494 if {![string match "*\['\"\\]*" $str]} {
3495 return "\"$str\""
3497 if {![string match "*'*" $str]} {
3498 return "'$str'"
3500 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3503 proc shellarglist {l} {
3504 set str {}
3505 foreach a $l {
3506 if {$str ne {}} {
3507 append str " "
3509 append str [shellquote $a]
3511 return $str
3514 proc shelldequote {str} {
3515 set ret {}
3516 set used -1
3517 while {1} {
3518 incr used
3519 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3520 append ret [string range $str $used end]
3521 set used [string length $str]
3522 break
3524 set first [lindex $first 0]
3525 set ch [string index $str $first]
3526 if {$first > $used} {
3527 append ret [string range $str $used [expr {$first - 1}]]
3528 set used $first
3530 if {$ch eq " " || $ch eq "\t"} break
3531 incr used
3532 if {$ch eq "'"} {
3533 set first [string first "'" $str $used]
3534 if {$first < 0} {
3535 error "unmatched single-quote"
3537 append ret [string range $str $used [expr {$first - 1}]]
3538 set used $first
3539 continue
3541 if {$ch eq "\\"} {
3542 if {$used >= [string length $str]} {
3543 error "trailing backslash"
3545 append ret [string index $str $used]
3546 continue
3548 # here ch == "\""
3549 while {1} {
3550 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3551 error "unmatched double-quote"
3553 set first [lindex $first 0]
3554 set ch [string index $str $first]
3555 if {$first > $used} {
3556 append ret [string range $str $used [expr {$first - 1}]]
3557 set used $first
3559 if {$ch eq "\""} break
3560 incr used
3561 append ret [string index $str $used]
3562 incr used
3565 return [list $used $ret]
3568 proc shellsplit {str} {
3569 set l {}
3570 while {1} {
3571 set str [string trimleft $str]
3572 if {$str eq {}} break
3573 set dq [shelldequote $str]
3574 set n [lindex $dq 0]
3575 set word [lindex $dq 1]
3576 set str [string range $str $n end]
3577 lappend l $word
3579 return $l
3582 # Code to implement multiple views
3584 proc newview {ishighlight} {
3585 global nextviewnum newviewname newishighlight
3586 global revtreeargs viewargscmd newviewopts curview
3588 set newishighlight $ishighlight
3589 set top .gitkview
3590 if {[winfo exists $top]} {
3591 raise $top
3592 return
3594 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3595 set newviewopts($nextviewnum,perm) 0
3596 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3597 decode_view_opts $nextviewnum $revtreeargs
3598 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3601 set known_view_options {
3602 {perm b . {} {mc "Remember this view"}}
3603 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3604 {all b * "--all" {mc "Use all refs"}}
3605 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3606 {lright b . "--left-right" {mc "Mark branch sides"}}
3607 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3608 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3609 {limit t10 + "--max-count=*" {mc "Max count:"}}
3610 {skip t10 . "--skip=*" {mc "Skip:"}}
3611 {first b . "--first-parent" {mc "Limit to first parent"}}
3612 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3615 proc encode_view_opts {n} {
3616 global known_view_options newviewopts
3618 set rargs [list]
3619 foreach opt $known_view_options {
3620 set patterns [lindex $opt 3]
3621 if {$patterns eq {}} continue
3622 set pattern [lindex $patterns 0]
3624 set val $newviewopts($n,[lindex $opt 0])
3626 if {[lindex $opt 1] eq "b"} {
3627 if {$val} {
3628 lappend rargs $pattern
3630 } else {
3631 set val [string trim $val]
3632 if {$val ne {}} {
3633 set pfix [string range $pattern 0 end-1]
3634 lappend rargs $pfix$val
3638 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3641 proc decode_view_opts {n view_args} {
3642 global known_view_options newviewopts
3644 foreach opt $known_view_options {
3645 if {[lindex $opt 1] eq "b"} {
3646 set val 0
3647 } else {
3648 set val {}
3650 set newviewopts($n,[lindex $opt 0]) $val
3652 set oargs [list]
3653 foreach arg $view_args {
3654 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3655 && ![info exists found(limit)]} {
3656 set newviewopts($n,limit) $cnt
3657 set found(limit) 1
3658 continue
3660 catch { unset val }
3661 foreach opt $known_view_options {
3662 set id [lindex $opt 0]
3663 if {[info exists found($id)]} continue
3664 foreach pattern [lindex $opt 3] {
3665 if {![string match $pattern $arg]} continue
3666 if {[lindex $opt 1] ne "b"} {
3667 set size [string length $pattern]
3668 set val [string range $arg [expr {$size-1}] end]
3669 } else {
3670 set val 1
3672 set newviewopts($n,$id) $val
3673 set found($id) 1
3674 break
3676 if {[info exists val]} break
3678 if {[info exists val]} continue
3679 lappend oargs $arg
3681 set newviewopts($n,args) [shellarglist $oargs]
3684 proc edit_or_newview {} {
3685 global curview
3687 if {$curview > 0} {
3688 editview
3689 } else {
3690 newview 0
3694 proc editview {} {
3695 global curview
3696 global viewname viewperm newviewname newviewopts
3697 global viewargs viewargscmd
3699 set top .gitkvedit-$curview
3700 if {[winfo exists $top]} {
3701 raise $top
3702 return
3704 set newviewname($curview) $viewname($curview)
3705 set newviewopts($curview,perm) $viewperm($curview)
3706 set newviewopts($curview,cmd) $viewargscmd($curview)
3707 decode_view_opts $curview $viewargs($curview)
3708 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3711 proc vieweditor {top n title} {
3712 global newviewname newviewopts viewfiles bgcolor
3713 global known_view_options
3715 toplevel $top
3716 wm title $top $title
3717 make_transient $top .
3719 # View name
3720 frame $top.nfr
3721 label $top.nl -text [mc "Name"]
3722 entry $top.name -width 20 -textvariable newviewname($n)
3723 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3724 pack $top.nl -in $top.nfr -side left -padx {0 30}
3725 pack $top.name -in $top.nfr -side left
3727 # View options
3728 set cframe $top.nfr
3729 set cexpand 0
3730 set cnt 0
3731 foreach opt $known_view_options {
3732 set id [lindex $opt 0]
3733 set type [lindex $opt 1]
3734 set flags [lindex $opt 2]
3735 set title [eval [lindex $opt 4]]
3736 set lxpad 0
3738 if {$flags eq "+" || $flags eq "*"} {
3739 set cframe $top.fr$cnt
3740 incr cnt
3741 frame $cframe
3742 pack $cframe -in $top -fill x -pady 3 -padx 3
3743 set cexpand [expr {$flags eq "*"}]
3744 } else {
3745 set lxpad 5
3748 if {$type eq "b"} {
3749 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3750 pack $cframe.c_$id -in $cframe -side left \
3751 -padx [list $lxpad 0] -expand $cexpand -anchor w
3752 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3753 message $cframe.l_$id -aspect 1500 -text $title
3754 entry $cframe.e_$id -width $sz -background $bgcolor \
3755 -textvariable newviewopts($n,$id)
3756 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3757 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3758 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3759 message $cframe.l_$id -aspect 1500 -text $title
3760 entry $cframe.e_$id -width $sz -background $bgcolor \
3761 -textvariable newviewopts($n,$id)
3762 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3763 pack $cframe.e_$id -in $cframe -side top -fill x
3767 # Path list
3768 message $top.l -aspect 1500 \
3769 -text [mc "Enter files and directories to include, one per line:"]
3770 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3771 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3772 if {[info exists viewfiles($n)]} {
3773 foreach f $viewfiles($n) {
3774 $top.t insert end $f
3775 $top.t insert end "\n"
3777 $top.t delete {end - 1c} end
3778 $top.t mark set insert 0.0
3780 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3781 frame $top.buts
3782 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3783 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3784 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3785 bind $top <Control-Return> [list newviewok $top $n]
3786 bind $top <F5> [list newviewok $top $n 1]
3787 bind $top <Escape> [list destroy $top]
3788 grid $top.buts.ok $top.buts.apply $top.buts.can
3789 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3790 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3791 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3792 pack $top.buts -in $top -side top -fill x
3793 focus $top.t
3796 proc doviewmenu {m first cmd op argv} {
3797 set nmenu [$m index end]
3798 for {set i $first} {$i <= $nmenu} {incr i} {
3799 if {[$m entrycget $i -command] eq $cmd} {
3800 eval $m $op $i $argv
3801 break
3806 proc allviewmenus {n op args} {
3807 # global viewhlmenu
3809 doviewmenu .bar.view 5 [list showview $n] $op $args
3810 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3813 proc newviewok {top n {apply 0}} {
3814 global nextviewnum newviewperm newviewname newishighlight
3815 global viewname viewfiles viewperm selectedview curview
3816 global viewargs viewargscmd newviewopts viewhlmenu
3818 if {[catch {
3819 set newargs [encode_view_opts $n]
3820 } err]} {
3821 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3822 return
3824 set files {}
3825 foreach f [split [$top.t get 0.0 end] "\n"] {
3826 set ft [string trim $f]
3827 if {$ft ne {}} {
3828 lappend files $ft
3831 if {![info exists viewfiles($n)]} {
3832 # creating a new view
3833 incr nextviewnum
3834 set viewname($n) $newviewname($n)
3835 set viewperm($n) $newviewopts($n,perm)
3836 set viewfiles($n) $files
3837 set viewargs($n) $newargs
3838 set viewargscmd($n) $newviewopts($n,cmd)
3839 addviewmenu $n
3840 if {!$newishighlight} {
3841 run showview $n
3842 } else {
3843 run addvhighlight $n
3845 } else {
3846 # editing an existing view
3847 set viewperm($n) $newviewopts($n,perm)
3848 if {$newviewname($n) ne $viewname($n)} {
3849 set viewname($n) $newviewname($n)
3850 doviewmenu .bar.view 5 [list showview $n] \
3851 entryconf [list -label $viewname($n)]
3852 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3853 # entryconf [list -label $viewname($n) -value $viewname($n)]
3855 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3856 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3857 set viewfiles($n) $files
3858 set viewargs($n) $newargs
3859 set viewargscmd($n) $newviewopts($n,cmd)
3860 if {$curview == $n} {
3861 run reloadcommits
3865 if {$apply} return
3866 catch {destroy $top}
3869 proc delview {} {
3870 global curview viewperm hlview selectedhlview
3872 if {$curview == 0} return
3873 if {[info exists hlview] && $hlview == $curview} {
3874 set selectedhlview [mc "None"]
3875 unset hlview
3877 allviewmenus $curview delete
3878 set viewperm($curview) 0
3879 showview 0
3882 proc addviewmenu {n} {
3883 global viewname viewhlmenu
3885 .bar.view add radiobutton -label $viewname($n) \
3886 -command [list showview $n] -variable selectedview -value $n
3887 #$viewhlmenu add radiobutton -label $viewname($n) \
3888 # -command [list addvhighlight $n] -variable selectedhlview
3891 proc showview {n} {
3892 global curview cached_commitrow ordertok
3893 global displayorder parentlist rowidlist rowisopt rowfinal
3894 global colormap rowtextx nextcolor canvxmax
3895 global numcommits viewcomplete
3896 global selectedline currentid canv canvy0
3897 global treediffs
3898 global pending_select mainheadid
3899 global commitidx
3900 global selectedview
3901 global hlview selectedhlview commitinterest
3903 if {$n == $curview} return
3904 set selid {}
3905 set ymax [lindex [$canv cget -scrollregion] 3]
3906 set span [$canv yview]
3907 set ytop [expr {[lindex $span 0] * $ymax}]
3908 set ybot [expr {[lindex $span 1] * $ymax}]
3909 set yscreen [expr {($ybot - $ytop) / 2}]
3910 if {$selectedline ne {}} {
3911 set selid $currentid
3912 set y [yc $selectedline]
3913 if {$ytop < $y && $y < $ybot} {
3914 set yscreen [expr {$y - $ytop}]
3916 } elseif {[info exists pending_select]} {
3917 set selid $pending_select
3918 unset pending_select
3920 unselectline
3921 normalline
3922 catch {unset treediffs}
3923 clear_display
3924 if {[info exists hlview] && $hlview == $n} {
3925 unset hlview
3926 set selectedhlview [mc "None"]
3928 catch {unset commitinterest}
3929 catch {unset cached_commitrow}
3930 catch {unset ordertok}
3932 set curview $n
3933 set selectedview $n
3934 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3935 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3937 run refill_reflist
3938 if {![info exists viewcomplete($n)]} {
3939 getcommits $selid
3940 return
3943 set displayorder {}
3944 set parentlist {}
3945 set rowidlist {}
3946 set rowisopt {}
3947 set rowfinal {}
3948 set numcommits $commitidx($n)
3950 catch {unset colormap}
3951 catch {unset rowtextx}
3952 set nextcolor 0
3953 set canvxmax [$canv cget -width]
3954 set curview $n
3955 set row 0
3956 setcanvscroll
3957 set yf 0
3958 set row {}
3959 if {$selid ne {} && [commitinview $selid $n]} {
3960 set row [rowofcommit $selid]
3961 # try to get the selected row in the same position on the screen
3962 set ymax [lindex [$canv cget -scrollregion] 3]
3963 set ytop [expr {[yc $row] - $yscreen}]
3964 if {$ytop < 0} {
3965 set ytop 0
3967 set yf [expr {$ytop * 1.0 / $ymax}]
3969 allcanvs yview moveto $yf
3970 drawvisible
3971 if {$row ne {}} {
3972 selectline $row 0
3973 } elseif {!$viewcomplete($n)} {
3974 reset_pending_select $selid
3975 } else {
3976 reset_pending_select {}
3978 if {[commitinview $pending_select $curview]} {
3979 selectline [rowofcommit $pending_select] 1
3980 } else {
3981 set row [first_real_row]
3982 if {$row < $numcommits} {
3983 selectline $row 0
3987 if {!$viewcomplete($n)} {
3988 if {$numcommits == 0} {
3989 show_status [mc "Reading commits..."]
3991 } elseif {$numcommits == 0} {
3992 show_status [mc "No commits selected"]
3996 # Stuff relating to the highlighting facility
3998 proc ishighlighted {id} {
3999 global vhighlights fhighlights nhighlights rhighlights
4001 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4002 return $nhighlights($id)
4004 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4005 return $vhighlights($id)
4007 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4008 return $fhighlights($id)
4010 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4011 return $rhighlights($id)
4013 return 0
4016 proc bolden {id font} {
4017 global canv linehtag currentid boldids need_redisplay
4019 # need_redisplay = 1 means the display is stale and about to be redrawn
4020 if {$need_redisplay} return
4021 lappend boldids $id
4022 $canv itemconf $linehtag($id) -font $font
4023 if {[info exists currentid] && $id eq $currentid} {
4024 $canv delete secsel
4025 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4026 -outline {{}} -tags secsel \
4027 -fill [$canv cget -selectbackground]]
4028 $canv lower $t
4032 proc bolden_name {id font} {
4033 global canv2 linentag currentid boldnameids need_redisplay
4035 if {$need_redisplay} return
4036 lappend boldnameids $id
4037 $canv2 itemconf $linentag($id) -font $font
4038 if {[info exists currentid] && $id eq $currentid} {
4039 $canv2 delete secsel
4040 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4041 -outline {{}} -tags secsel \
4042 -fill [$canv2 cget -selectbackground]]
4043 $canv2 lower $t
4047 proc unbolden {} {
4048 global boldids
4050 set stillbold {}
4051 foreach id $boldids {
4052 if {![ishighlighted $id]} {
4053 bolden $id mainfont
4054 } else {
4055 lappend stillbold $id
4058 set boldids $stillbold
4061 proc addvhighlight {n} {
4062 global hlview viewcomplete curview vhl_done commitidx
4064 if {[info exists hlview]} {
4065 delvhighlight
4067 set hlview $n
4068 if {$n != $curview && ![info exists viewcomplete($n)]} {
4069 start_rev_list $n
4071 set vhl_done $commitidx($hlview)
4072 if {$vhl_done > 0} {
4073 drawvisible
4077 proc delvhighlight {} {
4078 global hlview vhighlights
4080 if {![info exists hlview]} return
4081 unset hlview
4082 catch {unset vhighlights}
4083 unbolden
4086 proc vhighlightmore {} {
4087 global hlview vhl_done commitidx vhighlights curview
4089 set max $commitidx($hlview)
4090 set vr [visiblerows]
4091 set r0 [lindex $vr 0]
4092 set r1 [lindex $vr 1]
4093 for {set i $vhl_done} {$i < $max} {incr i} {
4094 set id [commitonrow $i $hlview]
4095 if {[commitinview $id $curview]} {
4096 set row [rowofcommit $id]
4097 if {$r0 <= $row && $row <= $r1} {
4098 if {![highlighted $row]} {
4099 bolden $id mainfontbold
4101 set vhighlights($id) 1
4105 set vhl_done $max
4106 return 0
4109 proc askvhighlight {row id} {
4110 global hlview vhighlights iddrawn
4112 if {[commitinview $id $hlview]} {
4113 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4114 bolden $id mainfontbold
4116 set vhighlights($id) 1
4117 } else {
4118 set vhighlights($id) 0
4122 proc hfiles_change {} {
4123 global highlight_files filehighlight fhighlights fh_serial
4124 global highlight_paths gdttype
4126 if {[info exists filehighlight]} {
4127 # delete previous highlights
4128 catch {close $filehighlight}
4129 unset filehighlight
4130 catch {unset fhighlights}
4131 unbolden
4132 unhighlight_filelist
4134 set highlight_paths {}
4135 after cancel do_file_hl $fh_serial
4136 incr fh_serial
4137 if {$highlight_files ne {}} {
4138 after 300 do_file_hl $fh_serial
4142 proc gdttype_change {name ix op} {
4143 global gdttype highlight_files findstring findpattern
4145 stopfinding
4146 if {$findstring ne {}} {
4147 if {$gdttype eq [mc "containing:"]} {
4148 if {$highlight_files ne {}} {
4149 set highlight_files {}
4150 hfiles_change
4152 findcom_change
4153 } else {
4154 if {$findpattern ne {}} {
4155 set findpattern {}
4156 findcom_change
4158 set highlight_files $findstring
4159 hfiles_change
4161 drawvisible
4163 # enable/disable findtype/findloc menus too
4166 proc find_change {name ix op} {
4167 global gdttype findstring highlight_files
4169 stopfinding
4170 if {$gdttype eq [mc "containing:"]} {
4171 findcom_change
4172 } else {
4173 if {$highlight_files ne $findstring} {
4174 set highlight_files $findstring
4175 hfiles_change
4178 drawvisible
4181 proc findcom_change args {
4182 global nhighlights boldnameids
4183 global findpattern findtype findstring gdttype
4185 stopfinding
4186 # delete previous highlights, if any
4187 foreach id $boldnameids {
4188 bolden_name $id mainfont
4190 set boldnameids {}
4191 catch {unset nhighlights}
4192 unbolden
4193 unmarkmatches
4194 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4195 set findpattern {}
4196 } elseif {$findtype eq [mc "Regexp"]} {
4197 set findpattern $findstring
4198 } else {
4199 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4200 $findstring]
4201 set findpattern "*$e*"
4205 proc makepatterns {l} {
4206 set ret {}
4207 foreach e $l {
4208 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4209 if {[string index $ee end] eq "/"} {
4210 lappend ret "$ee*"
4211 } else {
4212 lappend ret $ee
4213 lappend ret "$ee/*"
4216 return $ret
4219 proc do_file_hl {serial} {
4220 global highlight_files filehighlight highlight_paths gdttype fhl_list
4222 if {$gdttype eq [mc "touching paths:"]} {
4223 if {[catch {set paths [shellsplit $highlight_files]}]} return
4224 set highlight_paths [makepatterns $paths]
4225 highlight_filelist
4226 set gdtargs [concat -- $paths]
4227 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4228 set gdtargs [list "-S$highlight_files"]
4229 } else {
4230 # must be "containing:", i.e. we're searching commit info
4231 return
4233 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4234 set filehighlight [open $cmd r+]
4235 fconfigure $filehighlight -blocking 0
4236 filerun $filehighlight readfhighlight
4237 set fhl_list {}
4238 drawvisible
4239 flushhighlights
4242 proc flushhighlights {} {
4243 global filehighlight fhl_list
4245 if {[info exists filehighlight]} {
4246 lappend fhl_list {}
4247 puts $filehighlight ""
4248 flush $filehighlight
4252 proc askfilehighlight {row id} {
4253 global filehighlight fhighlights fhl_list
4255 lappend fhl_list $id
4256 set fhighlights($id) -1
4257 puts $filehighlight $id
4260 proc readfhighlight {} {
4261 global filehighlight fhighlights curview iddrawn
4262 global fhl_list find_dirn
4264 if {![info exists filehighlight]} {
4265 return 0
4267 set nr 0
4268 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4269 set line [string trim $line]
4270 set i [lsearch -exact $fhl_list $line]
4271 if {$i < 0} continue
4272 for {set j 0} {$j < $i} {incr j} {
4273 set id [lindex $fhl_list $j]
4274 set fhighlights($id) 0
4276 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4277 if {$line eq {}} continue
4278 if {![commitinview $line $curview]} continue
4279 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4280 bolden $line mainfontbold
4282 set fhighlights($line) 1
4284 if {[eof $filehighlight]} {
4285 # strange...
4286 puts "oops, git diff-tree died"
4287 catch {close $filehighlight}
4288 unset filehighlight
4289 return 0
4291 if {[info exists find_dirn]} {
4292 run findmore
4294 return 1
4297 proc doesmatch {f} {
4298 global findtype findpattern
4300 if {$findtype eq [mc "Regexp"]} {
4301 return [regexp $findpattern $f]
4302 } elseif {$findtype eq [mc "IgnCase"]} {
4303 return [string match -nocase $findpattern $f]
4304 } else {
4305 return [string match $findpattern $f]
4309 proc askfindhighlight {row id} {
4310 global nhighlights commitinfo iddrawn
4311 global findloc
4312 global markingmatches
4314 if {![info exists commitinfo($id)]} {
4315 getcommit $id
4317 set info $commitinfo($id)
4318 set isbold 0
4319 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4320 foreach f $info ty $fldtypes {
4321 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4322 [doesmatch $f]} {
4323 if {$ty eq [mc "Author"]} {
4324 set isbold 2
4325 break
4327 set isbold 1
4330 if {$isbold && [info exists iddrawn($id)]} {
4331 if {![ishighlighted $id]} {
4332 bolden $id mainfontbold
4333 if {$isbold > 1} {
4334 bolden_name $id mainfontbold
4337 if {$markingmatches} {
4338 markrowmatches $row $id
4341 set nhighlights($id) $isbold
4344 proc markrowmatches {row id} {
4345 global canv canv2 linehtag linentag commitinfo findloc
4347 set headline [lindex $commitinfo($id) 0]
4348 set author [lindex $commitinfo($id) 1]
4349 $canv delete match$row
4350 $canv2 delete match$row
4351 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4352 set m [findmatches $headline]
4353 if {$m ne {}} {
4354 markmatches $canv $row $headline $linehtag($id) $m \
4355 [$canv itemcget $linehtag($id) -font] $row
4358 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4359 set m [findmatches $author]
4360 if {$m ne {}} {
4361 markmatches $canv2 $row $author $linentag($id) $m \
4362 [$canv2 itemcget $linentag($id) -font] $row
4367 proc vrel_change {name ix op} {
4368 global highlight_related
4370 rhighlight_none
4371 if {$highlight_related ne [mc "None"]} {
4372 run drawvisible
4376 # prepare for testing whether commits are descendents or ancestors of a
4377 proc rhighlight_sel {a} {
4378 global descendent desc_todo ancestor anc_todo
4379 global highlight_related
4381 catch {unset descendent}
4382 set desc_todo [list $a]
4383 catch {unset ancestor}
4384 set anc_todo [list $a]
4385 if {$highlight_related ne [mc "None"]} {
4386 rhighlight_none
4387 run drawvisible
4391 proc rhighlight_none {} {
4392 global rhighlights
4394 catch {unset rhighlights}
4395 unbolden
4398 proc is_descendent {a} {
4399 global curview children descendent desc_todo
4401 set v $curview
4402 set la [rowofcommit $a]
4403 set todo $desc_todo
4404 set leftover {}
4405 set done 0
4406 for {set i 0} {$i < [llength $todo]} {incr i} {
4407 set do [lindex $todo $i]
4408 if {[rowofcommit $do] < $la} {
4409 lappend leftover $do
4410 continue
4412 foreach nk $children($v,$do) {
4413 if {![info exists descendent($nk)]} {
4414 set descendent($nk) 1
4415 lappend todo $nk
4416 if {$nk eq $a} {
4417 set done 1
4421 if {$done} {
4422 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4423 return
4426 set descendent($a) 0
4427 set desc_todo $leftover
4430 proc is_ancestor {a} {
4431 global curview parents ancestor anc_todo
4433 set v $curview
4434 set la [rowofcommit $a]
4435 set todo $anc_todo
4436 set leftover {}
4437 set done 0
4438 for {set i 0} {$i < [llength $todo]} {incr i} {
4439 set do [lindex $todo $i]
4440 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4441 lappend leftover $do
4442 continue
4444 foreach np $parents($v,$do) {
4445 if {![info exists ancestor($np)]} {
4446 set ancestor($np) 1
4447 lappend todo $np
4448 if {$np eq $a} {
4449 set done 1
4453 if {$done} {
4454 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4455 return
4458 set ancestor($a) 0
4459 set anc_todo $leftover
4462 proc askrelhighlight {row id} {
4463 global descendent highlight_related iddrawn rhighlights
4464 global selectedline ancestor
4466 if {$selectedline eq {}} return
4467 set isbold 0
4468 if {$highlight_related eq [mc "Descendant"] ||
4469 $highlight_related eq [mc "Not descendant"]} {
4470 if {![info exists descendent($id)]} {
4471 is_descendent $id
4473 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4474 set isbold 1
4476 } elseif {$highlight_related eq [mc "Ancestor"] ||
4477 $highlight_related eq [mc "Not ancestor"]} {
4478 if {![info exists ancestor($id)]} {
4479 is_ancestor $id
4481 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4482 set isbold 1
4485 if {[info exists iddrawn($id)]} {
4486 if {$isbold && ![ishighlighted $id]} {
4487 bolden $id mainfontbold
4490 set rhighlights($id) $isbold
4493 # Graph layout functions
4495 proc shortids {ids} {
4496 set res {}
4497 foreach id $ids {
4498 if {[llength $id] > 1} {
4499 lappend res [shortids $id]
4500 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4501 lappend res [string range $id 0 7]
4502 } else {
4503 lappend res $id
4506 return $res
4509 proc ntimes {n o} {
4510 set ret {}
4511 set o [list $o]
4512 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4513 if {($n & $mask) != 0} {
4514 set ret [concat $ret $o]
4516 set o [concat $o $o]
4518 return $ret
4521 proc ordertoken {id} {
4522 global ordertok curview varcid varcstart varctok curview parents children
4523 global nullid nullid2
4525 if {[info exists ordertok($id)]} {
4526 return $ordertok($id)
4528 set origid $id
4529 set todo {}
4530 while {1} {
4531 if {[info exists varcid($curview,$id)]} {
4532 set a $varcid($curview,$id)
4533 set p [lindex $varcstart($curview) $a]
4534 } else {
4535 set p [lindex $children($curview,$id) 0]
4537 if {[info exists ordertok($p)]} {
4538 set tok $ordertok($p)
4539 break
4541 set id [first_real_child $curview,$p]
4542 if {$id eq {}} {
4543 # it's a root
4544 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4545 break
4547 if {[llength $parents($curview,$id)] == 1} {
4548 lappend todo [list $p {}]
4549 } else {
4550 set j [lsearch -exact $parents($curview,$id) $p]
4551 if {$j < 0} {
4552 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4554 lappend todo [list $p [strrep $j]]
4557 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4558 set p [lindex $todo $i 0]
4559 append tok [lindex $todo $i 1]
4560 set ordertok($p) $tok
4562 set ordertok($origid) $tok
4563 return $tok
4566 # Work out where id should go in idlist so that order-token
4567 # values increase from left to right
4568 proc idcol {idlist id {i 0}} {
4569 set t [ordertoken $id]
4570 if {$i < 0} {
4571 set i 0
4573 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4574 if {$i > [llength $idlist]} {
4575 set i [llength $idlist]
4577 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4578 incr i
4579 } else {
4580 if {$t > [ordertoken [lindex $idlist $i]]} {
4581 while {[incr i] < [llength $idlist] &&
4582 $t >= [ordertoken [lindex $idlist $i]]} {}
4585 return $i
4588 proc initlayout {} {
4589 global rowidlist rowisopt rowfinal displayorder parentlist
4590 global numcommits canvxmax canv
4591 global nextcolor
4592 global colormap rowtextx
4594 set numcommits 0
4595 set displayorder {}
4596 set parentlist {}
4597 set nextcolor 0
4598 set rowidlist {}
4599 set rowisopt {}
4600 set rowfinal {}
4601 set canvxmax [$canv cget -width]
4602 catch {unset colormap}
4603 catch {unset rowtextx}
4604 setcanvscroll
4607 proc setcanvscroll {} {
4608 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4609 global lastscrollset lastscrollrows
4611 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4612 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4613 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4614 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4615 set lastscrollset [clock clicks -milliseconds]
4616 set lastscrollrows $numcommits
4619 proc visiblerows {} {
4620 global canv numcommits linespc
4622 set ymax [lindex [$canv cget -scrollregion] 3]
4623 if {$ymax eq {} || $ymax == 0} return
4624 set f [$canv yview]
4625 set y0 [expr {int([lindex $f 0] * $ymax)}]
4626 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4627 if {$r0 < 0} {
4628 set r0 0
4630 set y1 [expr {int([lindex $f 1] * $ymax)}]
4631 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4632 if {$r1 >= $numcommits} {
4633 set r1 [expr {$numcommits - 1}]
4635 return [list $r0 $r1]
4638 proc layoutmore {} {
4639 global commitidx viewcomplete curview
4640 global numcommits pending_select curview
4641 global lastscrollset lastscrollrows
4643 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4644 [clock clicks -milliseconds] - $lastscrollset > 500} {
4645 setcanvscroll
4647 if {[info exists pending_select] &&
4648 [commitinview $pending_select $curview]} {
4649 update
4650 selectline [rowofcommit $pending_select] 1
4652 drawvisible
4655 # With path limiting, we mightn't get the actual HEAD commit,
4656 # so ask git rev-list what is the first ancestor of HEAD that
4657 # touches a file in the path limit.
4658 proc get_viewmainhead {view} {
4659 global viewmainheadid vfilelimit viewinstances mainheadid
4661 catch {
4662 set rfd [open [concat | git rev-list -1 $mainheadid \
4663 -- $vfilelimit($view)] r]
4664 set j [reg_instance $rfd]
4665 lappend viewinstances($view) $j
4666 fconfigure $rfd -blocking 0
4667 filerun $rfd [list getviewhead $rfd $j $view]
4668 set viewmainheadid($curview) {}
4672 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4673 proc getviewhead {fd inst view} {
4674 global viewmainheadid commfd curview viewinstances showlocalchanges
4676 set id {}
4677 if {[gets $fd line] < 0} {
4678 if {![eof $fd]} {
4679 return 1
4681 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4682 set id $line
4684 set viewmainheadid($view) $id
4685 close $fd
4686 unset commfd($inst)
4687 set i [lsearch -exact $viewinstances($view) $inst]
4688 if {$i >= 0} {
4689 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4691 if {$showlocalchanges && $id ne {} && $view == $curview} {
4692 doshowlocalchanges
4694 return 0
4697 proc doshowlocalchanges {} {
4698 global curview viewmainheadid
4700 if {$viewmainheadid($curview) eq {}} return
4701 if {[commitinview $viewmainheadid($curview) $curview]} {
4702 dodiffindex
4703 } else {
4704 interestedin $viewmainheadid($curview) dodiffindex
4708 proc dohidelocalchanges {} {
4709 global nullid nullid2 lserial curview
4711 if {[commitinview $nullid $curview]} {
4712 removefakerow $nullid
4714 if {[commitinview $nullid2 $curview]} {
4715 removefakerow $nullid2
4717 incr lserial
4720 # spawn off a process to do git diff-index --cached HEAD
4721 proc dodiffindex {} {
4722 global lserial showlocalchanges vfilelimit curview
4723 global isworktree
4725 if {!$showlocalchanges || !$isworktree} return
4726 incr lserial
4727 set cmd "|git diff-index --cached HEAD"
4728 if {$vfilelimit($curview) ne {}} {
4729 set cmd [concat $cmd -- $vfilelimit($curview)]
4731 set fd [open $cmd r]
4732 fconfigure $fd -blocking 0
4733 set i [reg_instance $fd]
4734 filerun $fd [list readdiffindex $fd $lserial $i]
4737 proc readdiffindex {fd serial inst} {
4738 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4739 global vfilelimit
4741 set isdiff 1
4742 if {[gets $fd line] < 0} {
4743 if {![eof $fd]} {
4744 return 1
4746 set isdiff 0
4748 # we only need to see one line and we don't really care what it says...
4749 stop_instance $inst
4751 if {$serial != $lserial} {
4752 return 0
4755 # now see if there are any local changes not checked in to the index
4756 set cmd "|git diff-files"
4757 if {$vfilelimit($curview) ne {}} {
4758 set cmd [concat $cmd -- $vfilelimit($curview)]
4760 set fd [open $cmd r]
4761 fconfigure $fd -blocking 0
4762 set i [reg_instance $fd]
4763 filerun $fd [list readdifffiles $fd $serial $i]
4765 if {$isdiff && ![commitinview $nullid2 $curview]} {
4766 # add the line for the changes in the index to the graph
4767 set hl [mc "Local changes checked in to index but not committed"]
4768 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4769 set commitdata($nullid2) "\n $hl\n"
4770 if {[commitinview $nullid $curview]} {
4771 removefakerow $nullid
4773 insertfakerow $nullid2 $viewmainheadid($curview)
4774 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4775 if {[commitinview $nullid $curview]} {
4776 removefakerow $nullid
4778 removefakerow $nullid2
4780 return 0
4783 proc readdifffiles {fd serial inst} {
4784 global viewmainheadid nullid nullid2 curview
4785 global commitinfo commitdata lserial
4787 set isdiff 1
4788 if {[gets $fd line] < 0} {
4789 if {![eof $fd]} {
4790 return 1
4792 set isdiff 0
4794 # we only need to see one line and we don't really care what it says...
4795 stop_instance $inst
4797 if {$serial != $lserial} {
4798 return 0
4801 if {$isdiff && ![commitinview $nullid $curview]} {
4802 # add the line for the local diff to the graph
4803 set hl [mc "Local uncommitted changes, not checked in to index"]
4804 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4805 set commitdata($nullid) "\n $hl\n"
4806 if {[commitinview $nullid2 $curview]} {
4807 set p $nullid2
4808 } else {
4809 set p $viewmainheadid($curview)
4811 insertfakerow $nullid $p
4812 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4813 removefakerow $nullid
4815 return 0
4818 proc nextuse {id row} {
4819 global curview children
4821 if {[info exists children($curview,$id)]} {
4822 foreach kid $children($curview,$id) {
4823 if {![commitinview $kid $curview]} {
4824 return -1
4826 if {[rowofcommit $kid] > $row} {
4827 return [rowofcommit $kid]
4831 if {[commitinview $id $curview]} {
4832 return [rowofcommit $id]
4834 return -1
4837 proc prevuse {id row} {
4838 global curview children
4840 set ret -1
4841 if {[info exists children($curview,$id)]} {
4842 foreach kid $children($curview,$id) {
4843 if {![commitinview $kid $curview]} break
4844 if {[rowofcommit $kid] < $row} {
4845 set ret [rowofcommit $kid]
4849 return $ret
4852 proc make_idlist {row} {
4853 global displayorder parentlist uparrowlen downarrowlen mingaplen
4854 global commitidx curview children
4856 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4857 if {$r < 0} {
4858 set r 0
4860 set ra [expr {$row - $downarrowlen}]
4861 if {$ra < 0} {
4862 set ra 0
4864 set rb [expr {$row + $uparrowlen}]
4865 if {$rb > $commitidx($curview)} {
4866 set rb $commitidx($curview)
4868 make_disporder $r [expr {$rb + 1}]
4869 set ids {}
4870 for {} {$r < $ra} {incr r} {
4871 set nextid [lindex $displayorder [expr {$r + 1}]]
4872 foreach p [lindex $parentlist $r] {
4873 if {$p eq $nextid} continue
4874 set rn [nextuse $p $r]
4875 if {$rn >= $row &&
4876 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4877 lappend ids [list [ordertoken $p] $p]
4881 for {} {$r < $row} {incr r} {
4882 set nextid [lindex $displayorder [expr {$r + 1}]]
4883 foreach p [lindex $parentlist $r] {
4884 if {$p eq $nextid} continue
4885 set rn [nextuse $p $r]
4886 if {$rn < 0 || $rn >= $row} {
4887 lappend ids [list [ordertoken $p] $p]
4891 set id [lindex $displayorder $row]
4892 lappend ids [list [ordertoken $id] $id]
4893 while {$r < $rb} {
4894 foreach p [lindex $parentlist $r] {
4895 set firstkid [lindex $children($curview,$p) 0]
4896 if {[rowofcommit $firstkid] < $row} {
4897 lappend ids [list [ordertoken $p] $p]
4900 incr r
4901 set id [lindex $displayorder $r]
4902 if {$id ne {}} {
4903 set firstkid [lindex $children($curview,$id) 0]
4904 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4905 lappend ids [list [ordertoken $id] $id]
4909 set idlist {}
4910 foreach idx [lsort -unique $ids] {
4911 lappend idlist [lindex $idx 1]
4913 return $idlist
4916 proc rowsequal {a b} {
4917 while {[set i [lsearch -exact $a {}]] >= 0} {
4918 set a [lreplace $a $i $i]
4920 while {[set i [lsearch -exact $b {}]] >= 0} {
4921 set b [lreplace $b $i $i]
4923 return [expr {$a eq $b}]
4926 proc makeupline {id row rend col} {
4927 global rowidlist uparrowlen downarrowlen mingaplen
4929 for {set r $rend} {1} {set r $rstart} {
4930 set rstart [prevuse $id $r]
4931 if {$rstart < 0} return
4932 if {$rstart < $row} break
4934 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4935 set rstart [expr {$rend - $uparrowlen - 1}]
4937 for {set r $rstart} {[incr r] <= $row} {} {
4938 set idlist [lindex $rowidlist $r]
4939 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4940 set col [idcol $idlist $id $col]
4941 lset rowidlist $r [linsert $idlist $col $id]
4942 changedrow $r
4947 proc layoutrows {row endrow} {
4948 global rowidlist rowisopt rowfinal displayorder
4949 global uparrowlen downarrowlen maxwidth mingaplen
4950 global children parentlist
4951 global commitidx viewcomplete curview
4953 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4954 set idlist {}
4955 if {$row > 0} {
4956 set rm1 [expr {$row - 1}]
4957 foreach id [lindex $rowidlist $rm1] {
4958 if {$id ne {}} {
4959 lappend idlist $id
4962 set final [lindex $rowfinal $rm1]
4964 for {} {$row < $endrow} {incr row} {
4965 set rm1 [expr {$row - 1}]
4966 if {$rm1 < 0 || $idlist eq {}} {
4967 set idlist [make_idlist $row]
4968 set final 1
4969 } else {
4970 set id [lindex $displayorder $rm1]
4971 set col [lsearch -exact $idlist $id]
4972 set idlist [lreplace $idlist $col $col]
4973 foreach p [lindex $parentlist $rm1] {
4974 if {[lsearch -exact $idlist $p] < 0} {
4975 set col [idcol $idlist $p $col]
4976 set idlist [linsert $idlist $col $p]
4977 # if not the first child, we have to insert a line going up
4978 if {$id ne [lindex $children($curview,$p) 0]} {
4979 makeupline $p $rm1 $row $col
4983 set id [lindex $displayorder $row]
4984 if {$row > $downarrowlen} {
4985 set termrow [expr {$row - $downarrowlen - 1}]
4986 foreach p [lindex $parentlist $termrow] {
4987 set i [lsearch -exact $idlist $p]
4988 if {$i < 0} continue
4989 set nr [nextuse $p $termrow]
4990 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4991 set idlist [lreplace $idlist $i $i]
4995 set col [lsearch -exact $idlist $id]
4996 if {$col < 0} {
4997 set col [idcol $idlist $id]
4998 set idlist [linsert $idlist $col $id]
4999 if {$children($curview,$id) ne {}} {
5000 makeupline $id $rm1 $row $col
5003 set r [expr {$row + $uparrowlen - 1}]
5004 if {$r < $commitidx($curview)} {
5005 set x $col
5006 foreach p [lindex $parentlist $r] {
5007 if {[lsearch -exact $idlist $p] >= 0} continue
5008 set fk [lindex $children($curview,$p) 0]
5009 if {[rowofcommit $fk] < $row} {
5010 set x [idcol $idlist $p $x]
5011 set idlist [linsert $idlist $x $p]
5014 if {[incr r] < $commitidx($curview)} {
5015 set p [lindex $displayorder $r]
5016 if {[lsearch -exact $idlist $p] < 0} {
5017 set fk [lindex $children($curview,$p) 0]
5018 if {$fk ne {} && [rowofcommit $fk] < $row} {
5019 set x [idcol $idlist $p $x]
5020 set idlist [linsert $idlist $x $p]
5026 if {$final && !$viewcomplete($curview) &&
5027 $row + $uparrowlen + $mingaplen + $downarrowlen
5028 >= $commitidx($curview)} {
5029 set final 0
5031 set l [llength $rowidlist]
5032 if {$row == $l} {
5033 lappend rowidlist $idlist
5034 lappend rowisopt 0
5035 lappend rowfinal $final
5036 } elseif {$row < $l} {
5037 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5038 lset rowidlist $row $idlist
5039 changedrow $row
5041 lset rowfinal $row $final
5042 } else {
5043 set pad [ntimes [expr {$row - $l}] {}]
5044 set rowidlist [concat $rowidlist $pad]
5045 lappend rowidlist $idlist
5046 set rowfinal [concat $rowfinal $pad]
5047 lappend rowfinal $final
5048 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5051 return $row
5054 proc changedrow {row} {
5055 global displayorder iddrawn rowisopt need_redisplay
5057 set l [llength $rowisopt]
5058 if {$row < $l} {
5059 lset rowisopt $row 0
5060 if {$row + 1 < $l} {
5061 lset rowisopt [expr {$row + 1}] 0
5062 if {$row + 2 < $l} {
5063 lset rowisopt [expr {$row + 2}] 0
5067 set id [lindex $displayorder $row]
5068 if {[info exists iddrawn($id)]} {
5069 set need_redisplay 1
5073 proc insert_pad {row col npad} {
5074 global rowidlist
5076 set pad [ntimes $npad {}]
5077 set idlist [lindex $rowidlist $row]
5078 set bef [lrange $idlist 0 [expr {$col - 1}]]
5079 set aft [lrange $idlist $col end]
5080 set i [lsearch -exact $aft {}]
5081 if {$i > 0} {
5082 set aft [lreplace $aft $i $i]
5084 lset rowidlist $row [concat $bef $pad $aft]
5085 changedrow $row
5088 proc optimize_rows {row col endrow} {
5089 global rowidlist rowisopt displayorder curview children
5091 if {$row < 1} {
5092 set row 1
5094 for {} {$row < $endrow} {incr row; set col 0} {
5095 if {[lindex $rowisopt $row]} continue
5096 set haspad 0
5097 set y0 [expr {$row - 1}]
5098 set ym [expr {$row - 2}]
5099 set idlist [lindex $rowidlist $row]
5100 set previdlist [lindex $rowidlist $y0]
5101 if {$idlist eq {} || $previdlist eq {}} continue
5102 if {$ym >= 0} {
5103 set pprevidlist [lindex $rowidlist $ym]
5104 if {$pprevidlist eq {}} continue
5105 } else {
5106 set pprevidlist {}
5108 set x0 -1
5109 set xm -1
5110 for {} {$col < [llength $idlist]} {incr col} {
5111 set id [lindex $idlist $col]
5112 if {[lindex $previdlist $col] eq $id} continue
5113 if {$id eq {}} {
5114 set haspad 1
5115 continue
5117 set x0 [lsearch -exact $previdlist $id]
5118 if {$x0 < 0} continue
5119 set z [expr {$x0 - $col}]
5120 set isarrow 0
5121 set z0 {}
5122 if {$ym >= 0} {
5123 set xm [lsearch -exact $pprevidlist $id]
5124 if {$xm >= 0} {
5125 set z0 [expr {$xm - $x0}]
5128 if {$z0 eq {}} {
5129 # if row y0 is the first child of $id then it's not an arrow
5130 if {[lindex $children($curview,$id) 0] ne
5131 [lindex $displayorder $y0]} {
5132 set isarrow 1
5135 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5136 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5137 set isarrow 1
5139 # Looking at lines from this row to the previous row,
5140 # make them go straight up if they end in an arrow on
5141 # the previous row; otherwise make them go straight up
5142 # or at 45 degrees.
5143 if {$z < -1 || ($z < 0 && $isarrow)} {
5144 # Line currently goes left too much;
5145 # insert pads in the previous row, then optimize it
5146 set npad [expr {-1 - $z + $isarrow}]
5147 insert_pad $y0 $x0 $npad
5148 if {$y0 > 0} {
5149 optimize_rows $y0 $x0 $row
5151 set previdlist [lindex $rowidlist $y0]
5152 set x0 [lsearch -exact $previdlist $id]
5153 set z [expr {$x0 - $col}]
5154 if {$z0 ne {}} {
5155 set pprevidlist [lindex $rowidlist $ym]
5156 set xm [lsearch -exact $pprevidlist $id]
5157 set z0 [expr {$xm - $x0}]
5159 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5160 # Line currently goes right too much;
5161 # insert pads in this line
5162 set npad [expr {$z - 1 + $isarrow}]
5163 insert_pad $row $col $npad
5164 set idlist [lindex $rowidlist $row]
5165 incr col $npad
5166 set z [expr {$x0 - $col}]
5167 set haspad 1
5169 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5170 # this line links to its first child on row $row-2
5171 set id [lindex $displayorder $ym]
5172 set xc [lsearch -exact $pprevidlist $id]
5173 if {$xc >= 0} {
5174 set z0 [expr {$xc - $x0}]
5177 # avoid lines jigging left then immediately right
5178 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5179 insert_pad $y0 $x0 1
5180 incr x0
5181 optimize_rows $y0 $x0 $row
5182 set previdlist [lindex $rowidlist $y0]
5185 if {!$haspad} {
5186 # Find the first column that doesn't have a line going right
5187 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5188 set id [lindex $idlist $col]
5189 if {$id eq {}} break
5190 set x0 [lsearch -exact $previdlist $id]
5191 if {$x0 < 0} {
5192 # check if this is the link to the first child
5193 set kid [lindex $displayorder $y0]
5194 if {[lindex $children($curview,$id) 0] eq $kid} {
5195 # it is, work out offset to child
5196 set x0 [lsearch -exact $previdlist $kid]
5199 if {$x0 <= $col} break
5201 # Insert a pad at that column as long as it has a line and
5202 # isn't the last column
5203 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5204 set idlist [linsert $idlist $col {}]
5205 lset rowidlist $row $idlist
5206 changedrow $row
5212 proc xc {row col} {
5213 global canvx0 linespc
5214 return [expr {$canvx0 + $col * $linespc}]
5217 proc yc {row} {
5218 global canvy0 linespc
5219 return [expr {$canvy0 + $row * $linespc}]
5222 proc linewidth {id} {
5223 global thickerline lthickness
5225 set wid $lthickness
5226 if {[info exists thickerline] && $id eq $thickerline} {
5227 set wid [expr {2 * $lthickness}]
5229 return $wid
5232 proc rowranges {id} {
5233 global curview children uparrowlen downarrowlen
5234 global rowidlist
5236 set kids $children($curview,$id)
5237 if {$kids eq {}} {
5238 return {}
5240 set ret {}
5241 lappend kids $id
5242 foreach child $kids {
5243 if {![commitinview $child $curview]} break
5244 set row [rowofcommit $child]
5245 if {![info exists prev]} {
5246 lappend ret [expr {$row + 1}]
5247 } else {
5248 if {$row <= $prevrow} {
5249 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5251 # see if the line extends the whole way from prevrow to row
5252 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5253 [lsearch -exact [lindex $rowidlist \
5254 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5255 # it doesn't, see where it ends
5256 set r [expr {$prevrow + $downarrowlen}]
5257 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5258 while {[incr r -1] > $prevrow &&
5259 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5260 } else {
5261 while {[incr r] <= $row &&
5262 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5263 incr r -1
5265 lappend ret $r
5266 # see where it starts up again
5267 set r [expr {$row - $uparrowlen}]
5268 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5269 while {[incr r] < $row &&
5270 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5271 } else {
5272 while {[incr r -1] >= $prevrow &&
5273 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5274 incr r
5276 lappend ret $r
5279 if {$child eq $id} {
5280 lappend ret $row
5282 set prev $child
5283 set prevrow $row
5285 return $ret
5288 proc drawlineseg {id row endrow arrowlow} {
5289 global rowidlist displayorder iddrawn linesegs
5290 global canv colormap linespc curview maxlinelen parentlist
5292 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5293 set le [expr {$row + 1}]
5294 set arrowhigh 1
5295 while {1} {
5296 set c [lsearch -exact [lindex $rowidlist $le] $id]
5297 if {$c < 0} {
5298 incr le -1
5299 break
5301 lappend cols $c
5302 set x [lindex $displayorder $le]
5303 if {$x eq $id} {
5304 set arrowhigh 0
5305 break
5307 if {[info exists iddrawn($x)] || $le == $endrow} {
5308 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5309 if {$c >= 0} {
5310 lappend cols $c
5311 set arrowhigh 0
5313 break
5315 incr le
5317 if {$le <= $row} {
5318 return $row
5321 set lines {}
5322 set i 0
5323 set joinhigh 0
5324 if {[info exists linesegs($id)]} {
5325 set lines $linesegs($id)
5326 foreach li $lines {
5327 set r0 [lindex $li 0]
5328 if {$r0 > $row} {
5329 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5330 set joinhigh 1
5332 break
5334 incr i
5337 set joinlow 0
5338 if {$i > 0} {
5339 set li [lindex $lines [expr {$i-1}]]
5340 set r1 [lindex $li 1]
5341 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5342 set joinlow 1
5346 set x [lindex $cols [expr {$le - $row}]]
5347 set xp [lindex $cols [expr {$le - 1 - $row}]]
5348 set dir [expr {$xp - $x}]
5349 if {$joinhigh} {
5350 set ith [lindex $lines $i 2]
5351 set coords [$canv coords $ith]
5352 set ah [$canv itemcget $ith -arrow]
5353 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5354 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5355 if {$x2 ne {} && $x - $x2 == $dir} {
5356 set coords [lrange $coords 0 end-2]
5358 } else {
5359 set coords [list [xc $le $x] [yc $le]]
5361 if {$joinlow} {
5362 set itl [lindex $lines [expr {$i-1}] 2]
5363 set al [$canv itemcget $itl -arrow]
5364 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5365 } elseif {$arrowlow} {
5366 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5367 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5368 set arrowlow 0
5371 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5372 for {set y $le} {[incr y -1] > $row} {} {
5373 set x $xp
5374 set xp [lindex $cols [expr {$y - 1 - $row}]]
5375 set ndir [expr {$xp - $x}]
5376 if {$dir != $ndir || $xp < 0} {
5377 lappend coords [xc $y $x] [yc $y]
5379 set dir $ndir
5381 if {!$joinlow} {
5382 if {$xp < 0} {
5383 # join parent line to first child
5384 set ch [lindex $displayorder $row]
5385 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5386 if {$xc < 0} {
5387 puts "oops: drawlineseg: child $ch not on row $row"
5388 } elseif {$xc != $x} {
5389 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5390 set d [expr {int(0.5 * $linespc)}]
5391 set x1 [xc $row $x]
5392 if {$xc < $x} {
5393 set x2 [expr {$x1 - $d}]
5394 } else {
5395 set x2 [expr {$x1 + $d}]
5397 set y2 [yc $row]
5398 set y1 [expr {$y2 + $d}]
5399 lappend coords $x1 $y1 $x2 $y2
5400 } elseif {$xc < $x - 1} {
5401 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5402 } elseif {$xc > $x + 1} {
5403 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5405 set x $xc
5407 lappend coords [xc $row $x] [yc $row]
5408 } else {
5409 set xn [xc $row $xp]
5410 set yn [yc $row]
5411 lappend coords $xn $yn
5413 if {!$joinhigh} {
5414 assigncolor $id
5415 set t [$canv create line $coords -width [linewidth $id] \
5416 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5417 $canv lower $t
5418 bindline $t $id
5419 set lines [linsert $lines $i [list $row $le $t]]
5420 } else {
5421 $canv coords $ith $coords
5422 if {$arrow ne $ah} {
5423 $canv itemconf $ith -arrow $arrow
5425 lset lines $i 0 $row
5427 } else {
5428 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5429 set ndir [expr {$xo - $xp}]
5430 set clow [$canv coords $itl]
5431 if {$dir == $ndir} {
5432 set clow [lrange $clow 2 end]
5434 set coords [concat $coords $clow]
5435 if {!$joinhigh} {
5436 lset lines [expr {$i-1}] 1 $le
5437 } else {
5438 # coalesce two pieces
5439 $canv delete $ith
5440 set b [lindex $lines [expr {$i-1}] 0]
5441 set e [lindex $lines $i 1]
5442 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5444 $canv coords $itl $coords
5445 if {$arrow ne $al} {
5446 $canv itemconf $itl -arrow $arrow
5450 set linesegs($id) $lines
5451 return $le
5454 proc drawparentlinks {id row} {
5455 global rowidlist canv colormap curview parentlist
5456 global idpos linespc
5458 set rowids [lindex $rowidlist $row]
5459 set col [lsearch -exact $rowids $id]
5460 if {$col < 0} return
5461 set olds [lindex $parentlist $row]
5462 set row2 [expr {$row + 1}]
5463 set x [xc $row $col]
5464 set y [yc $row]
5465 set y2 [yc $row2]
5466 set d [expr {int(0.5 * $linespc)}]
5467 set ymid [expr {$y + $d}]
5468 set ids [lindex $rowidlist $row2]
5469 # rmx = right-most X coord used
5470 set rmx 0
5471 foreach p $olds {
5472 set i [lsearch -exact $ids $p]
5473 if {$i < 0} {
5474 puts "oops, parent $p of $id not in list"
5475 continue
5477 set x2 [xc $row2 $i]
5478 if {$x2 > $rmx} {
5479 set rmx $x2
5481 set j [lsearch -exact $rowids $p]
5482 if {$j < 0} {
5483 # drawlineseg will do this one for us
5484 continue
5486 assigncolor $p
5487 # should handle duplicated parents here...
5488 set coords [list $x $y]
5489 if {$i != $col} {
5490 # if attaching to a vertical segment, draw a smaller
5491 # slant for visual distinctness
5492 if {$i == $j} {
5493 if {$i < $col} {
5494 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5495 } else {
5496 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5498 } elseif {$i < $col && $i < $j} {
5499 # segment slants towards us already
5500 lappend coords [xc $row $j] $y
5501 } else {
5502 if {$i < $col - 1} {
5503 lappend coords [expr {$x2 + $linespc}] $y
5504 } elseif {$i > $col + 1} {
5505 lappend coords [expr {$x2 - $linespc}] $y
5507 lappend coords $x2 $y2
5509 } else {
5510 lappend coords $x2 $y2
5512 set t [$canv create line $coords -width [linewidth $p] \
5513 -fill $colormap($p) -tags lines.$p]
5514 $canv lower $t
5515 bindline $t $p
5517 if {$rmx > [lindex $idpos($id) 1]} {
5518 lset idpos($id) 1 $rmx
5519 redrawtags $id
5523 proc drawlines {id} {
5524 global canv
5526 $canv itemconf lines.$id -width [linewidth $id]
5529 proc drawcmittext {id row col} {
5530 global linespc canv canv2 canv3 fgcolor curview
5531 global cmitlisted commitinfo rowidlist parentlist
5532 global rowtextx idpos idtags idheads idotherrefs
5533 global linehtag linentag linedtag selectedline
5534 global canvxmax boldids boldnameids fgcolor
5535 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5537 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5538 set listed $cmitlisted($curview,$id)
5539 if {$id eq $nullid} {
5540 set ofill red
5541 } elseif {$id eq $nullid2} {
5542 set ofill green
5543 } elseif {$id eq $mainheadid} {
5544 set ofill yellow
5545 } else {
5546 set ofill [lindex $circlecolors $listed]
5548 set x [xc $row $col]
5549 set y [yc $row]
5550 set orad [expr {$linespc / 3}]
5551 if {$listed <= 2} {
5552 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5553 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5554 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5555 } elseif {$listed == 3} {
5556 # triangle pointing left for left-side commits
5557 set t [$canv create polygon \
5558 [expr {$x - $orad}] $y \
5559 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5560 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5561 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5562 } else {
5563 # triangle pointing right for right-side commits
5564 set t [$canv create polygon \
5565 [expr {$x + $orad - 1}] $y \
5566 [expr {$x - $orad}] [expr {$y - $orad}] \
5567 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5568 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5570 set circleitem($row) $t
5571 $canv raise $t
5572 $canv bind $t <1> {selcanvline {} %x %y}
5573 set rmx [llength [lindex $rowidlist $row]]
5574 set olds [lindex $parentlist $row]
5575 if {$olds ne {}} {
5576 set nextids [lindex $rowidlist [expr {$row + 1}]]
5577 foreach p $olds {
5578 set i [lsearch -exact $nextids $p]
5579 if {$i > $rmx} {
5580 set rmx $i
5584 set xt [xc $row $rmx]
5585 set rowtextx($row) $xt
5586 set idpos($id) [list $x $xt $y]
5587 if {[info exists idtags($id)] || [info exists idheads($id)]
5588 || [info exists idotherrefs($id)]} {
5589 set xt [drawtags $id $x $xt $y]
5591 set headline [lindex $commitinfo($id) 0]
5592 set name [lindex $commitinfo($id) 1]
5593 set date [lindex $commitinfo($id) 2]
5594 set date [formatdate $date]
5595 set font mainfont
5596 set nfont mainfont
5597 set isbold [ishighlighted $id]
5598 if {$isbold > 0} {
5599 lappend boldids $id
5600 set font mainfontbold
5601 if {$isbold > 1} {
5602 lappend boldnameids $id
5603 set nfont mainfontbold
5606 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5607 -text $headline -font $font -tags text]
5608 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5609 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5610 -text $name -font $nfont -tags text]
5611 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5612 -text $date -font mainfont -tags text]
5613 if {$selectedline == $row} {
5614 make_secsel $id
5616 set xr [expr {$xt + [font measure $font $headline]}]
5617 if {$xr > $canvxmax} {
5618 set canvxmax $xr
5619 setcanvscroll
5623 proc drawcmitrow {row} {
5624 global displayorder rowidlist nrows_drawn
5625 global iddrawn markingmatches
5626 global commitinfo numcommits
5627 global filehighlight fhighlights findpattern nhighlights
5628 global hlview vhighlights
5629 global highlight_related rhighlights
5631 if {$row >= $numcommits} return
5633 set id [lindex $displayorder $row]
5634 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5635 askvhighlight $row $id
5637 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5638 askfilehighlight $row $id
5640 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5641 askfindhighlight $row $id
5643 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5644 askrelhighlight $row $id
5646 if {![info exists iddrawn($id)]} {
5647 set col [lsearch -exact [lindex $rowidlist $row] $id]
5648 if {$col < 0} {
5649 puts "oops, row $row id $id not in list"
5650 return
5652 if {![info exists commitinfo($id)]} {
5653 getcommit $id
5655 assigncolor $id
5656 drawcmittext $id $row $col
5657 set iddrawn($id) 1
5658 incr nrows_drawn
5660 if {$markingmatches} {
5661 markrowmatches $row $id
5665 proc drawcommits {row {endrow {}}} {
5666 global numcommits iddrawn displayorder curview need_redisplay
5667 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5669 if {$row < 0} {
5670 set row 0
5672 if {$endrow eq {}} {
5673 set endrow $row
5675 if {$endrow >= $numcommits} {
5676 set endrow [expr {$numcommits - 1}]
5679 set rl1 [expr {$row - $downarrowlen - 3}]
5680 if {$rl1 < 0} {
5681 set rl1 0
5683 set ro1 [expr {$row - 3}]
5684 if {$ro1 < 0} {
5685 set ro1 0
5687 set r2 [expr {$endrow + $uparrowlen + 3}]
5688 if {$r2 > $numcommits} {
5689 set r2 $numcommits
5691 for {set r $rl1} {$r < $r2} {incr r} {
5692 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5693 if {$rl1 < $r} {
5694 layoutrows $rl1 $r
5696 set rl1 [expr {$r + 1}]
5699 if {$rl1 < $r} {
5700 layoutrows $rl1 $r
5702 optimize_rows $ro1 0 $r2
5703 if {$need_redisplay || $nrows_drawn > 2000} {
5704 clear_display
5705 drawvisible
5708 # make the lines join to already-drawn rows either side
5709 set r [expr {$row - 1}]
5710 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5711 set r $row
5713 set er [expr {$endrow + 1}]
5714 if {$er >= $numcommits ||
5715 ![info exists iddrawn([lindex $displayorder $er])]} {
5716 set er $endrow
5718 for {} {$r <= $er} {incr r} {
5719 set id [lindex $displayorder $r]
5720 set wasdrawn [info exists iddrawn($id)]
5721 drawcmitrow $r
5722 if {$r == $er} break
5723 set nextid [lindex $displayorder [expr {$r + 1}]]
5724 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5725 drawparentlinks $id $r
5727 set rowids [lindex $rowidlist $r]
5728 foreach lid $rowids {
5729 if {$lid eq {}} continue
5730 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5731 if {$lid eq $id} {
5732 # see if this is the first child of any of its parents
5733 foreach p [lindex $parentlist $r] {
5734 if {[lsearch -exact $rowids $p] < 0} {
5735 # make this line extend up to the child
5736 set lineend($p) [drawlineseg $p $r $er 0]
5739 } else {
5740 set lineend($lid) [drawlineseg $lid $r $er 1]
5746 proc undolayout {row} {
5747 global uparrowlen mingaplen downarrowlen
5748 global rowidlist rowisopt rowfinal need_redisplay
5750 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5751 if {$r < 0} {
5752 set r 0
5754 if {[llength $rowidlist] > $r} {
5755 incr r -1
5756 set rowidlist [lrange $rowidlist 0 $r]
5757 set rowfinal [lrange $rowfinal 0 $r]
5758 set rowisopt [lrange $rowisopt 0 $r]
5759 set need_redisplay 1
5760 run drawvisible
5764 proc drawvisible {} {
5765 global canv linespc curview vrowmod selectedline targetrow targetid
5766 global need_redisplay cscroll numcommits
5768 set fs [$canv yview]
5769 set ymax [lindex [$canv cget -scrollregion] 3]
5770 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5771 set f0 [lindex $fs 0]
5772 set f1 [lindex $fs 1]
5773 set y0 [expr {int($f0 * $ymax)}]
5774 set y1 [expr {int($f1 * $ymax)}]
5776 if {[info exists targetid]} {
5777 if {[commitinview $targetid $curview]} {
5778 set r [rowofcommit $targetid]
5779 if {$r != $targetrow} {
5780 # Fix up the scrollregion and change the scrolling position
5781 # now that our target row has moved.
5782 set diff [expr {($r - $targetrow) * $linespc}]
5783 set targetrow $r
5784 setcanvscroll
5785 set ymax [lindex [$canv cget -scrollregion] 3]
5786 incr y0 $diff
5787 incr y1 $diff
5788 set f0 [expr {$y0 / $ymax}]
5789 set f1 [expr {$y1 / $ymax}]
5790 allcanvs yview moveto $f0
5791 $cscroll set $f0 $f1
5792 set need_redisplay 1
5794 } else {
5795 unset targetid
5799 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5800 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5801 if {$endrow >= $vrowmod($curview)} {
5802 update_arcrows $curview
5804 if {$selectedline ne {} &&
5805 $row <= $selectedline && $selectedline <= $endrow} {
5806 set targetrow $selectedline
5807 } elseif {[info exists targetid]} {
5808 set targetrow [expr {int(($row + $endrow) / 2)}]
5810 if {[info exists targetrow]} {
5811 if {$targetrow >= $numcommits} {
5812 set targetrow [expr {$numcommits - 1}]
5814 set targetid [commitonrow $targetrow]
5816 drawcommits $row $endrow
5819 proc clear_display {} {
5820 global iddrawn linesegs need_redisplay nrows_drawn
5821 global vhighlights fhighlights nhighlights rhighlights
5822 global linehtag linentag linedtag boldids boldnameids
5824 allcanvs delete all
5825 catch {unset iddrawn}
5826 catch {unset linesegs}
5827 catch {unset linehtag}
5828 catch {unset linentag}
5829 catch {unset linedtag}
5830 set boldids {}
5831 set boldnameids {}
5832 catch {unset vhighlights}
5833 catch {unset fhighlights}
5834 catch {unset nhighlights}
5835 catch {unset rhighlights}
5836 set need_redisplay 0
5837 set nrows_drawn 0
5840 proc findcrossings {id} {
5841 global rowidlist parentlist numcommits displayorder
5843 set cross {}
5844 set ccross {}
5845 foreach {s e} [rowranges $id] {
5846 if {$e >= $numcommits} {
5847 set e [expr {$numcommits - 1}]
5849 if {$e <= $s} continue
5850 for {set row $e} {[incr row -1] >= $s} {} {
5851 set x [lsearch -exact [lindex $rowidlist $row] $id]
5852 if {$x < 0} break
5853 set olds [lindex $parentlist $row]
5854 set kid [lindex $displayorder $row]
5855 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5856 if {$kidx < 0} continue
5857 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5858 foreach p $olds {
5859 set px [lsearch -exact $nextrow $p]
5860 if {$px < 0} continue
5861 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5862 if {[lsearch -exact $ccross $p] >= 0} continue
5863 if {$x == $px + ($kidx < $px? -1: 1)} {
5864 lappend ccross $p
5865 } elseif {[lsearch -exact $cross $p] < 0} {
5866 lappend cross $p
5872 return [concat $ccross {{}} $cross]
5875 proc assigncolor {id} {
5876 global colormap colors nextcolor
5877 global parents children children curview
5879 if {[info exists colormap($id)]} return
5880 set ncolors [llength $colors]
5881 if {[info exists children($curview,$id)]} {
5882 set kids $children($curview,$id)
5883 } else {
5884 set kids {}
5886 if {[llength $kids] == 1} {
5887 set child [lindex $kids 0]
5888 if {[info exists colormap($child)]
5889 && [llength $parents($curview,$child)] == 1} {
5890 set colormap($id) $colormap($child)
5891 return
5894 set badcolors {}
5895 set origbad {}
5896 foreach x [findcrossings $id] {
5897 if {$x eq {}} {
5898 # delimiter between corner crossings and other crossings
5899 if {[llength $badcolors] >= $ncolors - 1} break
5900 set origbad $badcolors
5902 if {[info exists colormap($x)]
5903 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5904 lappend badcolors $colormap($x)
5907 if {[llength $badcolors] >= $ncolors} {
5908 set badcolors $origbad
5910 set origbad $badcolors
5911 if {[llength $badcolors] < $ncolors - 1} {
5912 foreach child $kids {
5913 if {[info exists colormap($child)]
5914 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5915 lappend badcolors $colormap($child)
5917 foreach p $parents($curview,$child) {
5918 if {[info exists colormap($p)]
5919 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5920 lappend badcolors $colormap($p)
5924 if {[llength $badcolors] >= $ncolors} {
5925 set badcolors $origbad
5928 for {set i 0} {$i <= $ncolors} {incr i} {
5929 set c [lindex $colors $nextcolor]
5930 if {[incr nextcolor] >= $ncolors} {
5931 set nextcolor 0
5933 if {[lsearch -exact $badcolors $c]} break
5935 set colormap($id) $c
5938 proc bindline {t id} {
5939 global canv
5941 $canv bind $t <Enter> "lineenter %x %y $id"
5942 $canv bind $t <Motion> "linemotion %x %y $id"
5943 $canv bind $t <Leave> "lineleave $id"
5944 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5947 proc drawtags {id x xt y1} {
5948 global idtags idheads idotherrefs mainhead
5949 global linespc lthickness
5950 global canv rowtextx curview fgcolor bgcolor ctxbut
5952 set marks {}
5953 set ntags 0
5954 set nheads 0
5955 if {[info exists idtags($id)]} {
5956 set marks $idtags($id)
5957 set ntags [llength $marks]
5959 if {[info exists idheads($id)]} {
5960 set marks [concat $marks $idheads($id)]
5961 set nheads [llength $idheads($id)]
5963 if {[info exists idotherrefs($id)]} {
5964 set marks [concat $marks $idotherrefs($id)]
5966 if {$marks eq {}} {
5967 return $xt
5970 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5971 set yt [expr {$y1 - 0.5 * $linespc}]
5972 set yb [expr {$yt + $linespc - 1}]
5973 set xvals {}
5974 set wvals {}
5975 set i -1
5976 foreach tag $marks {
5977 incr i
5978 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5979 set wid [font measure mainfontbold $tag]
5980 } else {
5981 set wid [font measure mainfont $tag]
5983 lappend xvals $xt
5984 lappend wvals $wid
5985 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5987 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5988 -width $lthickness -fill black -tags tag.$id]
5989 $canv lower $t
5990 foreach tag $marks x $xvals wid $wvals {
5991 set xl [expr {$x + $delta}]
5992 set xr [expr {$x + $delta + $wid + $lthickness}]
5993 set font mainfont
5994 if {[incr ntags -1] >= 0} {
5995 # draw a tag
5996 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5997 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5998 -width 1 -outline black -fill yellow -tags tag.$id]
5999 $canv bind $t <1> [list showtag $tag 1]
6000 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6001 } else {
6002 # draw a head or other ref
6003 if {[incr nheads -1] >= 0} {
6004 set col green
6005 if {$tag eq $mainhead} {
6006 set font mainfontbold
6008 } else {
6009 set col "#ddddff"
6011 set xl [expr {$xl - $delta/2}]
6012 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6013 -width 1 -outline black -fill $col -tags tag.$id
6014 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6015 set rwid [font measure mainfont $remoteprefix]
6016 set xi [expr {$x + 1}]
6017 set yti [expr {$yt + 1}]
6018 set xri [expr {$x + $rwid}]
6019 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6020 -width 0 -fill "#ffddaa" -tags tag.$id
6023 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6024 -font $font -tags [list tag.$id text]]
6025 if {$ntags >= 0} {
6026 $canv bind $t <1> [list showtag $tag 1]
6027 } elseif {$nheads >= 0} {
6028 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6031 return $xt
6034 proc xcoord {i level ln} {
6035 global canvx0 xspc1 xspc2
6037 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6038 if {$i > 0 && $i == $level} {
6039 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6040 } elseif {$i > $level} {
6041 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6043 return $x
6046 proc show_status {msg} {
6047 global canv fgcolor
6049 clear_display
6050 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6051 -tags text -fill $fgcolor
6054 # Don't change the text pane cursor if it is currently the hand cursor,
6055 # showing that we are over a sha1 ID link.
6056 proc settextcursor {c} {
6057 global ctext curtextcursor
6059 if {[$ctext cget -cursor] == $curtextcursor} {
6060 $ctext config -cursor $c
6062 set curtextcursor $c
6065 proc nowbusy {what {name {}}} {
6066 global isbusy busyname statusw
6068 if {[array names isbusy] eq {}} {
6069 . config -cursor watch
6070 settextcursor watch
6072 set isbusy($what) 1
6073 set busyname($what) $name
6074 if {$name ne {}} {
6075 $statusw conf -text $name
6079 proc notbusy {what} {
6080 global isbusy maincursor textcursor busyname statusw
6082 catch {
6083 unset isbusy($what)
6084 if {$busyname($what) ne {} &&
6085 [$statusw cget -text] eq $busyname($what)} {
6086 $statusw conf -text {}
6089 if {[array names isbusy] eq {}} {
6090 . config -cursor $maincursor
6091 settextcursor $textcursor
6095 proc findmatches {f} {
6096 global findtype findstring
6097 if {$findtype == [mc "Regexp"]} {
6098 set matches [regexp -indices -all -inline $findstring $f]
6099 } else {
6100 set fs $findstring
6101 if {$findtype == [mc "IgnCase"]} {
6102 set f [string tolower $f]
6103 set fs [string tolower $fs]
6105 set matches {}
6106 set i 0
6107 set l [string length $fs]
6108 while {[set j [string first $fs $f $i]] >= 0} {
6109 lappend matches [list $j [expr {$j+$l-1}]]
6110 set i [expr {$j + $l}]
6113 return $matches
6116 proc dofind {{dirn 1} {wrap 1}} {
6117 global findstring findstartline findcurline selectedline numcommits
6118 global gdttype filehighlight fh_serial find_dirn findallowwrap
6120 if {[info exists find_dirn]} {
6121 if {$find_dirn == $dirn} return
6122 stopfinding
6124 focus .
6125 if {$findstring eq {} || $numcommits == 0} return
6126 if {$selectedline eq {}} {
6127 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6128 } else {
6129 set findstartline $selectedline
6131 set findcurline $findstartline
6132 nowbusy finding [mc "Searching"]
6133 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6134 after cancel do_file_hl $fh_serial
6135 do_file_hl $fh_serial
6137 set find_dirn $dirn
6138 set findallowwrap $wrap
6139 run findmore
6142 proc stopfinding {} {
6143 global find_dirn findcurline fprogcoord
6145 if {[info exists find_dirn]} {
6146 unset find_dirn
6147 unset findcurline
6148 notbusy finding
6149 set fprogcoord 0
6150 adjustprogress
6152 stopblaming
6155 proc findmore {} {
6156 global commitdata commitinfo numcommits findpattern findloc
6157 global findstartline findcurline findallowwrap
6158 global find_dirn gdttype fhighlights fprogcoord
6159 global curview varcorder vrownum varccommits vrowmod
6161 if {![info exists find_dirn]} {
6162 return 0
6164 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6165 set l $findcurline
6166 set moretodo 0
6167 if {$find_dirn > 0} {
6168 incr l
6169 if {$l >= $numcommits} {
6170 set l 0
6172 if {$l <= $findstartline} {
6173 set lim [expr {$findstartline + 1}]
6174 } else {
6175 set lim $numcommits
6176 set moretodo $findallowwrap
6178 } else {
6179 if {$l == 0} {
6180 set l $numcommits
6182 incr l -1
6183 if {$l >= $findstartline} {
6184 set lim [expr {$findstartline - 1}]
6185 } else {
6186 set lim -1
6187 set moretodo $findallowwrap
6190 set n [expr {($lim - $l) * $find_dirn}]
6191 if {$n > 500} {
6192 set n 500
6193 set moretodo 1
6195 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6196 update_arcrows $curview
6198 set found 0
6199 set domore 1
6200 set ai [bsearch $vrownum($curview) $l]
6201 set a [lindex $varcorder($curview) $ai]
6202 set arow [lindex $vrownum($curview) $ai]
6203 set ids [lindex $varccommits($curview,$a)]
6204 set arowend [expr {$arow + [llength $ids]}]
6205 if {$gdttype eq [mc "containing:"]} {
6206 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6207 if {$l < $arow || $l >= $arowend} {
6208 incr ai $find_dirn
6209 set a [lindex $varcorder($curview) $ai]
6210 set arow [lindex $vrownum($curview) $ai]
6211 set ids [lindex $varccommits($curview,$a)]
6212 set arowend [expr {$arow + [llength $ids]}]
6214 set id [lindex $ids [expr {$l - $arow}]]
6215 # shouldn't happen unless git log doesn't give all the commits...
6216 if {![info exists commitdata($id)] ||
6217 ![doesmatch $commitdata($id)]} {
6218 continue
6220 if {![info exists commitinfo($id)]} {
6221 getcommit $id
6223 set info $commitinfo($id)
6224 foreach f $info ty $fldtypes {
6225 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6226 [doesmatch $f]} {
6227 set found 1
6228 break
6231 if {$found} break
6233 } else {
6234 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6235 if {$l < $arow || $l >= $arowend} {
6236 incr ai $find_dirn
6237 set a [lindex $varcorder($curview) $ai]
6238 set arow [lindex $vrownum($curview) $ai]
6239 set ids [lindex $varccommits($curview,$a)]
6240 set arowend [expr {$arow + [llength $ids]}]
6242 set id [lindex $ids [expr {$l - $arow}]]
6243 if {![info exists fhighlights($id)]} {
6244 # this sets fhighlights($id) to -1
6245 askfilehighlight $l $id
6247 if {$fhighlights($id) > 0} {
6248 set found $domore
6249 break
6251 if {$fhighlights($id) < 0} {
6252 if {$domore} {
6253 set domore 0
6254 set findcurline [expr {$l - $find_dirn}]
6259 if {$found || ($domore && !$moretodo)} {
6260 unset findcurline
6261 unset find_dirn
6262 notbusy finding
6263 set fprogcoord 0
6264 adjustprogress
6265 if {$found} {
6266 findselectline $l
6267 } else {
6268 bell
6270 return 0
6272 if {!$domore} {
6273 flushhighlights
6274 } else {
6275 set findcurline [expr {$l - $find_dirn}]
6277 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6278 if {$n < 0} {
6279 incr n $numcommits
6281 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6282 adjustprogress
6283 return $domore
6286 proc findselectline {l} {
6287 global findloc commentend ctext findcurline markingmatches gdttype
6289 set markingmatches 1
6290 set findcurline $l
6291 selectline $l 1
6292 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
6293 # highlight the matches in the comments
6294 set f [$ctext get 1.0 $commentend]
6295 set matches [findmatches $f]
6296 foreach match $matches {
6297 set start [lindex $match 0]
6298 set end [expr {[lindex $match 1] + 1}]
6299 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6302 drawvisible
6305 # mark the bits of a headline or author that match a find string
6306 proc markmatches {canv l str tag matches font row} {
6307 global selectedline
6309 set bbox [$canv bbox $tag]
6310 set x0 [lindex $bbox 0]
6311 set y0 [lindex $bbox 1]
6312 set y1 [lindex $bbox 3]
6313 foreach match $matches {
6314 set start [lindex $match 0]
6315 set end [lindex $match 1]
6316 if {$start > $end} continue
6317 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6318 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6319 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6320 [expr {$x0+$xlen+2}] $y1 \
6321 -outline {} -tags [list match$l matches] -fill yellow]
6322 $canv lower $t
6323 if {$row == $selectedline} {
6324 $canv raise $t secsel
6329 proc unmarkmatches {} {
6330 global markingmatches
6332 allcanvs delete matches
6333 set markingmatches 0
6334 stopfinding
6337 proc selcanvline {w x y} {
6338 global canv canvy0 ctext linespc
6339 global rowtextx
6340 set ymax [lindex [$canv cget -scrollregion] 3]
6341 if {$ymax == {}} return
6342 set yfrac [lindex [$canv yview] 0]
6343 set y [expr {$y + $yfrac * $ymax}]
6344 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6345 if {$l < 0} {
6346 set l 0
6348 if {$w eq $canv} {
6349 set xmax [lindex [$canv cget -scrollregion] 2]
6350 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6351 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6353 unmarkmatches
6354 selectline $l 1
6357 proc commit_descriptor {p} {
6358 global commitinfo
6359 if {![info exists commitinfo($p)]} {
6360 getcommit $p
6362 set l "..."
6363 if {[llength $commitinfo($p)] > 1} {
6364 set l [lindex $commitinfo($p) 0]
6366 return "$p ($l)\n"
6369 # append some text to the ctext widget, and make any SHA1 ID
6370 # that we know about be a clickable link.
6371 proc appendwithlinks {text tags} {
6372 global ctext linknum curview
6374 set start [$ctext index "end - 1c"]
6375 $ctext insert end $text $tags
6376 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6377 foreach l $links {
6378 set s [lindex $l 0]
6379 set e [lindex $l 1]
6380 set linkid [string range $text $s $e]
6381 incr e
6382 $ctext tag delete link$linknum
6383 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6384 setlink $linkid link$linknum
6385 incr linknum
6389 proc setlink {id lk} {
6390 global curview ctext pendinglinks
6392 set known 0
6393 if {[string length $id] < 40} {
6394 set matches [longid $id]
6395 if {[llength $matches] > 0} {
6396 if {[llength $matches] > 1} return
6397 set known 1
6398 set id [lindex $matches 0]
6400 } else {
6401 set known [commitinview $id $curview]
6403 if {$known} {
6404 $ctext tag conf $lk -foreground blue -underline 1
6405 $ctext tag bind $lk <1> [list selbyid $id]
6406 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6407 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6408 } else {
6409 lappend pendinglinks($id) $lk
6410 interestedin $id {makelink %P}
6414 proc makelink {id} {
6415 global pendinglinks
6417 if {![info exists pendinglinks($id)]} return
6418 foreach lk $pendinglinks($id) {
6419 setlink $id $lk
6421 unset pendinglinks($id)
6424 proc linkcursor {w inc} {
6425 global linkentercount curtextcursor
6427 if {[incr linkentercount $inc] > 0} {
6428 $w configure -cursor hand2
6429 } else {
6430 $w configure -cursor $curtextcursor
6431 if {$linkentercount < 0} {
6432 set linkentercount 0
6437 proc viewnextline {dir} {
6438 global canv linespc
6440 $canv delete hover
6441 set ymax [lindex [$canv cget -scrollregion] 3]
6442 set wnow [$canv yview]
6443 set wtop [expr {[lindex $wnow 0] * $ymax}]
6444 set newtop [expr {$wtop + $dir * $linespc}]
6445 if {$newtop < 0} {
6446 set newtop 0
6447 } elseif {$newtop > $ymax} {
6448 set newtop $ymax
6450 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6453 # add a list of tag or branch names at position pos
6454 # returns the number of names inserted
6455 proc appendrefs {pos ids var} {
6456 global ctext linknum curview $var maxrefs
6458 if {[catch {$ctext index $pos}]} {
6459 return 0
6461 $ctext conf -state normal
6462 $ctext delete $pos "$pos lineend"
6463 set tags {}
6464 foreach id $ids {
6465 foreach tag [set $var\($id\)] {
6466 lappend tags [list $tag $id]
6469 if {[llength $tags] > $maxrefs} {
6470 $ctext insert $pos "many ([llength $tags])"
6471 } else {
6472 set tags [lsort -index 0 -decreasing $tags]
6473 set sep {}
6474 foreach ti $tags {
6475 set id [lindex $ti 1]
6476 set lk link$linknum
6477 incr linknum
6478 $ctext tag delete $lk
6479 $ctext insert $pos $sep
6480 $ctext insert $pos [lindex $ti 0] $lk
6481 setlink $id $lk
6482 set sep ", "
6485 $ctext conf -state disabled
6486 return [llength $tags]
6489 # called when we have finished computing the nearby tags
6490 proc dispneartags {delay} {
6491 global selectedline currentid showneartags tagphase
6493 if {$selectedline eq {} || !$showneartags} return
6494 after cancel dispnexttag
6495 if {$delay} {
6496 after 200 dispnexttag
6497 set tagphase -1
6498 } else {
6499 after idle dispnexttag
6500 set tagphase 0
6504 proc dispnexttag {} {
6505 global selectedline currentid showneartags tagphase ctext
6507 if {$selectedline eq {} || !$showneartags} return
6508 switch -- $tagphase {
6510 set dtags [desctags $currentid]
6511 if {$dtags ne {}} {
6512 appendrefs precedes $dtags idtags
6516 set atags [anctags $currentid]
6517 if {$atags ne {}} {
6518 appendrefs follows $atags idtags
6522 set dheads [descheads $currentid]
6523 if {$dheads ne {}} {
6524 if {[appendrefs branch $dheads idheads] > 1
6525 && [$ctext get "branch -3c"] eq "h"} {
6526 # turn "Branch" into "Branches"
6527 $ctext conf -state normal
6528 $ctext insert "branch -2c" "es"
6529 $ctext conf -state disabled
6534 if {[incr tagphase] <= 2} {
6535 after idle dispnexttag
6539 proc make_secsel {id} {
6540 global linehtag linentag linedtag canv canv2 canv3
6542 if {![info exists linehtag($id)]} return
6543 $canv delete secsel
6544 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6545 -tags secsel -fill [$canv cget -selectbackground]]
6546 $canv lower $t
6547 $canv2 delete secsel
6548 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6549 -tags secsel -fill [$canv2 cget -selectbackground]]
6550 $canv2 lower $t
6551 $canv3 delete secsel
6552 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6553 -tags secsel -fill [$canv3 cget -selectbackground]]
6554 $canv3 lower $t
6557 proc selectline {l isnew {desired_loc {}}} {
6558 global canv ctext commitinfo selectedline
6559 global canvy0 linespc parents children curview
6560 global currentid sha1entry
6561 global commentend idtags linknum
6562 global mergemax numcommits pending_select
6563 global cmitmode showneartags allcommits
6564 global targetrow targetid lastscrollrows
6565 global autoselect jump_to_here
6567 catch {unset pending_select}
6568 $canv delete hover
6569 normalline
6570 unsel_reflist
6571 stopfinding
6572 if {$l < 0 || $l >= $numcommits} return
6573 set id [commitonrow $l]
6574 set targetid $id
6575 set targetrow $l
6576 set selectedline $l
6577 set currentid $id
6578 if {$lastscrollrows < $numcommits} {
6579 setcanvscroll
6582 set y [expr {$canvy0 + $l * $linespc}]
6583 set ymax [lindex [$canv cget -scrollregion] 3]
6584 set ytop [expr {$y - $linespc - 1}]
6585 set ybot [expr {$y + $linespc + 1}]
6586 set wnow [$canv yview]
6587 set wtop [expr {[lindex $wnow 0] * $ymax}]
6588 set wbot [expr {[lindex $wnow 1] * $ymax}]
6589 set wh [expr {$wbot - $wtop}]
6590 set newtop $wtop
6591 if {$ytop < $wtop} {
6592 if {$ybot < $wtop} {
6593 set newtop [expr {$y - $wh / 2.0}]
6594 } else {
6595 set newtop $ytop
6596 if {$newtop > $wtop - $linespc} {
6597 set newtop [expr {$wtop - $linespc}]
6600 } elseif {$ybot > $wbot} {
6601 if {$ytop > $wbot} {
6602 set newtop [expr {$y - $wh / 2.0}]
6603 } else {
6604 set newtop [expr {$ybot - $wh}]
6605 if {$newtop < $wtop + $linespc} {
6606 set newtop [expr {$wtop + $linespc}]
6610 if {$newtop != $wtop} {
6611 if {$newtop < 0} {
6612 set newtop 0
6614 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6615 drawvisible
6618 make_secsel $id
6620 if {$isnew} {
6621 addtohistory [list selbyid $id 0] savecmitpos
6624 $sha1entry delete 0 end
6625 $sha1entry insert 0 $id
6626 if {$autoselect} {
6627 $sha1entry selection from 0
6628 $sha1entry selection to end
6630 rhighlight_sel $id
6632 $ctext conf -state normal
6633 clear_ctext
6634 set linknum 0
6635 if {![info exists commitinfo($id)]} {
6636 getcommit $id
6638 set info $commitinfo($id)
6639 set date [formatdate [lindex $info 2]]
6640 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6641 set date [formatdate [lindex $info 4]]
6642 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6643 if {[info exists idtags($id)]} {
6644 $ctext insert end [mc "Tags:"]
6645 foreach tag $idtags($id) {
6646 $ctext insert end " $tag"
6648 $ctext insert end "\n"
6651 set headers {}
6652 set olds $parents($curview,$id)
6653 if {[llength $olds] > 1} {
6654 set np 0
6655 foreach p $olds {
6656 if {$np >= $mergemax} {
6657 set tag mmax
6658 } else {
6659 set tag m$np
6661 $ctext insert end "[mc "Parent"]: " $tag
6662 appendwithlinks [commit_descriptor $p] {}
6663 incr np
6665 } else {
6666 foreach p $olds {
6667 append headers "[mc "Parent"]: [commit_descriptor $p]"
6671 foreach c $children($curview,$id) {
6672 append headers "[mc "Child"]: [commit_descriptor $c]"
6675 # make anything that looks like a SHA1 ID be a clickable link
6676 appendwithlinks $headers {}
6677 if {$showneartags} {
6678 if {![info exists allcommits]} {
6679 getallcommits
6681 $ctext insert end "[mc "Branch"]: "
6682 $ctext mark set branch "end -1c"
6683 $ctext mark gravity branch left
6684 $ctext insert end "\n[mc "Follows"]: "
6685 $ctext mark set follows "end -1c"
6686 $ctext mark gravity follows left
6687 $ctext insert end "\n[mc "Precedes"]: "
6688 $ctext mark set precedes "end -1c"
6689 $ctext mark gravity precedes left
6690 $ctext insert end "\n"
6691 dispneartags 1
6693 $ctext insert end "\n"
6694 set comment [lindex $info 5]
6695 if {[string first "\r" $comment] >= 0} {
6696 set comment [string map {"\r" "\n "} $comment]
6698 appendwithlinks $comment {comment}
6700 $ctext tag remove found 1.0 end
6701 $ctext conf -state disabled
6702 set commentend [$ctext index "end - 1c"]
6704 set jump_to_here $desired_loc
6705 init_flist [mc "Comments"]
6706 if {$cmitmode eq "tree"} {
6707 gettree $id
6708 } elseif {[llength $olds] <= 1} {
6709 startdiff $id
6710 } else {
6711 mergediff $id
6715 proc selfirstline {} {
6716 unmarkmatches
6717 selectline 0 1
6720 proc sellastline {} {
6721 global numcommits
6722 unmarkmatches
6723 set l [expr {$numcommits - 1}]
6724 selectline $l 1
6727 proc selnextline {dir} {
6728 global selectedline
6729 focus .
6730 if {$selectedline eq {}} return
6731 set l [expr {$selectedline + $dir}]
6732 unmarkmatches
6733 selectline $l 1
6736 proc selnextpage {dir} {
6737 global canv linespc selectedline numcommits
6739 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6740 if {$lpp < 1} {
6741 set lpp 1
6743 allcanvs yview scroll [expr {$dir * $lpp}] units
6744 drawvisible
6745 if {$selectedline eq {}} return
6746 set l [expr {$selectedline + $dir * $lpp}]
6747 if {$l < 0} {
6748 set l 0
6749 } elseif {$l >= $numcommits} {
6750 set l [expr $numcommits - 1]
6752 unmarkmatches
6753 selectline $l 1
6756 proc unselectline {} {
6757 global selectedline currentid
6759 set selectedline {}
6760 catch {unset currentid}
6761 allcanvs delete secsel
6762 rhighlight_none
6765 proc reselectline {} {
6766 global selectedline
6768 if {$selectedline ne {}} {
6769 selectline $selectedline 0
6773 proc addtohistory {cmd {saveproc {}}} {
6774 global history historyindex curview
6776 unset_posvars
6777 save_position
6778 set elt [list $curview $cmd $saveproc {}]
6779 if {$historyindex > 0
6780 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6781 return
6784 if {$historyindex < [llength $history]} {
6785 set history [lreplace $history $historyindex end $elt]
6786 } else {
6787 lappend history $elt
6789 incr historyindex
6790 if {$historyindex > 1} {
6791 .tf.bar.leftbut conf -state normal
6792 } else {
6793 .tf.bar.leftbut conf -state disabled
6795 .tf.bar.rightbut conf -state disabled
6798 # save the scrolling position of the diff display pane
6799 proc save_position {} {
6800 global historyindex history
6802 if {$historyindex < 1} return
6803 set hi [expr {$historyindex - 1}]
6804 set fn [lindex $history $hi 2]
6805 if {$fn ne {}} {
6806 lset history $hi 3 [eval $fn]
6810 proc unset_posvars {} {
6811 global last_posvars
6813 if {[info exists last_posvars]} {
6814 foreach {var val} $last_posvars {
6815 global $var
6816 catch {unset $var}
6818 unset last_posvars
6822 proc godo {elt} {
6823 global curview last_posvars
6825 set view [lindex $elt 0]
6826 set cmd [lindex $elt 1]
6827 set pv [lindex $elt 3]
6828 if {$curview != $view} {
6829 showview $view
6831 unset_posvars
6832 foreach {var val} $pv {
6833 global $var
6834 set $var $val
6836 set last_posvars $pv
6837 eval $cmd
6840 proc goback {} {
6841 global history historyindex
6842 focus .
6844 if {$historyindex > 1} {
6845 save_position
6846 incr historyindex -1
6847 godo [lindex $history [expr {$historyindex - 1}]]
6848 .tf.bar.rightbut conf -state normal
6850 if {$historyindex <= 1} {
6851 .tf.bar.leftbut conf -state disabled
6855 proc goforw {} {
6856 global history historyindex
6857 focus .
6859 if {$historyindex < [llength $history]} {
6860 save_position
6861 set cmd [lindex $history $historyindex]
6862 incr historyindex
6863 godo $cmd
6864 .tf.bar.leftbut conf -state normal
6866 if {$historyindex >= [llength $history]} {
6867 .tf.bar.rightbut conf -state disabled
6871 proc gettree {id} {
6872 global treefilelist treeidlist diffids diffmergeid treepending
6873 global nullid nullid2
6875 set diffids $id
6876 catch {unset diffmergeid}
6877 if {![info exists treefilelist($id)]} {
6878 if {![info exists treepending]} {
6879 if {$id eq $nullid} {
6880 set cmd [list | git ls-files]
6881 } elseif {$id eq $nullid2} {
6882 set cmd [list | git ls-files --stage -t]
6883 } else {
6884 set cmd [list | git ls-tree -r $id]
6886 if {[catch {set gtf [open $cmd r]}]} {
6887 return
6889 set treepending $id
6890 set treefilelist($id) {}
6891 set treeidlist($id) {}
6892 fconfigure $gtf -blocking 0 -encoding binary
6893 filerun $gtf [list gettreeline $gtf $id]
6895 } else {
6896 setfilelist $id
6900 proc gettreeline {gtf id} {
6901 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6903 set nl 0
6904 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6905 if {$diffids eq $nullid} {
6906 set fname $line
6907 } else {
6908 set i [string first "\t" $line]
6909 if {$i < 0} continue
6910 set fname [string range $line [expr {$i+1}] end]
6911 set line [string range $line 0 [expr {$i-1}]]
6912 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6913 set sha1 [lindex $line 2]
6914 lappend treeidlist($id) $sha1
6916 if {[string index $fname 0] eq "\""} {
6917 set fname [lindex $fname 0]
6919 set fname [encoding convertfrom $fname]
6920 lappend treefilelist($id) $fname
6922 if {![eof $gtf]} {
6923 return [expr {$nl >= 1000? 2: 1}]
6925 close $gtf
6926 unset treepending
6927 if {$cmitmode ne "tree"} {
6928 if {![info exists diffmergeid]} {
6929 gettreediffs $diffids
6931 } elseif {$id ne $diffids} {
6932 gettree $diffids
6933 } else {
6934 setfilelist $id
6936 return 0
6939 proc showfile {f} {
6940 global treefilelist treeidlist diffids nullid nullid2
6941 global ctext_file_names ctext_file_lines
6942 global ctext commentend
6944 set i [lsearch -exact $treefilelist($diffids) $f]
6945 if {$i < 0} {
6946 puts "oops, $f not in list for id $diffids"
6947 return
6949 if {$diffids eq $nullid} {
6950 if {[catch {set bf [open $f r]} err]} {
6951 puts "oops, can't read $f: $err"
6952 return
6954 } else {
6955 set blob [lindex $treeidlist($diffids) $i]
6956 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6957 puts "oops, error reading blob $blob: $err"
6958 return
6961 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6962 filerun $bf [list getblobline $bf $diffids]
6963 $ctext config -state normal
6964 clear_ctext $commentend
6965 lappend ctext_file_names $f
6966 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6967 $ctext insert end "\n"
6968 $ctext insert end "$f\n" filesep
6969 $ctext config -state disabled
6970 $ctext yview $commentend
6971 settabs 0
6974 proc getblobline {bf id} {
6975 global diffids cmitmode ctext
6977 if {$id ne $diffids || $cmitmode ne "tree"} {
6978 catch {close $bf}
6979 return 0
6981 $ctext config -state normal
6982 set nl 0
6983 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6984 $ctext insert end "$line\n"
6986 if {[eof $bf]} {
6987 global jump_to_here ctext_file_names commentend
6989 # delete last newline
6990 $ctext delete "end - 2c" "end - 1c"
6991 close $bf
6992 if {$jump_to_here ne {} &&
6993 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6994 set lnum [expr {[lindex $jump_to_here 1] +
6995 [lindex [split $commentend .] 0]}]
6996 mark_ctext_line $lnum
6998 return 0
7000 $ctext config -state disabled
7001 return [expr {$nl >= 1000? 2: 1}]
7004 proc mark_ctext_line {lnum} {
7005 global ctext markbgcolor
7007 $ctext tag delete omark
7008 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7009 $ctext tag conf omark -background $markbgcolor
7010 $ctext see $lnum.0
7013 proc mergediff {id} {
7014 global diffmergeid
7015 global diffids treediffs
7016 global parents curview
7018 set diffmergeid $id
7019 set diffids $id
7020 set treediffs($id) {}
7021 set np [llength $parents($curview,$id)]
7022 settabs $np
7023 getblobdiffs $id
7026 proc startdiff {ids} {
7027 global treediffs diffids treepending diffmergeid nullid nullid2
7029 settabs 1
7030 set diffids $ids
7031 catch {unset diffmergeid}
7032 if {![info exists treediffs($ids)] ||
7033 [lsearch -exact $ids $nullid] >= 0 ||
7034 [lsearch -exact $ids $nullid2] >= 0} {
7035 if {![info exists treepending]} {
7036 gettreediffs $ids
7038 } else {
7039 addtocflist $ids
7043 proc path_filter {filter name} {
7044 foreach p $filter {
7045 set l [string length $p]
7046 if {[string index $p end] eq "/"} {
7047 if {[string compare -length $l $p $name] == 0} {
7048 return 1
7050 } else {
7051 if {[string compare -length $l $p $name] == 0 &&
7052 ([string length $name] == $l ||
7053 [string index $name $l] eq "/")} {
7054 return 1
7058 return 0
7061 proc addtocflist {ids} {
7062 global treediffs
7064 add_flist $treediffs($ids)
7065 getblobdiffs $ids
7068 proc diffcmd {ids flags} {
7069 global nullid nullid2
7071 set i [lsearch -exact $ids $nullid]
7072 set j [lsearch -exact $ids $nullid2]
7073 if {$i >= 0} {
7074 if {[llength $ids] > 1 && $j < 0} {
7075 # comparing working directory with some specific revision
7076 set cmd [concat | git diff-index $flags]
7077 if {$i == 0} {
7078 lappend cmd -R [lindex $ids 1]
7079 } else {
7080 lappend cmd [lindex $ids 0]
7082 } else {
7083 # comparing working directory with index
7084 set cmd [concat | git diff-files $flags]
7085 if {$j == 1} {
7086 lappend cmd -R
7089 } elseif {$j >= 0} {
7090 set cmd [concat | git diff-index --cached $flags]
7091 if {[llength $ids] > 1} {
7092 # comparing index with specific revision
7093 if {$i == 0} {
7094 lappend cmd -R [lindex $ids 1]
7095 } else {
7096 lappend cmd [lindex $ids 0]
7098 } else {
7099 # comparing index with HEAD
7100 lappend cmd HEAD
7102 } else {
7103 set cmd [concat | git diff-tree -r $flags $ids]
7105 return $cmd
7108 proc gettreediffs {ids} {
7109 global treediff treepending
7111 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7113 set treepending $ids
7114 set treediff {}
7115 fconfigure $gdtf -blocking 0 -encoding binary
7116 filerun $gdtf [list gettreediffline $gdtf $ids]
7119 proc gettreediffline {gdtf ids} {
7120 global treediff treediffs treepending diffids diffmergeid
7121 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7123 set nr 0
7124 set sublist {}
7125 set max 1000
7126 if {$perfile_attrs} {
7127 # cache_gitattr is slow, and even slower on win32 where we
7128 # have to invoke it for only about 30 paths at a time
7129 set max 500
7130 if {[tk windowingsystem] == "win32"} {
7131 set max 120
7134 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7135 set i [string first "\t" $line]
7136 if {$i >= 0} {
7137 set file [string range $line [expr {$i+1}] end]
7138 if {[string index $file 0] eq "\""} {
7139 set file [lindex $file 0]
7141 set file [encoding convertfrom $file]
7142 if {$file ne [lindex $treediff end]} {
7143 lappend treediff $file
7144 lappend sublist $file
7148 if {$perfile_attrs} {
7149 cache_gitattr encoding $sublist
7151 if {![eof $gdtf]} {
7152 return [expr {$nr >= $max? 2: 1}]
7154 close $gdtf
7155 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7156 set flist {}
7157 foreach f $treediff {
7158 if {[path_filter $vfilelimit($curview) $f]} {
7159 lappend flist $f
7162 set treediffs($ids) $flist
7163 } else {
7164 set treediffs($ids) $treediff
7166 unset treepending
7167 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7168 gettree $diffids
7169 } elseif {$ids != $diffids} {
7170 if {![info exists diffmergeid]} {
7171 gettreediffs $diffids
7173 } else {
7174 addtocflist $ids
7176 return 0
7179 # empty string or positive integer
7180 proc diffcontextvalidate {v} {
7181 return [regexp {^(|[1-9][0-9]*)$} $v]
7184 proc diffcontextchange {n1 n2 op} {
7185 global diffcontextstring diffcontext
7187 if {[string is integer -strict $diffcontextstring]} {
7188 if {$diffcontextstring > 0} {
7189 set diffcontext $diffcontextstring
7190 reselectline
7195 proc changeignorespace {} {
7196 reselectline
7199 proc getblobdiffs {ids} {
7200 global blobdifffd diffids env
7201 global diffinhdr treediffs
7202 global diffcontext
7203 global ignorespace
7204 global limitdiffs vfilelimit curview
7205 global diffencoding targetline diffnparents
7207 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7208 if {$ignorespace} {
7209 append cmd " -w"
7211 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7212 set cmd [concat $cmd -- $vfilelimit($curview)]
7214 if {[catch {set bdf [open $cmd r]} err]} {
7215 error_popup [mc "Error getting diffs: %s" $err]
7216 return
7218 set targetline {}
7219 set diffnparents 0
7220 set diffinhdr 0
7221 set diffencoding [get_path_encoding {}]
7222 fconfigure $bdf -blocking 0 -encoding binary
7223 set blobdifffd($ids) $bdf
7224 filerun $bdf [list getblobdiffline $bdf $diffids]
7227 proc savecmitpos {} {
7228 global ctext cmitmode
7230 if {$cmitmode eq "tree"} {
7231 return {}
7233 return [list target_scrollpos [$ctext index @0,0]]
7236 proc savectextpos {} {
7237 global ctext
7239 return [list target_scrollpos [$ctext index @0,0]]
7242 proc maybe_scroll_ctext {ateof} {
7243 global ctext target_scrollpos
7245 if {![info exists target_scrollpos]} return
7246 if {!$ateof} {
7247 set nlines [expr {[winfo height $ctext]
7248 / [font metrics textfont -linespace]}]
7249 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7251 $ctext yview $target_scrollpos
7252 unset target_scrollpos
7255 proc setinlist {var i val} {
7256 global $var
7258 while {[llength [set $var]] < $i} {
7259 lappend $var {}
7261 if {[llength [set $var]] == $i} {
7262 lappend $var $val
7263 } else {
7264 lset $var $i $val
7268 proc makediffhdr {fname ids} {
7269 global ctext curdiffstart treediffs diffencoding
7270 global ctext_file_names jump_to_here targetline diffline
7272 set fname [encoding convertfrom $fname]
7273 set diffencoding [get_path_encoding $fname]
7274 set i [lsearch -exact $treediffs($ids) $fname]
7275 if {$i >= 0} {
7276 setinlist difffilestart $i $curdiffstart
7278 lset ctext_file_names end $fname
7279 set l [expr {(78 - [string length $fname]) / 2}]
7280 set pad [string range "----------------------------------------" 1 $l]
7281 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7282 set targetline {}
7283 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7284 set targetline [lindex $jump_to_here 1]
7286 set diffline 0
7289 proc getblobdiffline {bdf ids} {
7290 global diffids blobdifffd ctext curdiffstart
7291 global diffnexthead diffnextnote difffilestart
7292 global ctext_file_names ctext_file_lines
7293 global diffinhdr treediffs mergemax diffnparents
7294 global diffencoding jump_to_here targetline diffline
7296 set nr 0
7297 $ctext conf -state normal
7298 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7299 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7300 close $bdf
7301 return 0
7303 if {![string compare -length 5 "diff " $line]} {
7304 if {![regexp {^diff (--cc|--git) } $line m type]} {
7305 set line [encoding convertfrom $line]
7306 $ctext insert end "$line\n" hunksep
7307 continue
7309 # start of a new file
7310 set diffinhdr 1
7311 $ctext insert end "\n"
7312 set curdiffstart [$ctext index "end - 1c"]
7313 lappend ctext_file_names ""
7314 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7315 $ctext insert end "\n" filesep
7317 if {$type eq "--cc"} {
7318 # start of a new file in a merge diff
7319 set fname [string range $line 10 end]
7320 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7321 lappend treediffs($ids) $fname
7322 add_flist [list $fname]
7325 } else {
7326 set line [string range $line 11 end]
7327 # If the name hasn't changed the length will be odd,
7328 # the middle char will be a space, and the two bits either
7329 # side will be a/name and b/name, or "a/name" and "b/name".
7330 # If the name has changed we'll get "rename from" and
7331 # "rename to" or "copy from" and "copy to" lines following
7332 # this, and we'll use them to get the filenames.
7333 # This complexity is necessary because spaces in the
7334 # filename(s) don't get escaped.
7335 set l [string length $line]
7336 set i [expr {$l / 2}]
7337 if {!(($l & 1) && [string index $line $i] eq " " &&
7338 [string range $line 2 [expr {$i - 1}]] eq \
7339 [string range $line [expr {$i + 3}] end])} {
7340 continue
7342 # unescape if quoted and chop off the a/ from the front
7343 if {[string index $line 0] eq "\""} {
7344 set fname [string range [lindex $line 0] 2 end]
7345 } else {
7346 set fname [string range $line 2 [expr {$i - 1}]]
7349 makediffhdr $fname $ids
7351 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7352 set fname [encoding convertfrom [string range $line 16 end]]
7353 $ctext insert end "\n"
7354 set curdiffstart [$ctext index "end - 1c"]
7355 lappend ctext_file_names $fname
7356 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7357 $ctext insert end "$line\n" filesep
7358 set i [lsearch -exact $treediffs($ids) $fname]
7359 if {$i >= 0} {
7360 setinlist difffilestart $i $curdiffstart
7363 } elseif {![string compare -length 2 "@@" $line]} {
7364 regexp {^@@+} $line ats
7365 set line [encoding convertfrom $diffencoding $line]
7366 $ctext insert end "$line\n" hunksep
7367 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7368 set diffline $nl
7370 set diffnparents [expr {[string length $ats] - 1}]
7371 set diffinhdr 0
7373 } elseif {$diffinhdr} {
7374 if {![string compare -length 12 "rename from " $line]} {
7375 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7376 if {[string index $fname 0] eq "\""} {
7377 set fname [lindex $fname 0]
7379 set fname [encoding convertfrom $fname]
7380 set i [lsearch -exact $treediffs($ids) $fname]
7381 if {$i >= 0} {
7382 setinlist difffilestart $i $curdiffstart
7384 } elseif {![string compare -length 10 $line "rename to "] ||
7385 ![string compare -length 8 $line "copy to "]} {
7386 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7387 if {[string index $fname 0] eq "\""} {
7388 set fname [lindex $fname 0]
7390 makediffhdr $fname $ids
7391 } elseif {[string compare -length 3 $line "---"] == 0} {
7392 # do nothing
7393 continue
7394 } elseif {[string compare -length 3 $line "+++"] == 0} {
7395 set diffinhdr 0
7396 continue
7398 $ctext insert end "$line\n" filesep
7400 } else {
7401 set line [encoding convertfrom $diffencoding $line]
7402 # parse the prefix - one ' ', '-' or '+' for each parent
7403 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7404 set tag [expr {$diffnparents > 1? "m": "d"}]
7405 if {[string trim $prefix " -+"] eq {}} {
7406 # prefix only has " ", "-" and "+" in it: normal diff line
7407 set num [string first "-" $prefix]
7408 if {$num >= 0} {
7409 # removed line, first parent with line is $num
7410 if {$num >= $mergemax} {
7411 set num "max"
7413 $ctext insert end "$line\n" $tag$num
7414 } else {
7415 set tags {}
7416 if {[string first "+" $prefix] >= 0} {
7417 # added line
7418 lappend tags ${tag}result
7419 if {$diffnparents > 1} {
7420 set num [string first " " $prefix]
7421 if {$num >= 0} {
7422 if {$num >= $mergemax} {
7423 set num "max"
7425 lappend tags m$num
7429 if {$targetline ne {}} {
7430 if {$diffline == $targetline} {
7431 set seehere [$ctext index "end - 1 chars"]
7432 set targetline {}
7433 } else {
7434 incr diffline
7437 $ctext insert end "$line\n" $tags
7439 } else {
7440 # "\ No newline at end of file",
7441 # or something else we don't recognize
7442 $ctext insert end "$line\n" hunksep
7446 if {[info exists seehere]} {
7447 mark_ctext_line [lindex [split $seehere .] 0]
7449 maybe_scroll_ctext [eof $bdf]
7450 $ctext conf -state disabled
7451 if {[eof $bdf]} {
7452 close $bdf
7453 return 0
7455 return [expr {$nr >= 1000? 2: 1}]
7458 proc changediffdisp {} {
7459 global ctext diffelide
7461 $ctext tag conf d0 -elide [lindex $diffelide 0]
7462 $ctext tag conf dresult -elide [lindex $diffelide 1]
7465 proc highlightfile {loc cline} {
7466 global ctext cflist cflist_top
7468 $ctext yview $loc
7469 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7470 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7471 $cflist see $cline.0
7472 set cflist_top $cline
7475 proc prevfile {} {
7476 global difffilestart ctext cmitmode
7478 if {$cmitmode eq "tree"} return
7479 set prev 0.0
7480 set prevline 1
7481 set here [$ctext index @0,0]
7482 foreach loc $difffilestart {
7483 if {[$ctext compare $loc >= $here]} {
7484 highlightfile $prev $prevline
7485 return
7487 set prev $loc
7488 incr prevline
7490 highlightfile $prev $prevline
7493 proc nextfile {} {
7494 global difffilestart ctext cmitmode
7496 if {$cmitmode eq "tree"} return
7497 set here [$ctext index @0,0]
7498 set line 1
7499 foreach loc $difffilestart {
7500 incr line
7501 if {[$ctext compare $loc > $here]} {
7502 highlightfile $loc $line
7503 return
7508 proc clear_ctext {{first 1.0}} {
7509 global ctext smarktop smarkbot
7510 global ctext_file_names ctext_file_lines
7511 global pendinglinks
7513 set l [lindex [split $first .] 0]
7514 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7515 set smarktop $l
7517 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7518 set smarkbot $l
7520 $ctext delete $first end
7521 if {$first eq "1.0"} {
7522 catch {unset pendinglinks}
7524 set ctext_file_names {}
7525 set ctext_file_lines {}
7528 proc settabs {{firstab {}}} {
7529 global firsttabstop tabstop ctext have_tk85
7531 if {$firstab ne {} && $have_tk85} {
7532 set firsttabstop $firstab
7534 set w [font measure textfont "0"]
7535 if {$firsttabstop != 0} {
7536 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7537 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7538 } elseif {$have_tk85 || $tabstop != 8} {
7539 $ctext conf -tabs [expr {$tabstop * $w}]
7540 } else {
7541 $ctext conf -tabs {}
7545 proc incrsearch {name ix op} {
7546 global ctext searchstring searchdirn
7548 $ctext tag remove found 1.0 end
7549 if {[catch {$ctext index anchor}]} {
7550 # no anchor set, use start of selection, or of visible area
7551 set sel [$ctext tag ranges sel]
7552 if {$sel ne {}} {
7553 $ctext mark set anchor [lindex $sel 0]
7554 } elseif {$searchdirn eq "-forwards"} {
7555 $ctext mark set anchor @0,0
7556 } else {
7557 $ctext mark set anchor @0,[winfo height $ctext]
7560 if {$searchstring ne {}} {
7561 set here [$ctext search $searchdirn -- $searchstring anchor]
7562 if {$here ne {}} {
7563 $ctext see $here
7565 searchmarkvisible 1
7569 proc dosearch {} {
7570 global sstring ctext searchstring searchdirn
7572 focus $sstring
7573 $sstring icursor end
7574 set searchdirn -forwards
7575 if {$searchstring ne {}} {
7576 set sel [$ctext tag ranges sel]
7577 if {$sel ne {}} {
7578 set start "[lindex $sel 0] + 1c"
7579 } elseif {[catch {set start [$ctext index anchor]}]} {
7580 set start "@0,0"
7582 set match [$ctext search -count mlen -- $searchstring $start]
7583 $ctext tag remove sel 1.0 end
7584 if {$match eq {}} {
7585 bell
7586 return
7588 $ctext see $match
7589 set mend "$match + $mlen c"
7590 $ctext tag add sel $match $mend
7591 $ctext mark unset anchor
7595 proc dosearchback {} {
7596 global sstring ctext searchstring searchdirn
7598 focus $sstring
7599 $sstring icursor end
7600 set searchdirn -backwards
7601 if {$searchstring ne {}} {
7602 set sel [$ctext tag ranges sel]
7603 if {$sel ne {}} {
7604 set start [lindex $sel 0]
7605 } elseif {[catch {set start [$ctext index anchor]}]} {
7606 set start @0,[winfo height $ctext]
7608 set match [$ctext search -backwards -count ml -- $searchstring $start]
7609 $ctext tag remove sel 1.0 end
7610 if {$match eq {}} {
7611 bell
7612 return
7614 $ctext see $match
7615 set mend "$match + $ml c"
7616 $ctext tag add sel $match $mend
7617 $ctext mark unset anchor
7621 proc searchmark {first last} {
7622 global ctext searchstring
7624 set mend $first.0
7625 while {1} {
7626 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7627 if {$match eq {}} break
7628 set mend "$match + $mlen c"
7629 $ctext tag add found $match $mend
7633 proc searchmarkvisible {doall} {
7634 global ctext smarktop smarkbot
7636 set topline [lindex [split [$ctext index @0,0] .] 0]
7637 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7638 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7639 # no overlap with previous
7640 searchmark $topline $botline
7641 set smarktop $topline
7642 set smarkbot $botline
7643 } else {
7644 if {$topline < $smarktop} {
7645 searchmark $topline [expr {$smarktop-1}]
7646 set smarktop $topline
7648 if {$botline > $smarkbot} {
7649 searchmark [expr {$smarkbot+1}] $botline
7650 set smarkbot $botline
7655 proc scrolltext {f0 f1} {
7656 global searchstring
7658 .bleft.bottom.sb set $f0 $f1
7659 if {$searchstring ne {}} {
7660 searchmarkvisible 0
7664 proc setcoords {} {
7665 global linespc charspc canvx0 canvy0
7666 global xspc1 xspc2 lthickness
7668 set linespc [font metrics mainfont -linespace]
7669 set charspc [font measure mainfont "m"]
7670 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7671 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7672 set lthickness [expr {int($linespc / 9) + 1}]
7673 set xspc1(0) $linespc
7674 set xspc2 $linespc
7677 proc redisplay {} {
7678 global canv
7679 global selectedline
7681 set ymax [lindex [$canv cget -scrollregion] 3]
7682 if {$ymax eq {} || $ymax == 0} return
7683 set span [$canv yview]
7684 clear_display
7685 setcanvscroll
7686 allcanvs yview moveto [lindex $span 0]
7687 drawvisible
7688 if {$selectedline ne {}} {
7689 selectline $selectedline 0
7690 allcanvs yview moveto [lindex $span 0]
7694 proc parsefont {f n} {
7695 global fontattr
7697 set fontattr($f,family) [lindex $n 0]
7698 set s [lindex $n 1]
7699 if {$s eq {} || $s == 0} {
7700 set s 10
7701 } elseif {$s < 0} {
7702 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7704 set fontattr($f,size) $s
7705 set fontattr($f,weight) normal
7706 set fontattr($f,slant) roman
7707 foreach style [lrange $n 2 end] {
7708 switch -- $style {
7709 "normal" -
7710 "bold" {set fontattr($f,weight) $style}
7711 "roman" -
7712 "italic" {set fontattr($f,slant) $style}
7717 proc fontflags {f {isbold 0}} {
7718 global fontattr
7720 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7721 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7722 -slant $fontattr($f,slant)]
7725 proc fontname {f} {
7726 global fontattr
7728 set n [list $fontattr($f,family) $fontattr($f,size)]
7729 if {$fontattr($f,weight) eq "bold"} {
7730 lappend n "bold"
7732 if {$fontattr($f,slant) eq "italic"} {
7733 lappend n "italic"
7735 return $n
7738 proc incrfont {inc} {
7739 global mainfont textfont ctext canv cflist showrefstop
7740 global stopped entries fontattr
7742 unmarkmatches
7743 set s $fontattr(mainfont,size)
7744 incr s $inc
7745 if {$s < 1} {
7746 set s 1
7748 set fontattr(mainfont,size) $s
7749 font config mainfont -size $s
7750 font config mainfontbold -size $s
7751 set mainfont [fontname mainfont]
7752 set s $fontattr(textfont,size)
7753 incr s $inc
7754 if {$s < 1} {
7755 set s 1
7757 set fontattr(textfont,size) $s
7758 font config textfont -size $s
7759 font config textfontbold -size $s
7760 set textfont [fontname textfont]
7761 setcoords
7762 settabs
7763 redisplay
7766 proc clearsha1 {} {
7767 global sha1entry sha1string
7768 if {[string length $sha1string] == 40} {
7769 $sha1entry delete 0 end
7773 proc sha1change {n1 n2 op} {
7774 global sha1string currentid sha1but
7775 if {$sha1string == {}
7776 || ([info exists currentid] && $sha1string == $currentid)} {
7777 set state disabled
7778 } else {
7779 set state normal
7781 if {[$sha1but cget -state] == $state} return
7782 if {$state == "normal"} {
7783 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7784 } else {
7785 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7789 proc gotocommit {} {
7790 global sha1string tagids headids curview varcid
7792 if {$sha1string == {}
7793 || ([info exists currentid] && $sha1string == $currentid)} return
7794 if {[info exists tagids($sha1string)]} {
7795 set id $tagids($sha1string)
7796 } elseif {[info exists headids($sha1string)]} {
7797 set id $headids($sha1string)
7798 } else {
7799 set id [string tolower $sha1string]
7800 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7801 set matches [longid $id]
7802 if {$matches ne {}} {
7803 if {[llength $matches] > 1} {
7804 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7805 return
7807 set id [lindex $matches 0]
7811 if {[commitinview $id $curview]} {
7812 selectline [rowofcommit $id] 1
7813 return
7815 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7816 set msg [mc "SHA1 id %s is not known" $sha1string]
7817 } else {
7818 set msg [mc "Tag/Head %s is not known" $sha1string]
7820 error_popup $msg
7823 proc lineenter {x y id} {
7824 global hoverx hovery hoverid hovertimer
7825 global commitinfo canv
7827 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7828 set hoverx $x
7829 set hovery $y
7830 set hoverid $id
7831 if {[info exists hovertimer]} {
7832 after cancel $hovertimer
7834 set hovertimer [after 500 linehover]
7835 $canv delete hover
7838 proc linemotion {x y id} {
7839 global hoverx hovery hoverid hovertimer
7841 if {[info exists hoverid] && $id == $hoverid} {
7842 set hoverx $x
7843 set hovery $y
7844 if {[info exists hovertimer]} {
7845 after cancel $hovertimer
7847 set hovertimer [after 500 linehover]
7851 proc lineleave {id} {
7852 global hoverid hovertimer canv
7854 if {[info exists hoverid] && $id == $hoverid} {
7855 $canv delete hover
7856 if {[info exists hovertimer]} {
7857 after cancel $hovertimer
7858 unset hovertimer
7860 unset hoverid
7864 proc linehover {} {
7865 global hoverx hovery hoverid hovertimer
7866 global canv linespc lthickness
7867 global commitinfo
7869 set text [lindex $commitinfo($hoverid) 0]
7870 set ymax [lindex [$canv cget -scrollregion] 3]
7871 if {$ymax == {}} return
7872 set yfrac [lindex [$canv yview] 0]
7873 set x [expr {$hoverx + 2 * $linespc}]
7874 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7875 set x0 [expr {$x - 2 * $lthickness}]
7876 set y0 [expr {$y - 2 * $lthickness}]
7877 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7878 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7879 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7880 -fill \#ffff80 -outline black -width 1 -tags hover]
7881 $canv raise $t
7882 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7883 -font mainfont]
7884 $canv raise $t
7887 proc clickisonarrow {id y} {
7888 global lthickness
7890 set ranges [rowranges $id]
7891 set thresh [expr {2 * $lthickness + 6}]
7892 set n [expr {[llength $ranges] - 1}]
7893 for {set i 1} {$i < $n} {incr i} {
7894 set row [lindex $ranges $i]
7895 if {abs([yc $row] - $y) < $thresh} {
7896 return $i
7899 return {}
7902 proc arrowjump {id n y} {
7903 global canv
7905 # 1 <-> 2, 3 <-> 4, etc...
7906 set n [expr {(($n - 1) ^ 1) + 1}]
7907 set row [lindex [rowranges $id] $n]
7908 set yt [yc $row]
7909 set ymax [lindex [$canv cget -scrollregion] 3]
7910 if {$ymax eq {} || $ymax <= 0} return
7911 set view [$canv yview]
7912 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7913 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7914 if {$yfrac < 0} {
7915 set yfrac 0
7917 allcanvs yview moveto $yfrac
7920 proc lineclick {x y id isnew} {
7921 global ctext commitinfo children canv thickerline curview
7923 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7924 unmarkmatches
7925 unselectline
7926 normalline
7927 $canv delete hover
7928 # draw this line thicker than normal
7929 set thickerline $id
7930 drawlines $id
7931 if {$isnew} {
7932 set ymax [lindex [$canv cget -scrollregion] 3]
7933 if {$ymax eq {}} return
7934 set yfrac [lindex [$canv yview] 0]
7935 set y [expr {$y + $yfrac * $ymax}]
7937 set dirn [clickisonarrow $id $y]
7938 if {$dirn ne {}} {
7939 arrowjump $id $dirn $y
7940 return
7943 if {$isnew} {
7944 addtohistory [list lineclick $x $y $id 0] savectextpos
7946 # fill the details pane with info about this line
7947 $ctext conf -state normal
7948 clear_ctext
7949 settabs 0
7950 $ctext insert end "[mc "Parent"]:\t"
7951 $ctext insert end $id link0
7952 setlink $id link0
7953 set info $commitinfo($id)
7954 $ctext insert end "\n\t[lindex $info 0]\n"
7955 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7956 set date [formatdate [lindex $info 2]]
7957 $ctext insert end "\t[mc "Date"]:\t$date\n"
7958 set kids $children($curview,$id)
7959 if {$kids ne {}} {
7960 $ctext insert end "\n[mc "Children"]:"
7961 set i 0
7962 foreach child $kids {
7963 incr i
7964 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7965 set info $commitinfo($child)
7966 $ctext insert end "\n\t"
7967 $ctext insert end $child link$i
7968 setlink $child link$i
7969 $ctext insert end "\n\t[lindex $info 0]"
7970 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7971 set date [formatdate [lindex $info 2]]
7972 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7975 maybe_scroll_ctext 1
7976 $ctext conf -state disabled
7977 init_flist {}
7980 proc normalline {} {
7981 global thickerline
7982 if {[info exists thickerline]} {
7983 set id $thickerline
7984 unset thickerline
7985 drawlines $id
7989 proc selbyid {id {isnew 1}} {
7990 global curview
7991 if {[commitinview $id $curview]} {
7992 selectline [rowofcommit $id] $isnew
7996 proc mstime {} {
7997 global startmstime
7998 if {![info exists startmstime]} {
7999 set startmstime [clock clicks -milliseconds]
8001 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8004 proc rowmenu {x y id} {
8005 global rowctxmenu selectedline rowmenuid curview
8006 global nullid nullid2 fakerowmenu mainhead
8008 stopfinding
8009 set rowmenuid $id
8010 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8011 set state disabled
8012 } else {
8013 set state normal
8015 if {$id ne $nullid && $id ne $nullid2} {
8016 set menu $rowctxmenu
8017 if {$mainhead ne {}} {
8018 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
8019 } else {
8020 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8022 } else {
8023 set menu $fakerowmenu
8025 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8026 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8027 $menu entryconfigure [mca "Make patch"] -state $state
8028 tk_popup $menu $x $y
8031 proc diffvssel {dirn} {
8032 global rowmenuid selectedline
8034 if {$selectedline eq {}} return
8035 if {$dirn} {
8036 set oldid [commitonrow $selectedline]
8037 set newid $rowmenuid
8038 } else {
8039 set oldid $rowmenuid
8040 set newid [commitonrow $selectedline]
8042 addtohistory [list doseldiff $oldid $newid] savectextpos
8043 doseldiff $oldid $newid
8046 proc doseldiff {oldid newid} {
8047 global ctext
8048 global commitinfo
8050 $ctext conf -state normal
8051 clear_ctext
8052 init_flist [mc "Top"]
8053 $ctext insert end "[mc "From"] "
8054 $ctext insert end $oldid link0
8055 setlink $oldid link0
8056 $ctext insert end "\n "
8057 $ctext insert end [lindex $commitinfo($oldid) 0]
8058 $ctext insert end "\n\n[mc "To"] "
8059 $ctext insert end $newid link1
8060 setlink $newid link1
8061 $ctext insert end "\n "
8062 $ctext insert end [lindex $commitinfo($newid) 0]
8063 $ctext insert end "\n"
8064 $ctext conf -state disabled
8065 $ctext tag remove found 1.0 end
8066 startdiff [list $oldid $newid]
8069 proc mkpatch {} {
8070 global rowmenuid currentid commitinfo patchtop patchnum
8072 if {![info exists currentid]} return
8073 set oldid $currentid
8074 set oldhead [lindex $commitinfo($oldid) 0]
8075 set newid $rowmenuid
8076 set newhead [lindex $commitinfo($newid) 0]
8077 set top .patch
8078 set patchtop $top
8079 catch {destroy $top}
8080 toplevel $top
8081 make_transient $top .
8082 label $top.title -text [mc "Generate patch"]
8083 grid $top.title - -pady 10
8084 label $top.from -text [mc "From:"]
8085 entry $top.fromsha1 -width 40 -relief flat
8086 $top.fromsha1 insert 0 $oldid
8087 $top.fromsha1 conf -state readonly
8088 grid $top.from $top.fromsha1 -sticky w
8089 entry $top.fromhead -width 60 -relief flat
8090 $top.fromhead insert 0 $oldhead
8091 $top.fromhead conf -state readonly
8092 grid x $top.fromhead -sticky w
8093 label $top.to -text [mc "To:"]
8094 entry $top.tosha1 -width 40 -relief flat
8095 $top.tosha1 insert 0 $newid
8096 $top.tosha1 conf -state readonly
8097 grid $top.to $top.tosha1 -sticky w
8098 entry $top.tohead -width 60 -relief flat
8099 $top.tohead insert 0 $newhead
8100 $top.tohead conf -state readonly
8101 grid x $top.tohead -sticky w
8102 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8103 grid $top.rev x -pady 10
8104 label $top.flab -text [mc "Output file:"]
8105 entry $top.fname -width 60
8106 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8107 incr patchnum
8108 grid $top.flab $top.fname -sticky w
8109 frame $top.buts
8110 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8111 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8112 bind $top <Key-Return> mkpatchgo
8113 bind $top <Key-Escape> mkpatchcan
8114 grid $top.buts.gen $top.buts.can
8115 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8116 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8117 grid $top.buts - -pady 10 -sticky ew
8118 focus $top.fname
8121 proc mkpatchrev {} {
8122 global patchtop
8124 set oldid [$patchtop.fromsha1 get]
8125 set oldhead [$patchtop.fromhead get]
8126 set newid [$patchtop.tosha1 get]
8127 set newhead [$patchtop.tohead get]
8128 foreach e [list fromsha1 fromhead tosha1 tohead] \
8129 v [list $newid $newhead $oldid $oldhead] {
8130 $patchtop.$e conf -state normal
8131 $patchtop.$e delete 0 end
8132 $patchtop.$e insert 0 $v
8133 $patchtop.$e conf -state readonly
8137 proc mkpatchgo {} {
8138 global patchtop nullid nullid2
8140 set oldid [$patchtop.fromsha1 get]
8141 set newid [$patchtop.tosha1 get]
8142 set fname [$patchtop.fname get]
8143 set cmd [diffcmd [list $oldid $newid] -p]
8144 # trim off the initial "|"
8145 set cmd [lrange $cmd 1 end]
8146 lappend cmd >$fname &
8147 if {[catch {eval exec $cmd} err]} {
8148 error_popup "[mc "Error creating patch:"] $err" $patchtop
8150 catch {destroy $patchtop}
8151 unset patchtop
8154 proc mkpatchcan {} {
8155 global patchtop
8157 catch {destroy $patchtop}
8158 unset patchtop
8161 proc mktag {} {
8162 global rowmenuid mktagtop commitinfo
8164 set top .maketag
8165 set mktagtop $top
8166 catch {destroy $top}
8167 toplevel $top
8168 make_transient $top .
8169 label $top.title -text [mc "Create tag"]
8170 grid $top.title - -pady 10
8171 label $top.id -text [mc "ID:"]
8172 entry $top.sha1 -width 40 -relief flat
8173 $top.sha1 insert 0 $rowmenuid
8174 $top.sha1 conf -state readonly
8175 grid $top.id $top.sha1 -sticky w
8176 entry $top.head -width 60 -relief flat
8177 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8178 $top.head conf -state readonly
8179 grid x $top.head -sticky w
8180 label $top.tlab -text [mc "Tag name:"]
8181 entry $top.tag -width 60
8182 grid $top.tlab $top.tag -sticky w
8183 frame $top.buts
8184 button $top.buts.gen -text [mc "Create"] -command mktaggo
8185 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8186 bind $top <Key-Return> mktaggo
8187 bind $top <Key-Escape> mktagcan
8188 grid $top.buts.gen $top.buts.can
8189 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8190 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8191 grid $top.buts - -pady 10 -sticky ew
8192 focus $top.tag
8195 proc domktag {} {
8196 global mktagtop env tagids idtags
8198 set id [$mktagtop.sha1 get]
8199 set tag [$mktagtop.tag get]
8200 if {$tag == {}} {
8201 error_popup [mc "No tag name specified"] $mktagtop
8202 return 0
8204 if {[info exists tagids($tag)]} {
8205 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8206 return 0
8208 if {[catch {
8209 exec git tag $tag $id
8210 } err]} {
8211 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8212 return 0
8215 set tagids($tag) $id
8216 lappend idtags($id) $tag
8217 redrawtags $id
8218 addedtag $id
8219 dispneartags 0
8220 run refill_reflist
8221 return 1
8224 proc redrawtags {id} {
8225 global canv linehtag idpos currentid curview cmitlisted
8226 global canvxmax iddrawn circleitem mainheadid circlecolors
8228 if {![commitinview $id $curview]} return
8229 if {![info exists iddrawn($id)]} return
8230 set row [rowofcommit $id]
8231 if {$id eq $mainheadid} {
8232 set ofill yellow
8233 } else {
8234 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8236 $canv itemconf $circleitem($row) -fill $ofill
8237 $canv delete tag.$id
8238 set xt [eval drawtags $id $idpos($id)]
8239 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8240 set text [$canv itemcget $linehtag($id) -text]
8241 set font [$canv itemcget $linehtag($id) -font]
8242 set xr [expr {$xt + [font measure $font $text]}]
8243 if {$xr > $canvxmax} {
8244 set canvxmax $xr
8245 setcanvscroll
8247 if {[info exists currentid] && $currentid == $id} {
8248 make_secsel $id
8252 proc mktagcan {} {
8253 global mktagtop
8255 catch {destroy $mktagtop}
8256 unset mktagtop
8259 proc mktaggo {} {
8260 if {![domktag]} return
8261 mktagcan
8264 proc writecommit {} {
8265 global rowmenuid wrcomtop commitinfo wrcomcmd
8267 set top .writecommit
8268 set wrcomtop $top
8269 catch {destroy $top}
8270 toplevel $top
8271 make_transient $top .
8272 label $top.title -text [mc "Write commit to file"]
8273 grid $top.title - -pady 10
8274 label $top.id -text [mc "ID:"]
8275 entry $top.sha1 -width 40 -relief flat
8276 $top.sha1 insert 0 $rowmenuid
8277 $top.sha1 conf -state readonly
8278 grid $top.id $top.sha1 -sticky w
8279 entry $top.head -width 60 -relief flat
8280 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8281 $top.head conf -state readonly
8282 grid x $top.head -sticky w
8283 label $top.clab -text [mc "Command:"]
8284 entry $top.cmd -width 60 -textvariable wrcomcmd
8285 grid $top.clab $top.cmd -sticky w -pady 10
8286 label $top.flab -text [mc "Output file:"]
8287 entry $top.fname -width 60
8288 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8289 grid $top.flab $top.fname -sticky w
8290 frame $top.buts
8291 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8292 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8293 bind $top <Key-Return> wrcomgo
8294 bind $top <Key-Escape> wrcomcan
8295 grid $top.buts.gen $top.buts.can
8296 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8297 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8298 grid $top.buts - -pady 10 -sticky ew
8299 focus $top.fname
8302 proc wrcomgo {} {
8303 global wrcomtop
8305 set id [$wrcomtop.sha1 get]
8306 set cmd "echo $id | [$wrcomtop.cmd get]"
8307 set fname [$wrcomtop.fname get]
8308 if {[catch {exec sh -c $cmd >$fname &} err]} {
8309 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8311 catch {destroy $wrcomtop}
8312 unset wrcomtop
8315 proc wrcomcan {} {
8316 global wrcomtop
8318 catch {destroy $wrcomtop}
8319 unset wrcomtop
8322 proc mkbranch {} {
8323 global rowmenuid mkbrtop
8325 set top .makebranch
8326 catch {destroy $top}
8327 toplevel $top
8328 make_transient $top .
8329 label $top.title -text [mc "Create new branch"]
8330 grid $top.title - -pady 10
8331 label $top.id -text [mc "ID:"]
8332 entry $top.sha1 -width 40 -relief flat
8333 $top.sha1 insert 0 $rowmenuid
8334 $top.sha1 conf -state readonly
8335 grid $top.id $top.sha1 -sticky w
8336 label $top.nlab -text [mc "Name:"]
8337 entry $top.name -width 40
8338 grid $top.nlab $top.name -sticky w
8339 frame $top.buts
8340 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8341 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8342 bind $top <Key-Return> [list mkbrgo $top]
8343 bind $top <Key-Escape> "catch {destroy $top}"
8344 grid $top.buts.go $top.buts.can
8345 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8346 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8347 grid $top.buts - -pady 10 -sticky ew
8348 focus $top.name
8351 proc mkbrgo {top} {
8352 global headids idheads
8354 set name [$top.name get]
8355 set id [$top.sha1 get]
8356 set cmdargs {}
8357 set old_id {}
8358 if {$name eq {}} {
8359 error_popup [mc "Please specify a name for the new branch"] $top
8360 return
8362 if {[info exists headids($name)]} {
8363 if {![confirm_popup [mc \
8364 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8365 return
8367 set old_id $headids($name)
8368 lappend cmdargs -f
8370 catch {destroy $top}
8371 lappend cmdargs $name $id
8372 nowbusy newbranch
8373 update
8374 if {[catch {
8375 eval exec git branch $cmdargs
8376 } err]} {
8377 notbusy newbranch
8378 error_popup $err
8379 } else {
8380 notbusy newbranch
8381 if {$old_id ne {}} {
8382 movehead $id $name
8383 movedhead $id $name
8384 redrawtags $old_id
8385 redrawtags $id
8386 } else {
8387 set headids($name) $id
8388 lappend idheads($id) $name
8389 addedhead $id $name
8390 redrawtags $id
8392 dispneartags 0
8393 run refill_reflist
8397 proc exec_citool {tool_args {baseid {}}} {
8398 global commitinfo env
8400 set save_env [array get env GIT_AUTHOR_*]
8402 if {$baseid ne {}} {
8403 if {![info exists commitinfo($baseid)]} {
8404 getcommit $baseid
8406 set author [lindex $commitinfo($baseid) 1]
8407 set date [lindex $commitinfo($baseid) 2]
8408 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8409 $author author name email]
8410 && $date ne {}} {
8411 set env(GIT_AUTHOR_NAME) $name
8412 set env(GIT_AUTHOR_EMAIL) $email
8413 set env(GIT_AUTHOR_DATE) $date
8417 eval exec git citool $tool_args &
8419 array unset env GIT_AUTHOR_*
8420 array set env $save_env
8423 proc cherrypick {} {
8424 global rowmenuid curview
8425 global mainhead mainheadid
8427 set oldhead [exec git rev-parse HEAD]
8428 set dheads [descheads $rowmenuid]
8429 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8430 set ok [confirm_popup [mc "Commit %s is already\
8431 included in branch %s -- really re-apply it?" \
8432 [string range $rowmenuid 0 7] $mainhead]]
8433 if {!$ok} return
8435 nowbusy cherrypick [mc "Cherry-picking"]
8436 update
8437 # Unfortunately git-cherry-pick writes stuff to stderr even when
8438 # no error occurs, and exec takes that as an indication of error...
8439 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8440 notbusy cherrypick
8441 if {[regexp -line \
8442 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8443 $err msg fname]} {
8444 error_popup [mc "Cherry-pick failed because of local changes\
8445 to file '%s'.\nPlease commit, reset or stash\
8446 your changes and try again." $fname]
8447 } elseif {[regexp -line \
8448 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8449 $err]} {
8450 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8451 conflict.\nDo you wish to run git citool to\
8452 resolve it?"]]} {
8453 # Force citool to read MERGE_MSG
8454 file delete [file join [gitdir] "GITGUI_MSG"]
8455 exec_citool {} $rowmenuid
8457 } else {
8458 error_popup $err
8460 run updatecommits
8461 return
8463 set newhead [exec git rev-parse HEAD]
8464 if {$newhead eq $oldhead} {
8465 notbusy cherrypick
8466 error_popup [mc "No changes committed"]
8467 return
8469 addnewchild $newhead $oldhead
8470 if {[commitinview $oldhead $curview]} {
8471 # XXX this isn't right if we have a path limit...
8472 insertrow $newhead $oldhead $curview
8473 if {$mainhead ne {}} {
8474 movehead $newhead $mainhead
8475 movedhead $newhead $mainhead
8477 set mainheadid $newhead
8478 redrawtags $oldhead
8479 redrawtags $newhead
8480 selbyid $newhead
8482 notbusy cherrypick
8485 proc resethead {} {
8486 global mainhead rowmenuid confirm_ok resettype
8488 set confirm_ok 0
8489 set w ".confirmreset"
8490 toplevel $w
8491 make_transient $w .
8492 wm title $w [mc "Confirm reset"]
8493 message $w.m -text \
8494 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8495 -justify center -aspect 1000
8496 pack $w.m -side top -fill x -padx 20 -pady 20
8497 frame $w.f -relief sunken -border 2
8498 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8499 grid $w.f.rt -sticky w
8500 set resettype mixed
8501 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8502 -text [mc "Soft: Leave working tree and index untouched"]
8503 grid $w.f.soft -sticky w
8504 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8505 -text [mc "Mixed: Leave working tree untouched, reset index"]
8506 grid $w.f.mixed -sticky w
8507 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8508 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8509 grid $w.f.hard -sticky w
8510 pack $w.f -side top -fill x
8511 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8512 pack $w.ok -side left -fill x -padx 20 -pady 20
8513 button $w.cancel -text [mc Cancel] -command "destroy $w"
8514 bind $w <Key-Escape> [list destroy $w]
8515 pack $w.cancel -side right -fill x -padx 20 -pady 20
8516 bind $w <Visibility> "grab $w; focus $w"
8517 tkwait window $w
8518 if {!$confirm_ok} return
8519 if {[catch {set fd [open \
8520 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8521 error_popup $err
8522 } else {
8523 dohidelocalchanges
8524 filerun $fd [list readresetstat $fd]
8525 nowbusy reset [mc "Resetting"]
8526 selbyid $rowmenuid
8530 proc readresetstat {fd} {
8531 global mainhead mainheadid showlocalchanges rprogcoord
8533 if {[gets $fd line] >= 0} {
8534 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8535 set rprogcoord [expr {1.0 * $m / $n}]
8536 adjustprogress
8538 return 1
8540 set rprogcoord 0
8541 adjustprogress
8542 notbusy reset
8543 if {[catch {close $fd} err]} {
8544 error_popup $err
8546 set oldhead $mainheadid
8547 set newhead [exec git rev-parse HEAD]
8548 if {$newhead ne $oldhead} {
8549 movehead $newhead $mainhead
8550 movedhead $newhead $mainhead
8551 set mainheadid $newhead
8552 redrawtags $oldhead
8553 redrawtags $newhead
8555 if {$showlocalchanges} {
8556 doshowlocalchanges
8558 return 0
8561 # context menu for a head
8562 proc headmenu {x y id head} {
8563 global headmenuid headmenuhead headctxmenu mainhead
8565 stopfinding
8566 set headmenuid $id
8567 set headmenuhead $head
8568 set state normal
8569 if {$head eq $mainhead} {
8570 set state disabled
8572 $headctxmenu entryconfigure 0 -state $state
8573 $headctxmenu entryconfigure 1 -state $state
8574 tk_popup $headctxmenu $x $y
8577 proc cobranch {} {
8578 global headmenuid headmenuhead headids
8579 global showlocalchanges
8581 # check the tree is clean first??
8582 nowbusy checkout [mc "Checking out"]
8583 update
8584 dohidelocalchanges
8585 if {[catch {
8586 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8587 } err]} {
8588 notbusy checkout
8589 error_popup $err
8590 if {$showlocalchanges} {
8591 dodiffindex
8593 } else {
8594 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8598 proc readcheckoutstat {fd newhead newheadid} {
8599 global mainhead mainheadid headids showlocalchanges progresscoords
8600 global viewmainheadid curview
8602 if {[gets $fd line] >= 0} {
8603 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8604 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8605 adjustprogress
8607 return 1
8609 set progresscoords {0 0}
8610 adjustprogress
8611 notbusy checkout
8612 if {[catch {close $fd} err]} {
8613 error_popup $err
8615 set oldmainid $mainheadid
8616 set mainhead $newhead
8617 set mainheadid $newheadid
8618 set viewmainheadid($curview) $newheadid
8619 redrawtags $oldmainid
8620 redrawtags $newheadid
8621 selbyid $newheadid
8622 if {$showlocalchanges} {
8623 dodiffindex
8627 proc rmbranch {} {
8628 global headmenuid headmenuhead mainhead
8629 global idheads
8631 set head $headmenuhead
8632 set id $headmenuid
8633 # this check shouldn't be needed any more...
8634 if {$head eq $mainhead} {
8635 error_popup [mc "Cannot delete the currently checked-out branch"]
8636 return
8638 set dheads [descheads $id]
8639 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8640 # the stuff on this branch isn't on any other branch
8641 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8642 branch.\nReally delete branch %s?" $head $head]]} return
8644 nowbusy rmbranch
8645 update
8646 if {[catch {exec git branch -D $head} err]} {
8647 notbusy rmbranch
8648 error_popup $err
8649 return
8651 removehead $id $head
8652 removedhead $id $head
8653 redrawtags $id
8654 notbusy rmbranch
8655 dispneartags 0
8656 run refill_reflist
8659 # Display a list of tags and heads
8660 proc showrefs {} {
8661 global showrefstop bgcolor fgcolor selectbgcolor
8662 global bglist fglist reflistfilter reflist maincursor
8664 set top .showrefs
8665 set showrefstop $top
8666 if {[winfo exists $top]} {
8667 raise $top
8668 refill_reflist
8669 return
8671 toplevel $top
8672 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8673 make_transient $top .
8674 text $top.list -background $bgcolor -foreground $fgcolor \
8675 -selectbackground $selectbgcolor -font mainfont \
8676 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8677 -width 30 -height 20 -cursor $maincursor \
8678 -spacing1 1 -spacing3 1 -state disabled
8679 $top.list tag configure highlight -background $selectbgcolor
8680 lappend bglist $top.list
8681 lappend fglist $top.list
8682 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8683 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8684 grid $top.list $top.ysb -sticky nsew
8685 grid $top.xsb x -sticky ew
8686 frame $top.f
8687 label $top.f.l -text "[mc "Filter"]: "
8688 entry $top.f.e -width 20 -textvariable reflistfilter
8689 set reflistfilter "*"
8690 trace add variable reflistfilter write reflistfilter_change
8691 pack $top.f.e -side right -fill x -expand 1
8692 pack $top.f.l -side left
8693 grid $top.f - -sticky ew -pady 2
8694 button $top.close -command [list destroy $top] -text [mc "Close"]
8695 bind $top <Key-Escape> [list destroy $top]
8696 grid $top.close -
8697 grid columnconfigure $top 0 -weight 1
8698 grid rowconfigure $top 0 -weight 1
8699 bind $top.list <1> {break}
8700 bind $top.list <B1-Motion> {break}
8701 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8702 set reflist {}
8703 refill_reflist
8706 proc sel_reflist {w x y} {
8707 global showrefstop reflist headids tagids otherrefids
8709 if {![winfo exists $showrefstop]} return
8710 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8711 set ref [lindex $reflist [expr {$l-1}]]
8712 set n [lindex $ref 0]
8713 switch -- [lindex $ref 1] {
8714 "H" {selbyid $headids($n)}
8715 "T" {selbyid $tagids($n)}
8716 "o" {selbyid $otherrefids($n)}
8718 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8721 proc unsel_reflist {} {
8722 global showrefstop
8724 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8725 $showrefstop.list tag remove highlight 0.0 end
8728 proc reflistfilter_change {n1 n2 op} {
8729 global reflistfilter
8731 after cancel refill_reflist
8732 after 200 refill_reflist
8735 proc refill_reflist {} {
8736 global reflist reflistfilter showrefstop headids tagids otherrefids
8737 global curview
8739 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8740 set refs {}
8741 foreach n [array names headids] {
8742 if {[string match $reflistfilter $n]} {
8743 if {[commitinview $headids($n) $curview]} {
8744 lappend refs [list $n H]
8745 } else {
8746 interestedin $headids($n) {run refill_reflist}
8750 foreach n [array names tagids] {
8751 if {[string match $reflistfilter $n]} {
8752 if {[commitinview $tagids($n) $curview]} {
8753 lappend refs [list $n T]
8754 } else {
8755 interestedin $tagids($n) {run refill_reflist}
8759 foreach n [array names otherrefids] {
8760 if {[string match $reflistfilter $n]} {
8761 if {[commitinview $otherrefids($n) $curview]} {
8762 lappend refs [list $n o]
8763 } else {
8764 interestedin $otherrefids($n) {run refill_reflist}
8768 set refs [lsort -index 0 $refs]
8769 if {$refs eq $reflist} return
8771 # Update the contents of $showrefstop.list according to the
8772 # differences between $reflist (old) and $refs (new)
8773 $showrefstop.list conf -state normal
8774 $showrefstop.list insert end "\n"
8775 set i 0
8776 set j 0
8777 while {$i < [llength $reflist] || $j < [llength $refs]} {
8778 if {$i < [llength $reflist]} {
8779 if {$j < [llength $refs]} {
8780 set cmp [string compare [lindex $reflist $i 0] \
8781 [lindex $refs $j 0]]
8782 if {$cmp == 0} {
8783 set cmp [string compare [lindex $reflist $i 1] \
8784 [lindex $refs $j 1]]
8786 } else {
8787 set cmp -1
8789 } else {
8790 set cmp 1
8792 switch -- $cmp {
8793 -1 {
8794 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8795 incr i
8798 incr i
8799 incr j
8802 set l [expr {$j + 1}]
8803 $showrefstop.list image create $l.0 -align baseline \
8804 -image reficon-[lindex $refs $j 1] -padx 2
8805 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8806 incr j
8810 set reflist $refs
8811 # delete last newline
8812 $showrefstop.list delete end-2c end-1c
8813 $showrefstop.list conf -state disabled
8816 # Stuff for finding nearby tags
8817 proc getallcommits {} {
8818 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8819 global idheads idtags idotherrefs allparents tagobjid
8821 if {![info exists allcommits]} {
8822 set nextarc 0
8823 set allcommits 0
8824 set seeds {}
8825 set allcwait 0
8826 set cachedarcs 0
8827 set allccache [file join [gitdir] "gitk.cache"]
8828 if {![catch {
8829 set f [open $allccache r]
8830 set allcwait 1
8831 getcache $f
8832 }]} return
8835 if {$allcwait} {
8836 return
8838 set cmd [list | git rev-list --parents]
8839 set allcupdate [expr {$seeds ne {}}]
8840 if {!$allcupdate} {
8841 set ids "--all"
8842 } else {
8843 set refs [concat [array names idheads] [array names idtags] \
8844 [array names idotherrefs]]
8845 set ids {}
8846 set tagobjs {}
8847 foreach name [array names tagobjid] {
8848 lappend tagobjs $tagobjid($name)
8850 foreach id [lsort -unique $refs] {
8851 if {![info exists allparents($id)] &&
8852 [lsearch -exact $tagobjs $id] < 0} {
8853 lappend ids $id
8856 if {$ids ne {}} {
8857 foreach id $seeds {
8858 lappend ids "^$id"
8862 if {$ids ne {}} {
8863 set fd [open [concat $cmd $ids] r]
8864 fconfigure $fd -blocking 0
8865 incr allcommits
8866 nowbusy allcommits
8867 filerun $fd [list getallclines $fd]
8868 } else {
8869 dispneartags 0
8873 # Since most commits have 1 parent and 1 child, we group strings of
8874 # such commits into "arcs" joining branch/merge points (BMPs), which
8875 # are commits that either don't have 1 parent or don't have 1 child.
8877 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8878 # arcout(id) - outgoing arcs for BMP
8879 # arcids(a) - list of IDs on arc including end but not start
8880 # arcstart(a) - BMP ID at start of arc
8881 # arcend(a) - BMP ID at end of arc
8882 # growing(a) - arc a is still growing
8883 # arctags(a) - IDs out of arcids (excluding end) that have tags
8884 # archeads(a) - IDs out of arcids (excluding end) that have heads
8885 # The start of an arc is at the descendent end, so "incoming" means
8886 # coming from descendents, and "outgoing" means going towards ancestors.
8888 proc getallclines {fd} {
8889 global allparents allchildren idtags idheads nextarc
8890 global arcnos arcids arctags arcout arcend arcstart archeads growing
8891 global seeds allcommits cachedarcs allcupdate
8893 set nid 0
8894 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8895 set id [lindex $line 0]
8896 if {[info exists allparents($id)]} {
8897 # seen it already
8898 continue
8900 set cachedarcs 0
8901 set olds [lrange $line 1 end]
8902 set allparents($id) $olds
8903 if {![info exists allchildren($id)]} {
8904 set allchildren($id) {}
8905 set arcnos($id) {}
8906 lappend seeds $id
8907 } else {
8908 set a $arcnos($id)
8909 if {[llength $olds] == 1 && [llength $a] == 1} {
8910 lappend arcids($a) $id
8911 if {[info exists idtags($id)]} {
8912 lappend arctags($a) $id
8914 if {[info exists idheads($id)]} {
8915 lappend archeads($a) $id
8917 if {[info exists allparents($olds)]} {
8918 # seen parent already
8919 if {![info exists arcout($olds)]} {
8920 splitarc $olds
8922 lappend arcids($a) $olds
8923 set arcend($a) $olds
8924 unset growing($a)
8926 lappend allchildren($olds) $id
8927 lappend arcnos($olds) $a
8928 continue
8931 foreach a $arcnos($id) {
8932 lappend arcids($a) $id
8933 set arcend($a) $id
8934 unset growing($a)
8937 set ao {}
8938 foreach p $olds {
8939 lappend allchildren($p) $id
8940 set a [incr nextarc]
8941 set arcstart($a) $id
8942 set archeads($a) {}
8943 set arctags($a) {}
8944 set archeads($a) {}
8945 set arcids($a) {}
8946 lappend ao $a
8947 set growing($a) 1
8948 if {[info exists allparents($p)]} {
8949 # seen it already, may need to make a new branch
8950 if {![info exists arcout($p)]} {
8951 splitarc $p
8953 lappend arcids($a) $p
8954 set arcend($a) $p
8955 unset growing($a)
8957 lappend arcnos($p) $a
8959 set arcout($id) $ao
8961 if {$nid > 0} {
8962 global cached_dheads cached_dtags cached_atags
8963 catch {unset cached_dheads}
8964 catch {unset cached_dtags}
8965 catch {unset cached_atags}
8967 if {![eof $fd]} {
8968 return [expr {$nid >= 1000? 2: 1}]
8970 set cacheok 1
8971 if {[catch {
8972 fconfigure $fd -blocking 1
8973 close $fd
8974 } err]} {
8975 # got an error reading the list of commits
8976 # if we were updating, try rereading the whole thing again
8977 if {$allcupdate} {
8978 incr allcommits -1
8979 dropcache $err
8980 return
8982 error_popup "[mc "Error reading commit topology information;\
8983 branch and preceding/following tag information\
8984 will be incomplete."]\n($err)"
8985 set cacheok 0
8987 if {[incr allcommits -1] == 0} {
8988 notbusy allcommits
8989 if {$cacheok} {
8990 run savecache
8993 dispneartags 0
8994 return 0
8997 proc recalcarc {a} {
8998 global arctags archeads arcids idtags idheads
9000 set at {}
9001 set ah {}
9002 foreach id [lrange $arcids($a) 0 end-1] {
9003 if {[info exists idtags($id)]} {
9004 lappend at $id
9006 if {[info exists idheads($id)]} {
9007 lappend ah $id
9010 set arctags($a) $at
9011 set archeads($a) $ah
9014 proc splitarc {p} {
9015 global arcnos arcids nextarc arctags archeads idtags idheads
9016 global arcstart arcend arcout allparents growing
9018 set a $arcnos($p)
9019 if {[llength $a] != 1} {
9020 puts "oops splitarc called but [llength $a] arcs already"
9021 return
9023 set a [lindex $a 0]
9024 set i [lsearch -exact $arcids($a) $p]
9025 if {$i < 0} {
9026 puts "oops splitarc $p not in arc $a"
9027 return
9029 set na [incr nextarc]
9030 if {[info exists arcend($a)]} {
9031 set arcend($na) $arcend($a)
9032 } else {
9033 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9034 set j [lsearch -exact $arcnos($l) $a]
9035 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9037 set tail [lrange $arcids($a) [expr {$i+1}] end]
9038 set arcids($a) [lrange $arcids($a) 0 $i]
9039 set arcend($a) $p
9040 set arcstart($na) $p
9041 set arcout($p) $na
9042 set arcids($na) $tail
9043 if {[info exists growing($a)]} {
9044 set growing($na) 1
9045 unset growing($a)
9048 foreach id $tail {
9049 if {[llength $arcnos($id)] == 1} {
9050 set arcnos($id) $na
9051 } else {
9052 set j [lsearch -exact $arcnos($id) $a]
9053 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9057 # reconstruct tags and heads lists
9058 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9059 recalcarc $a
9060 recalcarc $na
9061 } else {
9062 set arctags($na) {}
9063 set archeads($na) {}
9067 # Update things for a new commit added that is a child of one
9068 # existing commit. Used when cherry-picking.
9069 proc addnewchild {id p} {
9070 global allparents allchildren idtags nextarc
9071 global arcnos arcids arctags arcout arcend arcstart archeads growing
9072 global seeds allcommits
9074 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9075 set allparents($id) [list $p]
9076 set allchildren($id) {}
9077 set arcnos($id) {}
9078 lappend seeds $id
9079 lappend allchildren($p) $id
9080 set a [incr nextarc]
9081 set arcstart($a) $id
9082 set archeads($a) {}
9083 set arctags($a) {}
9084 set arcids($a) [list $p]
9085 set arcend($a) $p
9086 if {![info exists arcout($p)]} {
9087 splitarc $p
9089 lappend arcnos($p) $a
9090 set arcout($id) [list $a]
9093 # This implements a cache for the topology information.
9094 # The cache saves, for each arc, the start and end of the arc,
9095 # the ids on the arc, and the outgoing arcs from the end.
9096 proc readcache {f} {
9097 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9098 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9099 global allcwait
9101 set a $nextarc
9102 set lim $cachedarcs
9103 if {$lim - $a > 500} {
9104 set lim [expr {$a + 500}]
9106 if {[catch {
9107 if {$a == $lim} {
9108 # finish reading the cache and setting up arctags, etc.
9109 set line [gets $f]
9110 if {$line ne "1"} {error "bad final version"}
9111 close $f
9112 foreach id [array names idtags] {
9113 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9114 [llength $allparents($id)] == 1} {
9115 set a [lindex $arcnos($id) 0]
9116 if {$arctags($a) eq {}} {
9117 recalcarc $a
9121 foreach id [array names idheads] {
9122 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9123 [llength $allparents($id)] == 1} {
9124 set a [lindex $arcnos($id) 0]
9125 if {$archeads($a) eq {}} {
9126 recalcarc $a
9130 foreach id [lsort -unique $possible_seeds] {
9131 if {$arcnos($id) eq {}} {
9132 lappend seeds $id
9135 set allcwait 0
9136 } else {
9137 while {[incr a] <= $lim} {
9138 set line [gets $f]
9139 if {[llength $line] != 3} {error "bad line"}
9140 set s [lindex $line 0]
9141 set arcstart($a) $s
9142 lappend arcout($s) $a
9143 if {![info exists arcnos($s)]} {
9144 lappend possible_seeds $s
9145 set arcnos($s) {}
9147 set e [lindex $line 1]
9148 if {$e eq {}} {
9149 set growing($a) 1
9150 } else {
9151 set arcend($a) $e
9152 if {![info exists arcout($e)]} {
9153 set arcout($e) {}
9156 set arcids($a) [lindex $line 2]
9157 foreach id $arcids($a) {
9158 lappend allparents($s) $id
9159 set s $id
9160 lappend arcnos($id) $a
9162 if {![info exists allparents($s)]} {
9163 set allparents($s) {}
9165 set arctags($a) {}
9166 set archeads($a) {}
9168 set nextarc [expr {$a - 1}]
9170 } err]} {
9171 dropcache $err
9172 return 0
9174 if {!$allcwait} {
9175 getallcommits
9177 return $allcwait
9180 proc getcache {f} {
9181 global nextarc cachedarcs possible_seeds
9183 if {[catch {
9184 set line [gets $f]
9185 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9186 # make sure it's an integer
9187 set cachedarcs [expr {int([lindex $line 1])}]
9188 if {$cachedarcs < 0} {error "bad number of arcs"}
9189 set nextarc 0
9190 set possible_seeds {}
9191 run readcache $f
9192 } err]} {
9193 dropcache $err
9195 return 0
9198 proc dropcache {err} {
9199 global allcwait nextarc cachedarcs seeds
9201 #puts "dropping cache ($err)"
9202 foreach v {arcnos arcout arcids arcstart arcend growing \
9203 arctags archeads allparents allchildren} {
9204 global $v
9205 catch {unset $v}
9207 set allcwait 0
9208 set nextarc 0
9209 set cachedarcs 0
9210 set seeds {}
9211 getallcommits
9214 proc writecache {f} {
9215 global cachearc cachedarcs allccache
9216 global arcstart arcend arcnos arcids arcout
9218 set a $cachearc
9219 set lim $cachedarcs
9220 if {$lim - $a > 1000} {
9221 set lim [expr {$a + 1000}]
9223 if {[catch {
9224 while {[incr a] <= $lim} {
9225 if {[info exists arcend($a)]} {
9226 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9227 } else {
9228 puts $f [list $arcstart($a) {} $arcids($a)]
9231 } err]} {
9232 catch {close $f}
9233 catch {file delete $allccache}
9234 #puts "writing cache failed ($err)"
9235 return 0
9237 set cachearc [expr {$a - 1}]
9238 if {$a > $cachedarcs} {
9239 puts $f "1"
9240 close $f
9241 return 0
9243 return 1
9246 proc savecache {} {
9247 global nextarc cachedarcs cachearc allccache
9249 if {$nextarc == $cachedarcs} return
9250 set cachearc 0
9251 set cachedarcs $nextarc
9252 catch {
9253 set f [open $allccache w]
9254 puts $f [list 1 $cachedarcs]
9255 run writecache $f
9259 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9260 # or 0 if neither is true.
9261 proc anc_or_desc {a b} {
9262 global arcout arcstart arcend arcnos cached_isanc
9264 if {$arcnos($a) eq $arcnos($b)} {
9265 # Both are on the same arc(s); either both are the same BMP,
9266 # or if one is not a BMP, the other is also not a BMP or is
9267 # the BMP at end of the arc (and it only has 1 incoming arc).
9268 # Or both can be BMPs with no incoming arcs.
9269 if {$a eq $b || $arcnos($a) eq {}} {
9270 return 0
9272 # assert {[llength $arcnos($a)] == 1}
9273 set arc [lindex $arcnos($a) 0]
9274 set i [lsearch -exact $arcids($arc) $a]
9275 set j [lsearch -exact $arcids($arc) $b]
9276 if {$i < 0 || $i > $j} {
9277 return 1
9278 } else {
9279 return -1
9283 if {![info exists arcout($a)]} {
9284 set arc [lindex $arcnos($a) 0]
9285 if {[info exists arcend($arc)]} {
9286 set aend $arcend($arc)
9287 } else {
9288 set aend {}
9290 set a $arcstart($arc)
9291 } else {
9292 set aend $a
9294 if {![info exists arcout($b)]} {
9295 set arc [lindex $arcnos($b) 0]
9296 if {[info exists arcend($arc)]} {
9297 set bend $arcend($arc)
9298 } else {
9299 set bend {}
9301 set b $arcstart($arc)
9302 } else {
9303 set bend $b
9305 if {$a eq $bend} {
9306 return 1
9308 if {$b eq $aend} {
9309 return -1
9311 if {[info exists cached_isanc($a,$bend)]} {
9312 if {$cached_isanc($a,$bend)} {
9313 return 1
9316 if {[info exists cached_isanc($b,$aend)]} {
9317 if {$cached_isanc($b,$aend)} {
9318 return -1
9320 if {[info exists cached_isanc($a,$bend)]} {
9321 return 0
9325 set todo [list $a $b]
9326 set anc($a) a
9327 set anc($b) b
9328 for {set i 0} {$i < [llength $todo]} {incr i} {
9329 set x [lindex $todo $i]
9330 if {$anc($x) eq {}} {
9331 continue
9333 foreach arc $arcnos($x) {
9334 set xd $arcstart($arc)
9335 if {$xd eq $bend} {
9336 set cached_isanc($a,$bend) 1
9337 set cached_isanc($b,$aend) 0
9338 return 1
9339 } elseif {$xd eq $aend} {
9340 set cached_isanc($b,$aend) 1
9341 set cached_isanc($a,$bend) 0
9342 return -1
9344 if {![info exists anc($xd)]} {
9345 set anc($xd) $anc($x)
9346 lappend todo $xd
9347 } elseif {$anc($xd) ne $anc($x)} {
9348 set anc($xd) {}
9352 set cached_isanc($a,$bend) 0
9353 set cached_isanc($b,$aend) 0
9354 return 0
9357 # This identifies whether $desc has an ancestor that is
9358 # a growing tip of the graph and which is not an ancestor of $anc
9359 # and returns 0 if so and 1 if not.
9360 # If we subsequently discover a tag on such a growing tip, and that
9361 # turns out to be a descendent of $anc (which it could, since we
9362 # don't necessarily see children before parents), then $desc
9363 # isn't a good choice to display as a descendent tag of
9364 # $anc (since it is the descendent of another tag which is
9365 # a descendent of $anc). Similarly, $anc isn't a good choice to
9366 # display as a ancestor tag of $desc.
9368 proc is_certain {desc anc} {
9369 global arcnos arcout arcstart arcend growing problems
9371 set certain {}
9372 if {[llength $arcnos($anc)] == 1} {
9373 # tags on the same arc are certain
9374 if {$arcnos($desc) eq $arcnos($anc)} {
9375 return 1
9377 if {![info exists arcout($anc)]} {
9378 # if $anc is partway along an arc, use the start of the arc instead
9379 set a [lindex $arcnos($anc) 0]
9380 set anc $arcstart($a)
9383 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9384 set x $desc
9385 } else {
9386 set a [lindex $arcnos($desc) 0]
9387 set x $arcend($a)
9389 if {$x == $anc} {
9390 return 1
9392 set anclist [list $x]
9393 set dl($x) 1
9394 set nnh 1
9395 set ngrowanc 0
9396 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9397 set x [lindex $anclist $i]
9398 if {$dl($x)} {
9399 incr nnh -1
9401 set done($x) 1
9402 foreach a $arcout($x) {
9403 if {[info exists growing($a)]} {
9404 if {![info exists growanc($x)] && $dl($x)} {
9405 set growanc($x) 1
9406 incr ngrowanc
9408 } else {
9409 set y $arcend($a)
9410 if {[info exists dl($y)]} {
9411 if {$dl($y)} {
9412 if {!$dl($x)} {
9413 set dl($y) 0
9414 if {![info exists done($y)]} {
9415 incr nnh -1
9417 if {[info exists growanc($x)]} {
9418 incr ngrowanc -1
9420 set xl [list $y]
9421 for {set k 0} {$k < [llength $xl]} {incr k} {
9422 set z [lindex $xl $k]
9423 foreach c $arcout($z) {
9424 if {[info exists arcend($c)]} {
9425 set v $arcend($c)
9426 if {[info exists dl($v)] && $dl($v)} {
9427 set dl($v) 0
9428 if {![info exists done($v)]} {
9429 incr nnh -1
9431 if {[info exists growanc($v)]} {
9432 incr ngrowanc -1
9434 lappend xl $v
9441 } elseif {$y eq $anc || !$dl($x)} {
9442 set dl($y) 0
9443 lappend anclist $y
9444 } else {
9445 set dl($y) 1
9446 lappend anclist $y
9447 incr nnh
9452 foreach x [array names growanc] {
9453 if {$dl($x)} {
9454 return 0
9456 return 0
9458 return 1
9461 proc validate_arctags {a} {
9462 global arctags idtags
9464 set i -1
9465 set na $arctags($a)
9466 foreach id $arctags($a) {
9467 incr i
9468 if {![info exists idtags($id)]} {
9469 set na [lreplace $na $i $i]
9470 incr i -1
9473 set arctags($a) $na
9476 proc validate_archeads {a} {
9477 global archeads idheads
9479 set i -1
9480 set na $archeads($a)
9481 foreach id $archeads($a) {
9482 incr i
9483 if {![info exists idheads($id)]} {
9484 set na [lreplace $na $i $i]
9485 incr i -1
9488 set archeads($a) $na
9491 # Return the list of IDs that have tags that are descendents of id,
9492 # ignoring IDs that are descendents of IDs already reported.
9493 proc desctags {id} {
9494 global arcnos arcstart arcids arctags idtags allparents
9495 global growing cached_dtags
9497 if {![info exists allparents($id)]} {
9498 return {}
9500 set t1 [clock clicks -milliseconds]
9501 set argid $id
9502 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9503 # part-way along an arc; check that arc first
9504 set a [lindex $arcnos($id) 0]
9505 if {$arctags($a) ne {}} {
9506 validate_arctags $a
9507 set i [lsearch -exact $arcids($a) $id]
9508 set tid {}
9509 foreach t $arctags($a) {
9510 set j [lsearch -exact $arcids($a) $t]
9511 if {$j >= $i} break
9512 set tid $t
9514 if {$tid ne {}} {
9515 return $tid
9518 set id $arcstart($a)
9519 if {[info exists idtags($id)]} {
9520 return $id
9523 if {[info exists cached_dtags($id)]} {
9524 return $cached_dtags($id)
9527 set origid $id
9528 set todo [list $id]
9529 set queued($id) 1
9530 set nc 1
9531 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9532 set id [lindex $todo $i]
9533 set done($id) 1
9534 set ta [info exists hastaggedancestor($id)]
9535 if {!$ta} {
9536 incr nc -1
9538 # ignore tags on starting node
9539 if {!$ta && $i > 0} {
9540 if {[info exists idtags($id)]} {
9541 set tagloc($id) $id
9542 set ta 1
9543 } elseif {[info exists cached_dtags($id)]} {
9544 set tagloc($id) $cached_dtags($id)
9545 set ta 1
9548 foreach a $arcnos($id) {
9549 set d $arcstart($a)
9550 if {!$ta && $arctags($a) ne {}} {
9551 validate_arctags $a
9552 if {$arctags($a) ne {}} {
9553 lappend tagloc($id) [lindex $arctags($a) end]
9556 if {$ta || $arctags($a) ne {}} {
9557 set tomark [list $d]
9558 for {set j 0} {$j < [llength $tomark]} {incr j} {
9559 set dd [lindex $tomark $j]
9560 if {![info exists hastaggedancestor($dd)]} {
9561 if {[info exists done($dd)]} {
9562 foreach b $arcnos($dd) {
9563 lappend tomark $arcstart($b)
9565 if {[info exists tagloc($dd)]} {
9566 unset tagloc($dd)
9568 } elseif {[info exists queued($dd)]} {
9569 incr nc -1
9571 set hastaggedancestor($dd) 1
9575 if {![info exists queued($d)]} {
9576 lappend todo $d
9577 set queued($d) 1
9578 if {![info exists hastaggedancestor($d)]} {
9579 incr nc
9584 set tags {}
9585 foreach id [array names tagloc] {
9586 if {![info exists hastaggedancestor($id)]} {
9587 foreach t $tagloc($id) {
9588 if {[lsearch -exact $tags $t] < 0} {
9589 lappend tags $t
9594 set t2 [clock clicks -milliseconds]
9595 set loopix $i
9597 # remove tags that are descendents of other tags
9598 for {set i 0} {$i < [llength $tags]} {incr i} {
9599 set a [lindex $tags $i]
9600 for {set j 0} {$j < $i} {incr j} {
9601 set b [lindex $tags $j]
9602 set r [anc_or_desc $a $b]
9603 if {$r == 1} {
9604 set tags [lreplace $tags $j $j]
9605 incr j -1
9606 incr i -1
9607 } elseif {$r == -1} {
9608 set tags [lreplace $tags $i $i]
9609 incr i -1
9610 break
9615 if {[array names growing] ne {}} {
9616 # graph isn't finished, need to check if any tag could get
9617 # eclipsed by another tag coming later. Simply ignore any
9618 # tags that could later get eclipsed.
9619 set ctags {}
9620 foreach t $tags {
9621 if {[is_certain $t $origid]} {
9622 lappend ctags $t
9625 if {$tags eq $ctags} {
9626 set cached_dtags($origid) $tags
9627 } else {
9628 set tags $ctags
9630 } else {
9631 set cached_dtags($origid) $tags
9633 set t3 [clock clicks -milliseconds]
9634 if {0 && $t3 - $t1 >= 100} {
9635 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9636 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9638 return $tags
9641 proc anctags {id} {
9642 global arcnos arcids arcout arcend arctags idtags allparents
9643 global growing cached_atags
9645 if {![info exists allparents($id)]} {
9646 return {}
9648 set t1 [clock clicks -milliseconds]
9649 set argid $id
9650 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9651 # part-way along an arc; check that arc first
9652 set a [lindex $arcnos($id) 0]
9653 if {$arctags($a) ne {}} {
9654 validate_arctags $a
9655 set i [lsearch -exact $arcids($a) $id]
9656 foreach t $arctags($a) {
9657 set j [lsearch -exact $arcids($a) $t]
9658 if {$j > $i} {
9659 return $t
9663 if {![info exists arcend($a)]} {
9664 return {}
9666 set id $arcend($a)
9667 if {[info exists idtags($id)]} {
9668 return $id
9671 if {[info exists cached_atags($id)]} {
9672 return $cached_atags($id)
9675 set origid $id
9676 set todo [list $id]
9677 set queued($id) 1
9678 set taglist {}
9679 set nc 1
9680 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9681 set id [lindex $todo $i]
9682 set done($id) 1
9683 set td [info exists hastaggeddescendent($id)]
9684 if {!$td} {
9685 incr nc -1
9687 # ignore tags on starting node
9688 if {!$td && $i > 0} {
9689 if {[info exists idtags($id)]} {
9690 set tagloc($id) $id
9691 set td 1
9692 } elseif {[info exists cached_atags($id)]} {
9693 set tagloc($id) $cached_atags($id)
9694 set td 1
9697 foreach a $arcout($id) {
9698 if {!$td && $arctags($a) ne {}} {
9699 validate_arctags $a
9700 if {$arctags($a) ne {}} {
9701 lappend tagloc($id) [lindex $arctags($a) 0]
9704 if {![info exists arcend($a)]} continue
9705 set d $arcend($a)
9706 if {$td || $arctags($a) ne {}} {
9707 set tomark [list $d]
9708 for {set j 0} {$j < [llength $tomark]} {incr j} {
9709 set dd [lindex $tomark $j]
9710 if {![info exists hastaggeddescendent($dd)]} {
9711 if {[info exists done($dd)]} {
9712 foreach b $arcout($dd) {
9713 if {[info exists arcend($b)]} {
9714 lappend tomark $arcend($b)
9717 if {[info exists tagloc($dd)]} {
9718 unset tagloc($dd)
9720 } elseif {[info exists queued($dd)]} {
9721 incr nc -1
9723 set hastaggeddescendent($dd) 1
9727 if {![info exists queued($d)]} {
9728 lappend todo $d
9729 set queued($d) 1
9730 if {![info exists hastaggeddescendent($d)]} {
9731 incr nc
9736 set t2 [clock clicks -milliseconds]
9737 set loopix $i
9738 set tags {}
9739 foreach id [array names tagloc] {
9740 if {![info exists hastaggeddescendent($id)]} {
9741 foreach t $tagloc($id) {
9742 if {[lsearch -exact $tags $t] < 0} {
9743 lappend tags $t
9749 # remove tags that are ancestors of other tags
9750 for {set i 0} {$i < [llength $tags]} {incr i} {
9751 set a [lindex $tags $i]
9752 for {set j 0} {$j < $i} {incr j} {
9753 set b [lindex $tags $j]
9754 set r [anc_or_desc $a $b]
9755 if {$r == -1} {
9756 set tags [lreplace $tags $j $j]
9757 incr j -1
9758 incr i -1
9759 } elseif {$r == 1} {
9760 set tags [lreplace $tags $i $i]
9761 incr i -1
9762 break
9767 if {[array names growing] ne {}} {
9768 # graph isn't finished, need to check if any tag could get
9769 # eclipsed by another tag coming later. Simply ignore any
9770 # tags that could later get eclipsed.
9771 set ctags {}
9772 foreach t $tags {
9773 if {[is_certain $origid $t]} {
9774 lappend ctags $t
9777 if {$tags eq $ctags} {
9778 set cached_atags($origid) $tags
9779 } else {
9780 set tags $ctags
9782 } else {
9783 set cached_atags($origid) $tags
9785 set t3 [clock clicks -milliseconds]
9786 if {0 && $t3 - $t1 >= 100} {
9787 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9788 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9790 return $tags
9793 # Return the list of IDs that have heads that are descendents of id,
9794 # including id itself if it has a head.
9795 proc descheads {id} {
9796 global arcnos arcstart arcids archeads idheads cached_dheads
9797 global allparents
9799 if {![info exists allparents($id)]} {
9800 return {}
9802 set aret {}
9803 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9804 # part-way along an arc; check it first
9805 set a [lindex $arcnos($id) 0]
9806 if {$archeads($a) ne {}} {
9807 validate_archeads $a
9808 set i [lsearch -exact $arcids($a) $id]
9809 foreach t $archeads($a) {
9810 set j [lsearch -exact $arcids($a) $t]
9811 if {$j > $i} break
9812 lappend aret $t
9815 set id $arcstart($a)
9817 set origid $id
9818 set todo [list $id]
9819 set seen($id) 1
9820 set ret {}
9821 for {set i 0} {$i < [llength $todo]} {incr i} {
9822 set id [lindex $todo $i]
9823 if {[info exists cached_dheads($id)]} {
9824 set ret [concat $ret $cached_dheads($id)]
9825 } else {
9826 if {[info exists idheads($id)]} {
9827 lappend ret $id
9829 foreach a $arcnos($id) {
9830 if {$archeads($a) ne {}} {
9831 validate_archeads $a
9832 if {$archeads($a) ne {}} {
9833 set ret [concat $ret $archeads($a)]
9836 set d $arcstart($a)
9837 if {![info exists seen($d)]} {
9838 lappend todo $d
9839 set seen($d) 1
9844 set ret [lsort -unique $ret]
9845 set cached_dheads($origid) $ret
9846 return [concat $ret $aret]
9849 proc addedtag {id} {
9850 global arcnos arcout cached_dtags cached_atags
9852 if {![info exists arcnos($id)]} return
9853 if {![info exists arcout($id)]} {
9854 recalcarc [lindex $arcnos($id) 0]
9856 catch {unset cached_dtags}
9857 catch {unset cached_atags}
9860 proc addedhead {hid head} {
9861 global arcnos arcout cached_dheads
9863 if {![info exists arcnos($hid)]} return
9864 if {![info exists arcout($hid)]} {
9865 recalcarc [lindex $arcnos($hid) 0]
9867 catch {unset cached_dheads}
9870 proc removedhead {hid head} {
9871 global cached_dheads
9873 catch {unset cached_dheads}
9876 proc movedhead {hid head} {
9877 global arcnos arcout cached_dheads
9879 if {![info exists arcnos($hid)]} return
9880 if {![info exists arcout($hid)]} {
9881 recalcarc [lindex $arcnos($hid) 0]
9883 catch {unset cached_dheads}
9886 proc changedrefs {} {
9887 global cached_dheads cached_dtags cached_atags
9888 global arctags archeads arcnos arcout idheads idtags
9890 foreach id [concat [array names idheads] [array names idtags]] {
9891 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9892 set a [lindex $arcnos($id) 0]
9893 if {![info exists donearc($a)]} {
9894 recalcarc $a
9895 set donearc($a) 1
9899 catch {unset cached_dtags}
9900 catch {unset cached_atags}
9901 catch {unset cached_dheads}
9904 proc rereadrefs {} {
9905 global idtags idheads idotherrefs mainheadid
9907 set refids [concat [array names idtags] \
9908 [array names idheads] [array names idotherrefs]]
9909 foreach id $refids {
9910 if {![info exists ref($id)]} {
9911 set ref($id) [listrefs $id]
9914 set oldmainhead $mainheadid
9915 readrefs
9916 changedrefs
9917 set refids [lsort -unique [concat $refids [array names idtags] \
9918 [array names idheads] [array names idotherrefs]]]
9919 foreach id $refids {
9920 set v [listrefs $id]
9921 if {![info exists ref($id)] || $ref($id) != $v} {
9922 redrawtags $id
9925 if {$oldmainhead ne $mainheadid} {
9926 redrawtags $oldmainhead
9927 redrawtags $mainheadid
9929 run refill_reflist
9932 proc listrefs {id} {
9933 global idtags idheads idotherrefs
9935 set x {}
9936 if {[info exists idtags($id)]} {
9937 set x $idtags($id)
9939 set y {}
9940 if {[info exists idheads($id)]} {
9941 set y $idheads($id)
9943 set z {}
9944 if {[info exists idotherrefs($id)]} {
9945 set z $idotherrefs($id)
9947 return [list $x $y $z]
9950 proc showtag {tag isnew} {
9951 global ctext tagcontents tagids linknum tagobjid
9953 if {$isnew} {
9954 addtohistory [list showtag $tag 0] savectextpos
9956 $ctext conf -state normal
9957 clear_ctext
9958 settabs 0
9959 set linknum 0
9960 if {![info exists tagcontents($tag)]} {
9961 catch {
9962 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9965 if {[info exists tagcontents($tag)]} {
9966 set text $tagcontents($tag)
9967 } else {
9968 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9970 appendwithlinks $text {}
9971 maybe_scroll_ctext
9972 $ctext conf -state disabled
9973 init_flist {}
9976 proc doquit {} {
9977 global stopped
9978 global gitktmpdir
9980 set stopped 100
9981 savestuff .
9982 destroy .
9984 if {[info exists gitktmpdir]} {
9985 catch {file delete -force $gitktmpdir}
9989 proc mkfontdisp {font top which} {
9990 global fontattr fontpref $font
9992 set fontpref($font) [set $font]
9993 button $top.${font}but -text $which -font optionfont \
9994 -command [list choosefont $font $which]
9995 label $top.$font -relief flat -font $font \
9996 -text $fontattr($font,family) -justify left
9997 grid x $top.${font}but $top.$font -sticky w
10000 proc choosefont {font which} {
10001 global fontparam fontlist fonttop fontattr
10002 global prefstop
10004 set fontparam(which) $which
10005 set fontparam(font) $font
10006 set fontparam(family) [font actual $font -family]
10007 set fontparam(size) $fontattr($font,size)
10008 set fontparam(weight) $fontattr($font,weight)
10009 set fontparam(slant) $fontattr($font,slant)
10010 set top .gitkfont
10011 set fonttop $top
10012 if {![winfo exists $top]} {
10013 font create sample
10014 eval font config sample [font actual $font]
10015 toplevel $top
10016 make_transient $top $prefstop
10017 wm title $top [mc "Gitk font chooser"]
10018 label $top.l -textvariable fontparam(which)
10019 pack $top.l -side top
10020 set fontlist [lsort [font families]]
10021 frame $top.f
10022 listbox $top.f.fam -listvariable fontlist \
10023 -yscrollcommand [list $top.f.sb set]
10024 bind $top.f.fam <<ListboxSelect>> selfontfam
10025 scrollbar $top.f.sb -command [list $top.f.fam yview]
10026 pack $top.f.sb -side right -fill y
10027 pack $top.f.fam -side left -fill both -expand 1
10028 pack $top.f -side top -fill both -expand 1
10029 frame $top.g
10030 spinbox $top.g.size -from 4 -to 40 -width 4 \
10031 -textvariable fontparam(size) \
10032 -validatecommand {string is integer -strict %s}
10033 checkbutton $top.g.bold -padx 5 \
10034 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10035 -variable fontparam(weight) -onvalue bold -offvalue normal
10036 checkbutton $top.g.ital -padx 5 \
10037 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10038 -variable fontparam(slant) -onvalue italic -offvalue roman
10039 pack $top.g.size $top.g.bold $top.g.ital -side left
10040 pack $top.g -side top
10041 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10042 -background white
10043 $top.c create text 100 25 -anchor center -text $which -font sample \
10044 -fill black -tags text
10045 bind $top.c <Configure> [list centertext $top.c]
10046 pack $top.c -side top -fill x
10047 frame $top.buts
10048 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10049 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10050 bind $top <Key-Return> fontok
10051 bind $top <Key-Escape> fontcan
10052 grid $top.buts.ok $top.buts.can
10053 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10054 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10055 pack $top.buts -side bottom -fill x
10056 trace add variable fontparam write chg_fontparam
10057 } else {
10058 raise $top
10059 $top.c itemconf text -text $which
10061 set i [lsearch -exact $fontlist $fontparam(family)]
10062 if {$i >= 0} {
10063 $top.f.fam selection set $i
10064 $top.f.fam see $i
10068 proc centertext {w} {
10069 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10072 proc fontok {} {
10073 global fontparam fontpref prefstop
10075 set f $fontparam(font)
10076 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10077 if {$fontparam(weight) eq "bold"} {
10078 lappend fontpref($f) "bold"
10080 if {$fontparam(slant) eq "italic"} {
10081 lappend fontpref($f) "italic"
10083 set w $prefstop.$f
10084 $w conf -text $fontparam(family) -font $fontpref($f)
10086 fontcan
10089 proc fontcan {} {
10090 global fonttop fontparam
10092 if {[info exists fonttop]} {
10093 catch {destroy $fonttop}
10094 catch {font delete sample}
10095 unset fonttop
10096 unset fontparam
10100 proc selfontfam {} {
10101 global fonttop fontparam
10103 set i [$fonttop.f.fam curselection]
10104 if {$i ne {}} {
10105 set fontparam(family) [$fonttop.f.fam get $i]
10109 proc chg_fontparam {v sub op} {
10110 global fontparam
10112 font config sample -$sub $fontparam($sub)
10115 proc doprefs {} {
10116 global maxwidth maxgraphpct
10117 global oldprefs prefstop showneartags showlocalchanges
10118 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10119 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10121 set top .gitkprefs
10122 set prefstop $top
10123 if {[winfo exists $top]} {
10124 raise $top
10125 return
10127 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10128 limitdiffs tabstop perfile_attrs} {
10129 set oldprefs($v) [set $v]
10131 toplevel $top
10132 wm title $top [mc "Gitk preferences"]
10133 make_transient $top .
10134 label $top.ldisp -text [mc "Commit list display options"]
10135 grid $top.ldisp - -sticky w -pady 10
10136 label $top.spacer -text " "
10137 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10138 -font optionfont
10139 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10140 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10141 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10142 -font optionfont
10143 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10144 grid x $top.maxpctl $top.maxpct -sticky w
10145 frame $top.showlocal
10146 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
10147 checkbutton $top.showlocal.b -variable showlocalchanges
10148 pack $top.showlocal.b $top.showlocal.l -side left
10149 grid x $top.showlocal -sticky w
10150 frame $top.autoselect
10151 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
10152 checkbutton $top.autoselect.b -variable autoselect
10153 pack $top.autoselect.b $top.autoselect.l -side left
10154 grid x $top.autoselect -sticky w
10156 label $top.ddisp -text [mc "Diff display options"]
10157 grid $top.ddisp - -sticky w -pady 10
10158 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10159 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10160 grid x $top.tabstopl $top.tabstop -sticky w
10161 frame $top.ntag
10162 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
10163 checkbutton $top.ntag.b -variable showneartags
10164 pack $top.ntag.b $top.ntag.l -side left
10165 grid x $top.ntag -sticky w
10166 frame $top.ldiff
10167 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
10168 checkbutton $top.ldiff.b -variable limitdiffs
10169 pack $top.ldiff.b $top.ldiff.l -side left
10170 grid x $top.ldiff -sticky w
10171 frame $top.lattr
10172 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
10173 checkbutton $top.lattr.b -variable perfile_attrs
10174 pack $top.lattr.b $top.lattr.l -side left
10175 grid x $top.lattr -sticky w
10177 entry $top.extdifft -textvariable extdifftool
10178 frame $top.extdifff
10179 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10180 -padx 10
10181 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10182 -command choose_extdiff
10183 pack $top.extdifff.l $top.extdifff.b -side left
10184 grid x $top.extdifff $top.extdifft -sticky w
10186 label $top.cdisp -text [mc "Colors: press to choose"]
10187 grid $top.cdisp - -sticky w -pady 10
10188 label $top.bg -padx 40 -relief sunk -background $bgcolor
10189 button $top.bgbut -text [mc "Background"] -font optionfont \
10190 -command [list choosecolor bgcolor {} $top.bg background setbg]
10191 grid x $top.bgbut $top.bg -sticky w
10192 label $top.fg -padx 40 -relief sunk -background $fgcolor
10193 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10194 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10195 grid x $top.fgbut $top.fg -sticky w
10196 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10197 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10198 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10199 [list $ctext tag conf d0 -foreground]]
10200 grid x $top.diffoldbut $top.diffold -sticky w
10201 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10202 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10203 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10204 [list $ctext tag conf dresult -foreground]]
10205 grid x $top.diffnewbut $top.diffnew -sticky w
10206 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10207 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10208 -command [list choosecolor diffcolors 2 $top.hunksep \
10209 "diff hunk header" \
10210 [list $ctext tag conf hunksep -foreground]]
10211 grid x $top.hunksepbut $top.hunksep -sticky w
10212 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10213 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10214 -command [list choosecolor markbgcolor {} $top.markbgsep \
10215 [mc "marked line background"] \
10216 [list $ctext tag conf omark -background]]
10217 grid x $top.markbgbut $top.markbgsep -sticky w
10218 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10219 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10220 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10221 grid x $top.selbgbut $top.selbgsep -sticky w
10223 label $top.cfont -text [mc "Fonts: press to choose"]
10224 grid $top.cfont - -sticky w -pady 10
10225 mkfontdisp mainfont $top [mc "Main font"]
10226 mkfontdisp textfont $top [mc "Diff display font"]
10227 mkfontdisp uifont $top [mc "User interface font"]
10229 frame $top.buts
10230 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10231 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10232 bind $top <Key-Return> prefsok
10233 bind $top <Key-Escape> prefscan
10234 grid $top.buts.ok $top.buts.can
10235 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10236 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10237 grid $top.buts - - -pady 10 -sticky ew
10238 bind $top <Visibility> "focus $top.buts.ok"
10241 proc choose_extdiff {} {
10242 global extdifftool
10244 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10245 if {$prog ne {}} {
10246 set extdifftool $prog
10250 proc choosecolor {v vi w x cmd} {
10251 global $v
10253 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10254 -title [mc "Gitk: choose color for %s" $x]]
10255 if {$c eq {}} return
10256 $w conf -background $c
10257 lset $v $vi $c
10258 eval $cmd $c
10261 proc setselbg {c} {
10262 global bglist cflist
10263 foreach w $bglist {
10264 $w configure -selectbackground $c
10266 $cflist tag configure highlight \
10267 -background [$cflist cget -selectbackground]
10268 allcanvs itemconf secsel -fill $c
10271 proc setbg {c} {
10272 global bglist
10274 foreach w $bglist {
10275 $w conf -background $c
10279 proc setfg {c} {
10280 global fglist canv
10282 foreach w $fglist {
10283 $w conf -foreground $c
10285 allcanvs itemconf text -fill $c
10286 $canv itemconf circle -outline $c
10289 proc prefscan {} {
10290 global oldprefs prefstop
10292 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10293 limitdiffs tabstop perfile_attrs} {
10294 global $v
10295 set $v $oldprefs($v)
10297 catch {destroy $prefstop}
10298 unset prefstop
10299 fontcan
10302 proc prefsok {} {
10303 global maxwidth maxgraphpct
10304 global oldprefs prefstop showneartags showlocalchanges
10305 global fontpref mainfont textfont uifont
10306 global limitdiffs treediffs perfile_attrs
10308 catch {destroy $prefstop}
10309 unset prefstop
10310 fontcan
10311 set fontchanged 0
10312 if {$mainfont ne $fontpref(mainfont)} {
10313 set mainfont $fontpref(mainfont)
10314 parsefont mainfont $mainfont
10315 eval font configure mainfont [fontflags mainfont]
10316 eval font configure mainfontbold [fontflags mainfont 1]
10317 setcoords
10318 set fontchanged 1
10320 if {$textfont ne $fontpref(textfont)} {
10321 set textfont $fontpref(textfont)
10322 parsefont textfont $textfont
10323 eval font configure textfont [fontflags textfont]
10324 eval font configure textfontbold [fontflags textfont 1]
10326 if {$uifont ne $fontpref(uifont)} {
10327 set uifont $fontpref(uifont)
10328 parsefont uifont $uifont
10329 eval font configure uifont [fontflags uifont]
10331 settabs
10332 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10333 if {$showlocalchanges} {
10334 doshowlocalchanges
10335 } else {
10336 dohidelocalchanges
10339 if {$limitdiffs != $oldprefs(limitdiffs) ||
10340 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10341 # treediffs elements are limited by path;
10342 # won't have encodings cached if perfile_attrs was just turned on
10343 catch {unset treediffs}
10345 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10346 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10347 redisplay
10348 } elseif {$showneartags != $oldprefs(showneartags) ||
10349 $limitdiffs != $oldprefs(limitdiffs)} {
10350 reselectline
10354 proc formatdate {d} {
10355 global datetimeformat
10356 if {$d ne {}} {
10357 set d [clock format $d -format $datetimeformat]
10359 return $d
10362 # This list of encoding names and aliases is distilled from
10363 # http://www.iana.org/assignments/character-sets.
10364 # Not all of them are supported by Tcl.
10365 set encoding_aliases {
10366 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10367 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10368 { ISO-10646-UTF-1 csISO10646UTF1 }
10369 { ISO_646.basic:1983 ref csISO646basic1983 }
10370 { INVARIANT csINVARIANT }
10371 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10372 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10373 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10374 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10375 { NATS-DANO iso-ir-9-1 csNATSDANO }
10376 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10377 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10378 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10379 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10380 { ISO-2022-KR csISO2022KR }
10381 { EUC-KR csEUCKR }
10382 { ISO-2022-JP csISO2022JP }
10383 { ISO-2022-JP-2 csISO2022JP2 }
10384 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10385 csISO13JISC6220jp }
10386 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10387 { IT iso-ir-15 ISO646-IT csISO15Italian }
10388 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10389 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10390 { greek7-old iso-ir-18 csISO18Greek7Old }
10391 { latin-greek iso-ir-19 csISO19LatinGreek }
10392 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10393 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10394 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10395 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10396 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10397 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10398 { INIS iso-ir-49 csISO49INIS }
10399 { INIS-8 iso-ir-50 csISO50INIS8 }
10400 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10401 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10402 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10403 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10404 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10405 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10406 csISO60Norwegian1 }
10407 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10408 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10409 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10410 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10411 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10412 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10413 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10414 { greek7 iso-ir-88 csISO88Greek7 }
10415 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10416 { iso-ir-90 csISO90 }
10417 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10418 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10419 csISO92JISC62991984b }
10420 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10421 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10422 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10423 csISO95JIS62291984handadd }
10424 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10425 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10426 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10427 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10428 CP819 csISOLatin1 }
10429 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10430 { T.61-7bit iso-ir-102 csISO102T617bit }
10431 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10432 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10433 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10434 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10435 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10436 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10437 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10438 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10439 arabic csISOLatinArabic }
10440 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10441 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10442 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10443 greek greek8 csISOLatinGreek }
10444 { T.101-G2 iso-ir-128 csISO128T101G2 }
10445 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10446 csISOLatinHebrew }
10447 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10448 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10449 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10450 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10451 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10452 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10453 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10454 csISOLatinCyrillic }
10455 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10456 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10457 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10458 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10459 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10460 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10461 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10462 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10463 { ISO_10367-box iso-ir-155 csISO10367Box }
10464 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10465 { latin-lap lap iso-ir-158 csISO158Lap }
10466 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10467 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10468 { us-dk csUSDK }
10469 { dk-us csDKUS }
10470 { JIS_X0201 X0201 csHalfWidthKatakana }
10471 { KSC5636 ISO646-KR csKSC5636 }
10472 { ISO-10646-UCS-2 csUnicode }
10473 { ISO-10646-UCS-4 csUCS4 }
10474 { DEC-MCS dec csDECMCS }
10475 { hp-roman8 roman8 r8 csHPRoman8 }
10476 { macintosh mac csMacintosh }
10477 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10478 csIBM037 }
10479 { IBM038 EBCDIC-INT cp038 csIBM038 }
10480 { IBM273 CP273 csIBM273 }
10481 { IBM274 EBCDIC-BE CP274 csIBM274 }
10482 { IBM275 EBCDIC-BR cp275 csIBM275 }
10483 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10484 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10485 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10486 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10487 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10488 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10489 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10490 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10491 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10492 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10493 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10494 { IBM437 cp437 437 csPC8CodePage437 }
10495 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10496 { IBM775 cp775 csPC775Baltic }
10497 { IBM850 cp850 850 csPC850Multilingual }
10498 { IBM851 cp851 851 csIBM851 }
10499 { IBM852 cp852 852 csPCp852 }
10500 { IBM855 cp855 855 csIBM855 }
10501 { IBM857 cp857 857 csIBM857 }
10502 { IBM860 cp860 860 csIBM860 }
10503 { IBM861 cp861 861 cp-is csIBM861 }
10504 { IBM862 cp862 862 csPC862LatinHebrew }
10505 { IBM863 cp863 863 csIBM863 }
10506 { IBM864 cp864 csIBM864 }
10507 { IBM865 cp865 865 csIBM865 }
10508 { IBM866 cp866 866 csIBM866 }
10509 { IBM868 CP868 cp-ar csIBM868 }
10510 { IBM869 cp869 869 cp-gr csIBM869 }
10511 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10512 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10513 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10514 { IBM891 cp891 csIBM891 }
10515 { IBM903 cp903 csIBM903 }
10516 { IBM904 cp904 904 csIBBM904 }
10517 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10518 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10519 { IBM1026 CP1026 csIBM1026 }
10520 { EBCDIC-AT-DE csIBMEBCDICATDE }
10521 { EBCDIC-AT-DE-A csEBCDICATDEA }
10522 { EBCDIC-CA-FR csEBCDICCAFR }
10523 { EBCDIC-DK-NO csEBCDICDKNO }
10524 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10525 { EBCDIC-FI-SE csEBCDICFISE }
10526 { EBCDIC-FI-SE-A csEBCDICFISEA }
10527 { EBCDIC-FR csEBCDICFR }
10528 { EBCDIC-IT csEBCDICIT }
10529 { EBCDIC-PT csEBCDICPT }
10530 { EBCDIC-ES csEBCDICES }
10531 { EBCDIC-ES-A csEBCDICESA }
10532 { EBCDIC-ES-S csEBCDICESS }
10533 { EBCDIC-UK csEBCDICUK }
10534 { EBCDIC-US csEBCDICUS }
10535 { UNKNOWN-8BIT csUnknown8BiT }
10536 { MNEMONIC csMnemonic }
10537 { MNEM csMnem }
10538 { VISCII csVISCII }
10539 { VIQR csVIQR }
10540 { KOI8-R csKOI8R }
10541 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10542 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10543 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10544 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10545 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10546 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10547 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10548 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10549 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10550 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10551 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10552 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10553 { IBM1047 IBM-1047 }
10554 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10555 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10556 { UNICODE-1-1 csUnicode11 }
10557 { CESU-8 csCESU-8 }
10558 { BOCU-1 csBOCU-1 }
10559 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10560 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10561 l8 }
10562 { ISO-8859-15 ISO_8859-15 Latin-9 }
10563 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10564 { GBK CP936 MS936 windows-936 }
10565 { JIS_Encoding csJISEncoding }
10566 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10567 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10568 EUC-JP }
10569 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10570 { ISO-10646-UCS-Basic csUnicodeASCII }
10571 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10572 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10573 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10574 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10575 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10576 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10577 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10578 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10579 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10580 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10581 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10582 { Ventura-US csVenturaUS }
10583 { Ventura-International csVenturaInternational }
10584 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10585 { PC8-Turkish csPC8Turkish }
10586 { IBM-Symbols csIBMSymbols }
10587 { IBM-Thai csIBMThai }
10588 { HP-Legal csHPLegal }
10589 { HP-Pi-font csHPPiFont }
10590 { HP-Math8 csHPMath8 }
10591 { Adobe-Symbol-Encoding csHPPSMath }
10592 { HP-DeskTop csHPDesktop }
10593 { Ventura-Math csVenturaMath }
10594 { Microsoft-Publishing csMicrosoftPublishing }
10595 { Windows-31J csWindows31J }
10596 { GB2312 csGB2312 }
10597 { Big5 csBig5 }
10600 proc tcl_encoding {enc} {
10601 global encoding_aliases tcl_encoding_cache
10602 if {[info exists tcl_encoding_cache($enc)]} {
10603 return $tcl_encoding_cache($enc)
10605 set names [encoding names]
10606 set lcnames [string tolower $names]
10607 set enc [string tolower $enc]
10608 set i [lsearch -exact $lcnames $enc]
10609 if {$i < 0} {
10610 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10611 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10612 set i [lsearch -exact $lcnames $encx]
10615 if {$i < 0} {
10616 foreach l $encoding_aliases {
10617 set ll [string tolower $l]
10618 if {[lsearch -exact $ll $enc] < 0} continue
10619 # look through the aliases for one that tcl knows about
10620 foreach e $ll {
10621 set i [lsearch -exact $lcnames $e]
10622 if {$i < 0} {
10623 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10624 set i [lsearch -exact $lcnames $ex]
10627 if {$i >= 0} break
10629 break
10632 set tclenc {}
10633 if {$i >= 0} {
10634 set tclenc [lindex $names $i]
10636 set tcl_encoding_cache($enc) $tclenc
10637 return $tclenc
10640 proc gitattr {path attr default} {
10641 global path_attr_cache
10642 if {[info exists path_attr_cache($attr,$path)]} {
10643 set r $path_attr_cache($attr,$path)
10644 } else {
10645 set r "unspecified"
10646 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10647 regexp "(.*): encoding: (.*)" $line m f r
10649 set path_attr_cache($attr,$path) $r
10651 if {$r eq "unspecified"} {
10652 return $default
10654 return $r
10657 proc cache_gitattr {attr pathlist} {
10658 global path_attr_cache
10659 set newlist {}
10660 foreach path $pathlist {
10661 if {![info exists path_attr_cache($attr,$path)]} {
10662 lappend newlist $path
10665 set lim 1000
10666 if {[tk windowingsystem] == "win32"} {
10667 # windows has a 32k limit on the arguments to a command...
10668 set lim 30
10670 while {$newlist ne {}} {
10671 set head [lrange $newlist 0 [expr {$lim - 1}]]
10672 set newlist [lrange $newlist $lim end]
10673 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10674 foreach row [split $rlist "\n"] {
10675 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10676 if {[string index $path 0] eq "\""} {
10677 set path [encoding convertfrom [lindex $path 0]]
10679 set path_attr_cache($attr,$path) $value
10686 proc get_path_encoding {path} {
10687 global gui_encoding perfile_attrs
10688 set tcl_enc $gui_encoding
10689 if {$path ne {} && $perfile_attrs} {
10690 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10691 if {$enc2 ne {}} {
10692 set tcl_enc $enc2
10695 return $tcl_enc
10698 # First check that Tcl/Tk is recent enough
10699 if {[catch {package require Tk 8.4} err]} {
10700 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10701 Gitk requires at least Tcl/Tk 8.4."]
10702 exit 1
10705 # defaults...
10706 set wrcomcmd "git diff-tree --stdin -p --pretty"
10708 set gitencoding {}
10709 catch {
10710 set gitencoding [exec git config --get i18n.commitencoding]
10712 catch {
10713 set gitencoding [exec git config --get i18n.logoutputencoding]
10715 if {$gitencoding == ""} {
10716 set gitencoding "utf-8"
10718 set tclencoding [tcl_encoding $gitencoding]
10719 if {$tclencoding == {}} {
10720 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10723 set gui_encoding [encoding system]
10724 catch {
10725 set enc [exec git config --get gui.encoding]
10726 if {$enc ne {}} {
10727 set tclenc [tcl_encoding $enc]
10728 if {$tclenc ne {}} {
10729 set gui_encoding $tclenc
10730 } else {
10731 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10736 set mainfont {Helvetica 9}
10737 set textfont {Courier 9}
10738 set uifont {Helvetica 9 bold}
10739 set tabstop 8
10740 set findmergefiles 0
10741 set maxgraphpct 50
10742 set maxwidth 16
10743 set revlistorder 0
10744 set fastdate 0
10745 set uparrowlen 5
10746 set downarrowlen 5
10747 set mingaplen 100
10748 set cmitmode "patch"
10749 set wrapcomment "none"
10750 set showneartags 1
10751 set maxrefs 20
10752 set maxlinelen 200
10753 set showlocalchanges 1
10754 set limitdiffs 1
10755 set datetimeformat "%Y-%m-%d %H:%M:%S"
10756 set autoselect 1
10757 set perfile_attrs 0
10759 set extdifftool "meld"
10761 set colors {green red blue magenta darkgrey brown orange}
10762 set bgcolor white
10763 set fgcolor black
10764 set diffcolors {red "#00a000" blue}
10765 set diffcontext 3
10766 set ignorespace 0
10767 set selectbgcolor gray85
10768 set markbgcolor "#e0e0ff"
10770 set circlecolors {white blue gray blue blue}
10772 # button for popping up context menus
10773 if {[tk windowingsystem] eq "aqua"} {
10774 set ctxbut <Button-2>
10775 } else {
10776 set ctxbut <Button-3>
10779 ## For msgcat loading, first locate the installation location.
10780 if { [info exists ::env(GITK_MSGSDIR)] } {
10781 ## Msgsdir was manually set in the environment.
10782 set gitk_msgsdir $::env(GITK_MSGSDIR)
10783 } else {
10784 ## Let's guess the prefix from argv0.
10785 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10786 set gitk_libdir [file join $gitk_prefix share gitk lib]
10787 set gitk_msgsdir [file join $gitk_libdir msgs]
10788 unset gitk_prefix
10791 ## Internationalization (i18n) through msgcat and gettext. See
10792 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10793 package require msgcat
10794 namespace import ::msgcat::mc
10795 ## And eventually load the actual message catalog
10796 ::msgcat::mcload $gitk_msgsdir
10798 catch {source ~/.gitk}
10800 font create optionfont -family sans-serif -size -12
10802 parsefont mainfont $mainfont
10803 eval font create mainfont [fontflags mainfont]
10804 eval font create mainfontbold [fontflags mainfont 1]
10806 parsefont textfont $textfont
10807 eval font create textfont [fontflags textfont]
10808 eval font create textfontbold [fontflags textfont 1]
10810 parsefont uifont $uifont
10811 eval font create uifont [fontflags uifont]
10813 setoptions
10815 # check that we can find a .git directory somewhere...
10816 if {[catch {set gitdir [gitdir]}]} {
10817 show_error {} . [mc "Cannot find a git repository here."]
10818 exit 1
10820 if {![file isdirectory $gitdir]} {
10821 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10822 exit 1
10825 set selecthead {}
10826 set selectheadid {}
10828 set revtreeargs {}
10829 set cmdline_files {}
10830 set i 0
10831 set revtreeargscmd {}
10832 foreach arg $argv {
10833 switch -glob -- $arg {
10834 "" { }
10835 "--" {
10836 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10837 break
10839 "--select-commit=*" {
10840 set selecthead [string range $arg 16 end]
10842 "--argscmd=*" {
10843 set revtreeargscmd [string range $arg 10 end]
10845 default {
10846 lappend revtreeargs $arg
10849 incr i
10852 if {$selecthead eq "HEAD"} {
10853 set selecthead {}
10856 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10857 # no -- on command line, but some arguments (other than --argscmd)
10858 if {[catch {
10859 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10860 set cmdline_files [split $f "\n"]
10861 set n [llength $cmdline_files]
10862 set revtreeargs [lrange $revtreeargs 0 end-$n]
10863 # Unfortunately git rev-parse doesn't produce an error when
10864 # something is both a revision and a filename. To be consistent
10865 # with git log and git rev-list, check revtreeargs for filenames.
10866 foreach arg $revtreeargs {
10867 if {[file exists $arg]} {
10868 show_error {} . [mc "Ambiguous argument '%s': both revision\
10869 and filename" $arg]
10870 exit 1
10873 } err]} {
10874 # unfortunately we get both stdout and stderr in $err,
10875 # so look for "fatal:".
10876 set i [string first "fatal:" $err]
10877 if {$i > 0} {
10878 set err [string range $err [expr {$i + 6}] end]
10880 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10881 exit 1
10885 set nullid "0000000000000000000000000000000000000000"
10886 set nullid2 "0000000000000000000000000000000000000001"
10887 set nullfile "/dev/null"
10889 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10891 set runq {}
10892 set history {}
10893 set historyindex 0
10894 set fh_serial 0
10895 set nhl_names {}
10896 set highlight_paths {}
10897 set findpattern {}
10898 set searchdirn -forwards
10899 set boldids {}
10900 set boldnameids {}
10901 set diffelide {0 0}
10902 set markingmatches 0
10903 set linkentercount 0
10904 set need_redisplay 0
10905 set nrows_drawn 0
10906 set firsttabstop 0
10908 set nextviewnum 1
10909 set curview 0
10910 set selectedview 0
10911 set selectedhlview [mc "None"]
10912 set highlight_related [mc "None"]
10913 set highlight_files {}
10914 set viewfiles(0) {}
10915 set viewperm(0) 0
10916 set viewargs(0) {}
10917 set viewargscmd(0) {}
10919 set selectedline {}
10920 set numcommits 0
10921 set loginstance 0
10922 set cmdlineok 0
10923 set stopped 0
10924 set stuffsaved 0
10925 set patchnum 0
10926 set lserial 0
10927 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10928 setcoords
10929 makewindow
10930 # wait for the window to become visible
10931 tkwait visibility .
10932 wm title . "[file tail $argv0]: [file tail [pwd]]"
10933 readrefs
10935 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10936 # create a view for the files/dirs specified on the command line
10937 set curview 1
10938 set selectedview 1
10939 set nextviewnum 2
10940 set viewname(1) [mc "Command line"]
10941 set viewfiles(1) $cmdline_files
10942 set viewargs(1) $revtreeargs
10943 set viewargscmd(1) $revtreeargscmd
10944 set viewperm(1) 0
10945 set vdatemode(1) 0
10946 addviewmenu 1
10947 .bar.view entryconf [mca "Edit view..."] -state normal
10948 .bar.view entryconf [mca "Delete view"] -state normal
10951 if {[info exists permviews]} {
10952 foreach v $permviews {
10953 set n $nextviewnum
10954 incr nextviewnum
10955 set viewname($n) [lindex $v 0]
10956 set viewfiles($n) [lindex $v 1]
10957 set viewargs($n) [lindex $v 2]
10958 set viewargscmd($n) [lindex $v 3]
10959 set viewperm($n) 1
10960 addviewmenu $n
10963 getcommits {}