Use prerequisite tags to skip tests that depend on symbolic links
[git/jnareb-git.git] / gitk-git / gitk
blob1773ae63eb54f3b602b782a3633034aab2f828ae
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" - "--all" {
203 lappend revargs $arg
205 "--merge" {
206 set vmergeonly($n) 1
207 # git rev-parse doesn't understand --merge
208 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
210 "-*" {
211 # Other flag arguments including -<n>
212 if {[string is digit -strict [string range $arg 1 end]]} {
213 set filtered 1
214 } else {
215 # a flag argument that we don't recognize;
216 # that means we can't optimize
217 set allknown 0
219 lappend glflags $arg
221 default {
222 # Non-flag arguments specify commits or ranges of commits
223 if {[string match "*...*" $arg]} {
224 lappend revargs --gitk-symmetric-diff-marker
226 lappend revargs $arg
230 set vdflags($n) $diffargs
231 set vflags($n) $glflags
232 set vrevs($n) $revargs
233 set vfiltered($n) $filtered
234 set vorigargs($n) $origargs
235 return $allknown
238 proc parseviewrevs {view revs} {
239 global vposids vnegids
241 if {$revs eq {}} {
242 set revs HEAD
244 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
245 # we get stdout followed by stderr in $err
246 # for an unknown rev, git rev-parse echoes it and then errors out
247 set errlines [split $err "\n"]
248 set badrev {}
249 for {set l 0} {$l < [llength $errlines]} {incr l} {
250 set line [lindex $errlines $l]
251 if {!([string length $line] == 40 && [string is xdigit $line])} {
252 if {[string match "fatal:*" $line]} {
253 if {[string match "fatal: ambiguous argument*" $line]
254 && $badrev ne {}} {
255 if {[llength $badrev] == 1} {
256 set err "unknown revision $badrev"
257 } else {
258 set err "unknown revisions: [join $badrev ", "]"
260 } else {
261 set err [join [lrange $errlines $l end] "\n"]
263 break
265 lappend badrev $line
268 error_popup "[mc "Error parsing revisions:"] $err"
269 return {}
271 set ret {}
272 set pos {}
273 set neg {}
274 set sdm 0
275 foreach id [split $ids "\n"] {
276 if {$id eq "--gitk-symmetric-diff-marker"} {
277 set sdm 4
278 } elseif {[string match "^*" $id]} {
279 if {$sdm != 1} {
280 lappend ret $id
281 if {$sdm == 3} {
282 set sdm 0
285 lappend neg [string range $id 1 end]
286 } else {
287 if {$sdm != 2} {
288 lappend ret $id
289 } else {
290 lset ret end [lindex $ret end]...$id
292 lappend pos $id
294 incr sdm -1
296 set vposids($view) $pos
297 set vnegids($view) $neg
298 return $ret
301 # Start off a git log process and arrange to read its output
302 proc start_rev_list {view} {
303 global startmsecs commitidx viewcomplete curview
304 global tclencoding
305 global viewargs viewargscmd viewfiles vfilelimit
306 global showlocalchanges
307 global viewactive viewinstances vmergeonly
308 global mainheadid viewmainheadid viewmainheadid_orig
309 global vcanopt vflags vrevs vorigargs
311 set startmsecs [clock clicks -milliseconds]
312 set commitidx($view) 0
313 # these are set this way for the error exits
314 set viewcomplete($view) 1
315 set viewactive($view) 0
316 varcinit $view
318 set args $viewargs($view)
319 if {$viewargscmd($view) ne {}} {
320 if {[catch {
321 set str [exec sh -c $viewargscmd($view)]
322 } err]} {
323 error_popup "[mc "Error executing --argscmd command:"] $err"
324 return 0
326 set args [concat $args [split $str "\n"]]
328 set vcanopt($view) [parseviewargs $view $args]
330 set files $viewfiles($view)
331 if {$vmergeonly($view)} {
332 set files [unmerged_files $files]
333 if {$files eq {}} {
334 global nr_unmerged
335 if {$nr_unmerged == 0} {
336 error_popup [mc "No files selected: --merge specified but\
337 no files are unmerged."]
338 } else {
339 error_popup [mc "No files selected: --merge specified but\
340 no unmerged files are within file limit."]
342 return 0
345 set vfilelimit($view) $files
347 if {$vcanopt($view)} {
348 set revs [parseviewrevs $view $vrevs($view)]
349 if {$revs eq {}} {
350 return 0
352 set args [concat $vflags($view) $revs]
353 } else {
354 set args $vorigargs($view)
357 if {[catch {
358 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
359 --boundary $args "--" $files] r]
360 } err]} {
361 error_popup "[mc "Error executing git log:"] $err"
362 return 0
364 set i [reg_instance $fd]
365 set viewinstances($view) [list $i]
366 set viewmainheadid($view) $mainheadid
367 set viewmainheadid_orig($view) $mainheadid
368 if {$files ne {} && $mainheadid ne {}} {
369 get_viewmainhead $view
371 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
372 interestedin $viewmainheadid($view) dodiffindex
374 fconfigure $fd -blocking 0 -translation lf -eofchar {}
375 if {$tclencoding != {}} {
376 fconfigure $fd -encoding $tclencoding
378 filerun $fd [list getcommitlines $fd $i $view 0]
379 nowbusy $view [mc "Reading"]
380 set viewcomplete($view) 0
381 set viewactive($view) 1
382 return 1
385 proc stop_instance {inst} {
386 global commfd leftover
388 set fd $commfd($inst)
389 catch {
390 set pid [pid $fd]
392 if {$::tcl_platform(platform) eq {windows}} {
393 exec kill -f $pid
394 } else {
395 exec kill $pid
398 catch {close $fd}
399 nukefile $fd
400 unset commfd($inst)
401 unset leftover($inst)
404 proc stop_backends {} {
405 global commfd
407 foreach inst [array names commfd] {
408 stop_instance $inst
412 proc stop_rev_list {view} {
413 global viewinstances
415 foreach inst $viewinstances($view) {
416 stop_instance $inst
418 set viewinstances($view) {}
421 proc reset_pending_select {selid} {
422 global pending_select mainheadid selectheadid
424 if {$selid ne {}} {
425 set pending_select $selid
426 } elseif {$selectheadid ne {}} {
427 set pending_select $selectheadid
428 } else {
429 set pending_select $mainheadid
433 proc getcommits {selid} {
434 global canv curview need_redisplay viewactive
436 initlayout
437 if {[start_rev_list $curview]} {
438 reset_pending_select $selid
439 show_status [mc "Reading commits..."]
440 set need_redisplay 1
441 } else {
442 show_status [mc "No commits selected"]
446 proc updatecommits {} {
447 global curview vcanopt vorigargs vfilelimit viewinstances
448 global viewactive viewcomplete tclencoding
449 global startmsecs showneartags showlocalchanges
450 global mainheadid viewmainheadid viewmainheadid_orig pending_select
451 global isworktree
452 global varcid vposids vnegids vflags vrevs
454 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
455 rereadrefs
456 set view $curview
457 if {$mainheadid ne $viewmainheadid_orig($view)} {
458 if {$showlocalchanges} {
459 dohidelocalchanges
461 set viewmainheadid($view) $mainheadid
462 set viewmainheadid_orig($view) $mainheadid
463 if {$vfilelimit($view) ne {}} {
464 get_viewmainhead $view
467 if {$showlocalchanges} {
468 doshowlocalchanges
470 if {$vcanopt($view)} {
471 set oldpos $vposids($view)
472 set oldneg $vnegids($view)
473 set revs [parseviewrevs $view $vrevs($view)]
474 if {$revs eq {}} {
475 return
477 # note: getting the delta when negative refs change is hard,
478 # and could require multiple git log invocations, so in that
479 # case we ask git log for all the commits (not just the delta)
480 if {$oldneg eq $vnegids($view)} {
481 set newrevs {}
482 set npos 0
483 # take out positive refs that we asked for before or
484 # that we have already seen
485 foreach rev $revs {
486 if {[string length $rev] == 40} {
487 if {[lsearch -exact $oldpos $rev] < 0
488 && ![info exists varcid($view,$rev)]} {
489 lappend newrevs $rev
490 incr npos
492 } else {
493 lappend $newrevs $rev
496 if {$npos == 0} return
497 set revs $newrevs
498 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
500 set args [concat $vflags($view) $revs --not $oldpos]
501 } else {
502 set args $vorigargs($view)
504 if {[catch {
505 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
506 --boundary $args "--" $vfilelimit($view)] r]
507 } err]} {
508 error_popup "[mc "Error executing git log:"] $err"
509 return
511 if {$viewactive($view) == 0} {
512 set startmsecs [clock clicks -milliseconds]
514 set i [reg_instance $fd]
515 lappend viewinstances($view) $i
516 fconfigure $fd -blocking 0 -translation lf -eofchar {}
517 if {$tclencoding != {}} {
518 fconfigure $fd -encoding $tclencoding
520 filerun $fd [list getcommitlines $fd $i $view 1]
521 incr viewactive($view)
522 set viewcomplete($view) 0
523 reset_pending_select {}
524 nowbusy $view "Reading"
525 if {$showneartags} {
526 getallcommits
530 proc reloadcommits {} {
531 global curview viewcomplete selectedline currentid thickerline
532 global showneartags treediffs commitinterest cached_commitrow
533 global targetid
535 set selid {}
536 if {$selectedline ne {}} {
537 set selid $currentid
540 if {!$viewcomplete($curview)} {
541 stop_rev_list $curview
543 resetvarcs $curview
544 set selectedline {}
545 catch {unset currentid}
546 catch {unset thickerline}
547 catch {unset treediffs}
548 readrefs
549 changedrefs
550 if {$showneartags} {
551 getallcommits
553 clear_display
554 catch {unset commitinterest}
555 catch {unset cached_commitrow}
556 catch {unset targetid}
557 setcanvscroll
558 getcommits $selid
559 return 0
562 # This makes a string representation of a positive integer which
563 # sorts as a string in numerical order
564 proc strrep {n} {
565 if {$n < 16} {
566 return [format "%x" $n]
567 } elseif {$n < 256} {
568 return [format "x%.2x" $n]
569 } elseif {$n < 65536} {
570 return [format "y%.4x" $n]
572 return [format "z%.8x" $n]
575 # Procedures used in reordering commits from git log (without
576 # --topo-order) into the order for display.
578 proc varcinit {view} {
579 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
580 global vtokmod varcmod vrowmod varcix vlastins
582 set varcstart($view) {{}}
583 set vupptr($view) {0}
584 set vdownptr($view) {0}
585 set vleftptr($view) {0}
586 set vbackptr($view) {0}
587 set varctok($view) {{}}
588 set varcrow($view) {{}}
589 set vtokmod($view) {}
590 set varcmod($view) 0
591 set vrowmod($view) 0
592 set varcix($view) {{}}
593 set vlastins($view) {0}
596 proc resetvarcs {view} {
597 global varcid varccommits parents children vseedcount ordertok
599 foreach vid [array names varcid $view,*] {
600 unset varcid($vid)
601 unset children($vid)
602 unset parents($vid)
604 # some commits might have children but haven't been seen yet
605 foreach vid [array names children $view,*] {
606 unset children($vid)
608 foreach va [array names varccommits $view,*] {
609 unset varccommits($va)
611 foreach vd [array names vseedcount $view,*] {
612 unset vseedcount($vd)
614 catch {unset ordertok}
617 # returns a list of the commits with no children
618 proc seeds {v} {
619 global vdownptr vleftptr varcstart
621 set ret {}
622 set a [lindex $vdownptr($v) 0]
623 while {$a != 0} {
624 lappend ret [lindex $varcstart($v) $a]
625 set a [lindex $vleftptr($v) $a]
627 return $ret
630 proc newvarc {view id} {
631 global varcid varctok parents children vdatemode
632 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
633 global commitdata commitinfo vseedcount varccommits vlastins
635 set a [llength $varctok($view)]
636 set vid $view,$id
637 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
638 if {![info exists commitinfo($id)]} {
639 parsecommit $id $commitdata($id) 1
641 set cdate [lindex $commitinfo($id) 4]
642 if {![string is integer -strict $cdate]} {
643 set cdate 0
645 if {![info exists vseedcount($view,$cdate)]} {
646 set vseedcount($view,$cdate) -1
648 set c [incr vseedcount($view,$cdate)]
649 set cdate [expr {$cdate ^ 0xffffffff}]
650 set tok "s[strrep $cdate][strrep $c]"
651 } else {
652 set tok {}
654 set ka 0
655 if {[llength $children($vid)] > 0} {
656 set kid [lindex $children($vid) end]
657 set k $varcid($view,$kid)
658 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
659 set ki $kid
660 set ka $k
661 set tok [lindex $varctok($view) $k]
664 if {$ka != 0} {
665 set i [lsearch -exact $parents($view,$ki) $id]
666 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
667 append tok [strrep $j]
669 set c [lindex $vlastins($view) $ka]
670 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
671 set c $ka
672 set b [lindex $vdownptr($view) $ka]
673 } else {
674 set b [lindex $vleftptr($view) $c]
676 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
677 set c $b
678 set b [lindex $vleftptr($view) $c]
680 if {$c == $ka} {
681 lset vdownptr($view) $ka $a
682 lappend vbackptr($view) 0
683 } else {
684 lset vleftptr($view) $c $a
685 lappend vbackptr($view) $c
687 lset vlastins($view) $ka $a
688 lappend vupptr($view) $ka
689 lappend vleftptr($view) $b
690 if {$b != 0} {
691 lset vbackptr($view) $b $a
693 lappend varctok($view) $tok
694 lappend varcstart($view) $id
695 lappend vdownptr($view) 0
696 lappend varcrow($view) {}
697 lappend varcix($view) {}
698 set varccommits($view,$a) {}
699 lappend vlastins($view) 0
700 return $a
703 proc splitvarc {p v} {
704 global varcid varcstart varccommits varctok vtokmod
705 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707 set oa $varcid($v,$p)
708 set otok [lindex $varctok($v) $oa]
709 set ac $varccommits($v,$oa)
710 set i [lsearch -exact $varccommits($v,$oa) $p]
711 if {$i <= 0} return
712 set na [llength $varctok($v)]
713 # "%" sorts before "0"...
714 set tok "$otok%[strrep $i]"
715 lappend varctok($v) $tok
716 lappend varcrow($v) {}
717 lappend varcix($v) {}
718 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
719 set varccommits($v,$na) [lrange $ac $i end]
720 lappend varcstart($v) $p
721 foreach id $varccommits($v,$na) {
722 set varcid($v,$id) $na
724 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
725 lappend vlastins($v) [lindex $vlastins($v) $oa]
726 lset vdownptr($v) $oa $na
727 lset vlastins($v) $oa 0
728 lappend vupptr($v) $oa
729 lappend vleftptr($v) 0
730 lappend vbackptr($v) 0
731 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
732 lset vupptr($v) $b $na
734 if {[string compare $otok $vtokmod($v)] <= 0} {
735 modify_arc $v $oa
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 line [split $line " "]
1609 set tag [lindex $line 0]
1610 if {$tag == "author"} {
1611 set audate [lindex $line end-1]
1612 set auname [join [lrange $line 1 end-2] " "]
1613 } elseif {$tag == "committer"} {
1614 set comdate [lindex $line end-1]
1615 set comname [join [lrange $line 1 end-2] " "]
1618 set headline {}
1619 # take the first non-blank line of the comment as the headline
1620 set headline [string trimleft $comment]
1621 set i [string first "\n" $headline]
1622 if {$i >= 0} {
1623 set headline [string range $headline 0 $i]
1625 set headline [string trimright $headline]
1626 set i [string first "\r" $headline]
1627 if {$i >= 0} {
1628 set headline [string trimright [string range $headline 0 $i]]
1630 if {!$listed} {
1631 # git log indents the comment by 4 spaces;
1632 # if we got this via git cat-file, add the indentation
1633 set newcomment {}
1634 foreach line [split $comment "\n"] {
1635 append newcomment " "
1636 append newcomment $line
1637 append newcomment "\n"
1639 set comment $newcomment
1641 if {$comdate != {}} {
1642 set cdate($id) $comdate
1644 set commitinfo($id) [list $headline $auname $audate \
1645 $comname $comdate $comment]
1648 proc getcommit {id} {
1649 global commitdata commitinfo
1651 if {[info exists commitdata($id)]} {
1652 parsecommit $id $commitdata($id) 1
1653 } else {
1654 readcommit $id
1655 if {![info exists commitinfo($id)]} {
1656 set commitinfo($id) [list [mc "No commit information available"]]
1659 return 1
1662 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1663 # and are present in the current view.
1664 # This is fairly slow...
1665 proc longid {prefix} {
1666 global varcid curview
1668 set ids {}
1669 foreach match [array names varcid "$curview,$prefix*"] {
1670 lappend ids [lindex [split $match ","] 1]
1672 return $ids
1675 proc readrefs {} {
1676 global tagids idtags headids idheads tagobjid
1677 global otherrefids idotherrefs mainhead mainheadid
1678 global selecthead selectheadid
1680 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1681 catch {unset $v}
1683 set refd [open [list | git show-ref -d] r]
1684 while {[gets $refd line] >= 0} {
1685 if {[string index $line 40] ne " "} continue
1686 set id [string range $line 0 39]
1687 set ref [string range $line 41 end]
1688 if {![string match "refs/*" $ref]} continue
1689 set name [string range $ref 5 end]
1690 if {[string match "remotes/*" $name]} {
1691 if {![string match "*/HEAD" $name]} {
1692 set headids($name) $id
1693 lappend idheads($id) $name
1695 } elseif {[string match "heads/*" $name]} {
1696 set name [string range $name 6 end]
1697 set headids($name) $id
1698 lappend idheads($id) $name
1699 } elseif {[string match "tags/*" $name]} {
1700 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1701 # which is what we want since the former is the commit ID
1702 set name [string range $name 5 end]
1703 if {[string match "*^{}" $name]} {
1704 set name [string range $name 0 end-3]
1705 } else {
1706 set tagobjid($name) $id
1708 set tagids($name) $id
1709 lappend idtags($id) $name
1710 } else {
1711 set otherrefids($name) $id
1712 lappend idotherrefs($id) $name
1715 catch {close $refd}
1716 set mainhead {}
1717 set mainheadid {}
1718 catch {
1719 set mainheadid [exec git rev-parse HEAD]
1720 set thehead [exec git symbolic-ref HEAD]
1721 if {[string match "refs/heads/*" $thehead]} {
1722 set mainhead [string range $thehead 11 end]
1725 set selectheadid {}
1726 if {$selecthead ne {}} {
1727 catch {
1728 set selectheadid [exec git rev-parse --verify $selecthead]
1733 # skip over fake commits
1734 proc first_real_row {} {
1735 global nullid nullid2 numcommits
1737 for {set row 0} {$row < $numcommits} {incr row} {
1738 set id [commitonrow $row]
1739 if {$id ne $nullid && $id ne $nullid2} {
1740 break
1743 return $row
1746 # update things for a head moved to a child of its previous location
1747 proc movehead {id name} {
1748 global headids idheads
1750 removehead $headids($name) $name
1751 set headids($name) $id
1752 lappend idheads($id) $name
1755 # update things when a head has been removed
1756 proc removehead {id name} {
1757 global headids idheads
1759 if {$idheads($id) eq $name} {
1760 unset idheads($id)
1761 } else {
1762 set i [lsearch -exact $idheads($id) $name]
1763 if {$i >= 0} {
1764 set idheads($id) [lreplace $idheads($id) $i $i]
1767 unset headids($name)
1770 proc make_transient {window origin} {
1771 global have_tk85
1773 # In MacOS Tk 8.4 transient appears to work by setting
1774 # overrideredirect, which is utterly useless, since the
1775 # windows get no border, and are not even kept above
1776 # the parent.
1777 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1779 wm transient $window $origin
1781 # Windows fails to place transient windows normally, so
1782 # schedule a callback to center them on the parent.
1783 if {[tk windowingsystem] eq {win32}} {
1784 after idle [list tk::PlaceWindow $window widget $origin]
1788 proc show_error {w top msg} {
1789 message $w.m -text $msg -justify center -aspect 400
1790 pack $w.m -side top -fill x -padx 20 -pady 20
1791 button $w.ok -text [mc OK] -command "destroy $top"
1792 pack $w.ok -side bottom -fill x
1793 bind $top <Visibility> "grab $top; focus $top"
1794 bind $top <Key-Return> "destroy $top"
1795 bind $top <Key-space> "destroy $top"
1796 bind $top <Key-Escape> "destroy $top"
1797 tkwait window $top
1800 proc error_popup {msg {owner .}} {
1801 set w .error
1802 toplevel $w
1803 make_transient $w $owner
1804 show_error $w $w $msg
1807 proc confirm_popup {msg {owner .}} {
1808 global confirm_ok
1809 set confirm_ok 0
1810 set w .confirm
1811 toplevel $w
1812 make_transient $w $owner
1813 message $w.m -text $msg -justify center -aspect 400
1814 pack $w.m -side top -fill x -padx 20 -pady 20
1815 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1816 pack $w.ok -side left -fill x
1817 button $w.cancel -text [mc Cancel] -command "destroy $w"
1818 pack $w.cancel -side right -fill x
1819 bind $w <Visibility> "grab $w; focus $w"
1820 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1821 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1822 bind $w <Key-Escape> "destroy $w"
1823 tkwait window $w
1824 return $confirm_ok
1827 proc setoptions {} {
1828 option add *Panedwindow.showHandle 1 startupFile
1829 option add *Panedwindow.sashRelief raised startupFile
1830 option add *Button.font uifont startupFile
1831 option add *Checkbutton.font uifont startupFile
1832 option add *Radiobutton.font uifont startupFile
1833 option add *Menu.font uifont startupFile
1834 option add *Menubutton.font uifont startupFile
1835 option add *Label.font uifont startupFile
1836 option add *Message.font uifont startupFile
1837 option add *Entry.font uifont startupFile
1840 # Make a menu and submenus.
1841 # m is the window name for the menu, items is the list of menu items to add.
1842 # Each item is a list {mc label type description options...}
1843 # mc is ignored; it's so we can put mc there to alert xgettext
1844 # label is the string that appears in the menu
1845 # type is cascade, command or radiobutton (should add checkbutton)
1846 # description depends on type; it's the sublist for cascade, the
1847 # command to invoke for command, or {variable value} for radiobutton
1848 proc makemenu {m items} {
1849 menu $m
1850 if {[tk windowingsystem] eq {aqua}} {
1851 set Meta1 Cmd
1852 } else {
1853 set Meta1 Ctrl
1855 foreach i $items {
1856 set name [mc [lindex $i 1]]
1857 set type [lindex $i 2]
1858 set thing [lindex $i 3]
1859 set params [list $type]
1860 if {$name ne {}} {
1861 set u [string first "&" [string map {&& x} $name]]
1862 lappend params -label [string map {&& & & {}} $name]
1863 if {$u >= 0} {
1864 lappend params -underline $u
1867 switch -- $type {
1868 "cascade" {
1869 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1870 lappend params -menu $m.$submenu
1872 "command" {
1873 lappend params -command $thing
1875 "radiobutton" {
1876 lappend params -variable [lindex $thing 0] \
1877 -value [lindex $thing 1]
1880 set tail [lrange $i 4 end]
1881 regsub -all {\yMeta1\y} $tail $Meta1 tail
1882 eval $m add $params $tail
1883 if {$type eq "cascade"} {
1884 makemenu $m.$submenu $thing
1889 # translate string and remove ampersands
1890 proc mca {str} {
1891 return [string map {&& & & {}} [mc $str]]
1894 proc makewindow {} {
1895 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1896 global tabstop
1897 global findtype findtypemenu findloc findstring fstring geometry
1898 global entries sha1entry sha1string sha1but
1899 global diffcontextstring diffcontext
1900 global ignorespace
1901 global maincursor textcursor curtextcursor
1902 global rowctxmenu fakerowmenu mergemax wrapcomment
1903 global highlight_files gdttype
1904 global searchstring sstring
1905 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1906 global headctxmenu progresscanv progressitem progresscoords statusw
1907 global fprogitem fprogcoord lastprogupdate progupdatepending
1908 global rprogitem rprogcoord rownumsel numcommits
1909 global have_tk85
1911 # The "mc" arguments here are purely so that xgettext
1912 # sees the following string as needing to be translated
1913 makemenu .bar {
1914 {mc "File" cascade {
1915 {mc "Update" command updatecommits -accelerator F5}
1916 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1917 {mc "Reread references" command rereadrefs}
1918 {mc "List references" command showrefs -accelerator F2}
1919 {xx "" separator}
1920 {mc "Start git gui" command {exec git gui &}}
1921 {xx "" separator}
1922 {mc "Quit" command doquit -accelerator Meta1-Q}
1924 {mc "Edit" cascade {
1925 {mc "Preferences" command doprefs}
1927 {mc "View" cascade {
1928 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1929 {mc "Edit view..." command editview -state disabled -accelerator F4}
1930 {mc "Delete view" command delview -state disabled}
1931 {xx "" separator}
1932 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1934 {mc "Help" cascade {
1935 {mc "About gitk" command about}
1936 {mc "Key bindings" command keys}
1939 . configure -menu .bar
1941 # the gui has upper and lower half, parts of a paned window.
1942 panedwindow .ctop -orient vertical
1944 # possibly use assumed geometry
1945 if {![info exists geometry(pwsash0)]} {
1946 set geometry(topheight) [expr {15 * $linespc}]
1947 set geometry(topwidth) [expr {80 * $charspc}]
1948 set geometry(botheight) [expr {15 * $linespc}]
1949 set geometry(botwidth) [expr {50 * $charspc}]
1950 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1951 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1954 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1955 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1956 frame .tf.histframe
1957 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1959 # create three canvases
1960 set cscroll .tf.histframe.csb
1961 set canv .tf.histframe.pwclist.canv
1962 canvas $canv \
1963 -selectbackground $selectbgcolor \
1964 -background $bgcolor -bd 0 \
1965 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1966 .tf.histframe.pwclist add $canv
1967 set canv2 .tf.histframe.pwclist.canv2
1968 canvas $canv2 \
1969 -selectbackground $selectbgcolor \
1970 -background $bgcolor -bd 0 -yscrollincr $linespc
1971 .tf.histframe.pwclist add $canv2
1972 set canv3 .tf.histframe.pwclist.canv3
1973 canvas $canv3 \
1974 -selectbackground $selectbgcolor \
1975 -background $bgcolor -bd 0 -yscrollincr $linespc
1976 .tf.histframe.pwclist add $canv3
1977 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1978 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1980 # a scroll bar to rule them
1981 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1982 pack $cscroll -side right -fill y
1983 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1984 lappend bglist $canv $canv2 $canv3
1985 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1987 # we have two button bars at bottom of top frame. Bar 1
1988 frame .tf.bar
1989 frame .tf.lbar -height 15
1991 set sha1entry .tf.bar.sha1
1992 set entries $sha1entry
1993 set sha1but .tf.bar.sha1label
1994 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1995 -command gotocommit -width 8
1996 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1997 pack .tf.bar.sha1label -side left
1998 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1999 trace add variable sha1string write sha1change
2000 pack $sha1entry -side left -pady 2
2002 image create bitmap bm-left -data {
2003 #define left_width 16
2004 #define left_height 16
2005 static unsigned char left_bits[] = {
2006 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2007 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2008 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2010 image create bitmap bm-right -data {
2011 #define right_width 16
2012 #define right_height 16
2013 static unsigned char right_bits[] = {
2014 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2015 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2016 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2018 button .tf.bar.leftbut -image bm-left -command goback \
2019 -state disabled -width 26
2020 pack .tf.bar.leftbut -side left -fill y
2021 button .tf.bar.rightbut -image bm-right -command goforw \
2022 -state disabled -width 26
2023 pack .tf.bar.rightbut -side left -fill y
2025 label .tf.bar.rowlabel -text [mc "Row"]
2026 set rownumsel {}
2027 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2028 -relief sunken -anchor e
2029 label .tf.bar.rowlabel2 -text "/"
2030 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2031 -relief sunken -anchor e
2032 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2033 -side left
2034 global selectedline
2035 trace add variable selectedline write selectedline_change
2037 # Status label and progress bar
2038 set statusw .tf.bar.status
2039 label $statusw -width 15 -relief sunken
2040 pack $statusw -side left -padx 5
2041 set h [expr {[font metrics uifont -linespace] + 2}]
2042 set progresscanv .tf.bar.progress
2043 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2044 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2045 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2046 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2047 pack $progresscanv -side right -expand 1 -fill x
2048 set progresscoords {0 0}
2049 set fprogcoord 0
2050 set rprogcoord 0
2051 bind $progresscanv <Configure> adjustprogress
2052 set lastprogupdate [clock clicks -milliseconds]
2053 set progupdatepending 0
2055 # build up the bottom bar of upper window
2056 label .tf.lbar.flabel -text "[mc "Find"] "
2057 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2058 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2059 label .tf.lbar.flab2 -text " [mc "commit"] "
2060 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2061 -side left -fill y
2062 set gdttype [mc "containing:"]
2063 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2064 [mc "containing:"] \
2065 [mc "touching paths:"] \
2066 [mc "adding/removing string:"]]
2067 trace add variable gdttype write gdttype_change
2068 pack .tf.lbar.gdttype -side left -fill y
2070 set findstring {}
2071 set fstring .tf.lbar.findstring
2072 lappend entries $fstring
2073 entry $fstring -width 30 -font textfont -textvariable findstring
2074 trace add variable findstring write find_change
2075 set findtype [mc "Exact"]
2076 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2077 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2078 trace add variable findtype write findcom_change
2079 set findloc [mc "All fields"]
2080 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2081 [mc "Comments"] [mc "Author"] [mc "Committer"]
2082 trace add variable findloc write find_change
2083 pack .tf.lbar.findloc -side right
2084 pack .tf.lbar.findtype -side right
2085 pack $fstring -side left -expand 1 -fill x
2087 # Finish putting the upper half of the viewer together
2088 pack .tf.lbar -in .tf -side bottom -fill x
2089 pack .tf.bar -in .tf -side bottom -fill x
2090 pack .tf.histframe -fill both -side top -expand 1
2091 .ctop add .tf
2092 .ctop paneconfigure .tf -height $geometry(topheight)
2093 .ctop paneconfigure .tf -width $geometry(topwidth)
2095 # now build up the bottom
2096 panedwindow .pwbottom -orient horizontal
2098 # lower left, a text box over search bar, scroll bar to the right
2099 # if we know window height, then that will set the lower text height, otherwise
2100 # we set lower text height which will drive window height
2101 if {[info exists geometry(main)]} {
2102 frame .bleft -width $geometry(botwidth)
2103 } else {
2104 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2106 frame .bleft.top
2107 frame .bleft.mid
2108 frame .bleft.bottom
2110 button .bleft.top.search -text [mc "Search"] -command dosearch
2111 pack .bleft.top.search -side left -padx 5
2112 set sstring .bleft.top.sstring
2113 entry $sstring -width 20 -font textfont -textvariable searchstring
2114 lappend entries $sstring
2115 trace add variable searchstring write incrsearch
2116 pack $sstring -side left -expand 1 -fill x
2117 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2118 -command changediffdisp -variable diffelide -value {0 0}
2119 radiobutton .bleft.mid.old -text [mc "Old version"] \
2120 -command changediffdisp -variable diffelide -value {0 1}
2121 radiobutton .bleft.mid.new -text [mc "New version"] \
2122 -command changediffdisp -variable diffelide -value {1 0}
2123 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2124 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2125 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2126 -from 1 -increment 1 -to 10000000 \
2127 -validate all -validatecommand "diffcontextvalidate %P" \
2128 -textvariable diffcontextstring
2129 .bleft.mid.diffcontext set $diffcontext
2130 trace add variable diffcontextstring write diffcontextchange
2131 lappend entries .bleft.mid.diffcontext
2132 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2133 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2134 -command changeignorespace -variable ignorespace
2135 pack .bleft.mid.ignspace -side left -padx 5
2136 set ctext .bleft.bottom.ctext
2137 text $ctext -background $bgcolor -foreground $fgcolor \
2138 -state disabled -font textfont \
2139 -yscrollcommand scrolltext -wrap none \
2140 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2141 if {$have_tk85} {
2142 $ctext conf -tabstyle wordprocessor
2144 scrollbar .bleft.bottom.sb -command "$ctext yview"
2145 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2146 -width 10
2147 pack .bleft.top -side top -fill x
2148 pack .bleft.mid -side top -fill x
2149 grid $ctext .bleft.bottom.sb -sticky nsew
2150 grid .bleft.bottom.sbhorizontal -sticky ew
2151 grid columnconfigure .bleft.bottom 0 -weight 1
2152 grid rowconfigure .bleft.bottom 0 -weight 1
2153 grid rowconfigure .bleft.bottom 1 -weight 0
2154 pack .bleft.bottom -side top -fill both -expand 1
2155 lappend bglist $ctext
2156 lappend fglist $ctext
2158 $ctext tag conf comment -wrap $wrapcomment
2159 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2160 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2161 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2162 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2163 $ctext tag conf m0 -fore red
2164 $ctext tag conf m1 -fore blue
2165 $ctext tag conf m2 -fore green
2166 $ctext tag conf m3 -fore purple
2167 $ctext tag conf m4 -fore brown
2168 $ctext tag conf m5 -fore "#009090"
2169 $ctext tag conf m6 -fore magenta
2170 $ctext tag conf m7 -fore "#808000"
2171 $ctext tag conf m8 -fore "#009000"
2172 $ctext tag conf m9 -fore "#ff0080"
2173 $ctext tag conf m10 -fore cyan
2174 $ctext tag conf m11 -fore "#b07070"
2175 $ctext tag conf m12 -fore "#70b0f0"
2176 $ctext tag conf m13 -fore "#70f0b0"
2177 $ctext tag conf m14 -fore "#f0b070"
2178 $ctext tag conf m15 -fore "#ff70b0"
2179 $ctext tag conf mmax -fore darkgrey
2180 set mergemax 16
2181 $ctext tag conf mresult -font textfontbold
2182 $ctext tag conf msep -font textfontbold
2183 $ctext tag conf found -back yellow
2185 .pwbottom add .bleft
2186 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2188 # lower right
2189 frame .bright
2190 frame .bright.mode
2191 radiobutton .bright.mode.patch -text [mc "Patch"] \
2192 -command reselectline -variable cmitmode -value "patch"
2193 radiobutton .bright.mode.tree -text [mc "Tree"] \
2194 -command reselectline -variable cmitmode -value "tree"
2195 grid .bright.mode.patch .bright.mode.tree -sticky ew
2196 pack .bright.mode -side top -fill x
2197 set cflist .bright.cfiles
2198 set indent [font measure mainfont "nn"]
2199 text $cflist \
2200 -selectbackground $selectbgcolor \
2201 -background $bgcolor -foreground $fgcolor \
2202 -font mainfont \
2203 -tabs [list $indent [expr {2 * $indent}]] \
2204 -yscrollcommand ".bright.sb set" \
2205 -cursor [. cget -cursor] \
2206 -spacing1 1 -spacing3 1
2207 lappend bglist $cflist
2208 lappend fglist $cflist
2209 scrollbar .bright.sb -command "$cflist yview"
2210 pack .bright.sb -side right -fill y
2211 pack $cflist -side left -fill both -expand 1
2212 $cflist tag configure highlight \
2213 -background [$cflist cget -selectbackground]
2214 $cflist tag configure bold -font mainfontbold
2216 .pwbottom add .bright
2217 .ctop add .pwbottom
2219 # restore window width & height if known
2220 if {[info exists geometry(main)]} {
2221 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2222 if {$w > [winfo screenwidth .]} {
2223 set w [winfo screenwidth .]
2225 if {$h > [winfo screenheight .]} {
2226 set h [winfo screenheight .]
2228 wm geometry . "${w}x$h"
2232 if {[tk windowingsystem] eq {aqua}} {
2233 set M1B M1
2234 } else {
2235 set M1B Control
2238 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2239 pack .ctop -fill both -expand 1
2240 bindall <1> {selcanvline %W %x %y}
2241 #bindall <B1-Motion> {selcanvline %W %x %y}
2242 if {[tk windowingsystem] == "win32"} {
2243 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2244 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2245 } else {
2246 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2247 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2248 if {[tk windowingsystem] eq "aqua"} {
2249 bindall <MouseWheel> {
2250 set delta [expr {- (%D)}]
2251 allcanvs yview scroll $delta units
2255 bindall <2> "canvscan mark %W %x %y"
2256 bindall <B2-Motion> "canvscan dragto %W %x %y"
2257 bindkey <Home> selfirstline
2258 bindkey <End> sellastline
2259 bind . <Key-Up> "selnextline -1"
2260 bind . <Key-Down> "selnextline 1"
2261 bind . <Shift-Key-Up> "dofind -1 0"
2262 bind . <Shift-Key-Down> "dofind 1 0"
2263 bindkey <Key-Right> "goforw"
2264 bindkey <Key-Left> "goback"
2265 bind . <Key-Prior> "selnextpage -1"
2266 bind . <Key-Next> "selnextpage 1"
2267 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2268 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2269 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2270 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2271 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2272 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2273 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2274 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2275 bindkey <Key-space> "$ctext yview scroll 1 pages"
2276 bindkey p "selnextline -1"
2277 bindkey n "selnextline 1"
2278 bindkey z "goback"
2279 bindkey x "goforw"
2280 bindkey i "selnextline -1"
2281 bindkey k "selnextline 1"
2282 bindkey j "goback"
2283 bindkey l "goforw"
2284 bindkey b prevfile
2285 bindkey d "$ctext yview scroll 18 units"
2286 bindkey u "$ctext yview scroll -18 units"
2287 bindkey / {focus $fstring}
2288 bindkey <Key-Return> {dofind 1 1}
2289 bindkey ? {dofind -1 1}
2290 bindkey f nextfile
2291 bind . <F5> updatecommits
2292 bind . <$M1B-F5> reloadcommits
2293 bind . <F2> showrefs
2294 bind . <Shift-F4> {newview 0}
2295 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2296 bind . <F4> edit_or_newview
2297 bind . <$M1B-q> doquit
2298 bind . <$M1B-f> {dofind 1 1}
2299 bind . <$M1B-g> {dofind 1 0}
2300 bind . <$M1B-r> dosearchback
2301 bind . <$M1B-s> dosearch
2302 bind . <$M1B-equal> {incrfont 1}
2303 bind . <$M1B-plus> {incrfont 1}
2304 bind . <$M1B-KP_Add> {incrfont 1}
2305 bind . <$M1B-minus> {incrfont -1}
2306 bind . <$M1B-KP_Subtract> {incrfont -1}
2307 wm protocol . WM_DELETE_WINDOW doquit
2308 bind . <Destroy> {stop_backends}
2309 bind . <Button-1> "click %W"
2310 bind $fstring <Key-Return> {dofind 1 1}
2311 bind $sha1entry <Key-Return> {gotocommit; break}
2312 bind $sha1entry <<PasteSelection>> clearsha1
2313 bind $cflist <1> {sel_flist %W %x %y; break}
2314 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2315 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2316 global ctxbut
2317 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2318 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2320 set maincursor [. cget -cursor]
2321 set textcursor [$ctext cget -cursor]
2322 set curtextcursor $textcursor
2324 set rowctxmenu .rowctxmenu
2325 makemenu $rowctxmenu {
2326 {mc "Diff this -> selected" command {diffvssel 0}}
2327 {mc "Diff selected -> this" command {diffvssel 1}}
2328 {mc "Make patch" command mkpatch}
2329 {mc "Create tag" command mktag}
2330 {mc "Write commit to file" command writecommit}
2331 {mc "Create new branch" command mkbranch}
2332 {mc "Cherry-pick this commit" command cherrypick}
2333 {mc "Reset HEAD branch to here" command resethead}
2335 $rowctxmenu configure -tearoff 0
2337 set fakerowmenu .fakerowmenu
2338 makemenu $fakerowmenu {
2339 {mc "Diff this -> selected" command {diffvssel 0}}
2340 {mc "Diff selected -> this" command {diffvssel 1}}
2341 {mc "Make patch" command mkpatch}
2343 $fakerowmenu configure -tearoff 0
2345 set headctxmenu .headctxmenu
2346 makemenu $headctxmenu {
2347 {mc "Check out this branch" command cobranch}
2348 {mc "Remove this branch" command rmbranch}
2350 $headctxmenu configure -tearoff 0
2352 global flist_menu
2353 set flist_menu .flistctxmenu
2354 makemenu $flist_menu {
2355 {mc "Highlight this too" command {flist_hl 0}}
2356 {mc "Highlight this only" command {flist_hl 1}}
2357 {mc "External diff" command {external_diff}}
2358 {mc "Blame parent commit" command {external_blame 1}}
2360 $flist_menu configure -tearoff 0
2362 global diff_menu
2363 set diff_menu .diffctxmenu
2364 makemenu $diff_menu {
2365 {mc "Show origin of this line" command show_line_source}
2366 {mc "Run git gui blame on this line" command {external_blame_diff}}
2368 $diff_menu configure -tearoff 0
2371 # Windows sends all mouse wheel events to the current focused window, not
2372 # the one where the mouse hovers, so bind those events here and redirect
2373 # to the correct window
2374 proc windows_mousewheel_redirector {W X Y D} {
2375 global canv canv2 canv3
2376 set w [winfo containing -displayof $W $X $Y]
2377 if {$w ne ""} {
2378 set u [expr {$D < 0 ? 5 : -5}]
2379 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2380 allcanvs yview scroll $u units
2381 } else {
2382 catch {
2383 $w yview scroll $u units
2389 # Update row number label when selectedline changes
2390 proc selectedline_change {n1 n2 op} {
2391 global selectedline rownumsel
2393 if {$selectedline eq {}} {
2394 set rownumsel {}
2395 } else {
2396 set rownumsel [expr {$selectedline + 1}]
2400 # mouse-2 makes all windows scan vertically, but only the one
2401 # the cursor is in scans horizontally
2402 proc canvscan {op w x y} {
2403 global canv canv2 canv3
2404 foreach c [list $canv $canv2 $canv3] {
2405 if {$c == $w} {
2406 $c scan $op $x $y
2407 } else {
2408 $c scan $op 0 $y
2413 proc scrollcanv {cscroll f0 f1} {
2414 $cscroll set $f0 $f1
2415 drawvisible
2416 flushhighlights
2419 # when we make a key binding for the toplevel, make sure
2420 # it doesn't get triggered when that key is pressed in the
2421 # find string entry widget.
2422 proc bindkey {ev script} {
2423 global entries
2424 bind . $ev $script
2425 set escript [bind Entry $ev]
2426 if {$escript == {}} {
2427 set escript [bind Entry <Key>]
2429 foreach e $entries {
2430 bind $e $ev "$escript; break"
2434 # set the focus back to the toplevel for any click outside
2435 # the entry widgets
2436 proc click {w} {
2437 global ctext entries
2438 foreach e [concat $entries $ctext] {
2439 if {$w == $e} return
2441 focus .
2444 # Adjust the progress bar for a change in requested extent or canvas size
2445 proc adjustprogress {} {
2446 global progresscanv progressitem progresscoords
2447 global fprogitem fprogcoord lastprogupdate progupdatepending
2448 global rprogitem rprogcoord
2450 set w [expr {[winfo width $progresscanv] - 4}]
2451 set x0 [expr {$w * [lindex $progresscoords 0]}]
2452 set x1 [expr {$w * [lindex $progresscoords 1]}]
2453 set h [winfo height $progresscanv]
2454 $progresscanv coords $progressitem $x0 0 $x1 $h
2455 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2456 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2457 set now [clock clicks -milliseconds]
2458 if {$now >= $lastprogupdate + 100} {
2459 set progupdatepending 0
2460 update
2461 } elseif {!$progupdatepending} {
2462 set progupdatepending 1
2463 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2467 proc doprogupdate {} {
2468 global lastprogupdate progupdatepending
2470 if {$progupdatepending} {
2471 set progupdatepending 0
2472 set lastprogupdate [clock clicks -milliseconds]
2473 update
2477 proc savestuff {w} {
2478 global canv canv2 canv3 mainfont textfont uifont tabstop
2479 global stuffsaved findmergefiles maxgraphpct
2480 global maxwidth showneartags showlocalchanges
2481 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2482 global cmitmode wrapcomment datetimeformat limitdiffs
2483 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2484 global autoselect extdifftool perfile_attrs markbgcolor
2486 if {$stuffsaved} return
2487 if {![winfo viewable .]} return
2488 catch {
2489 set f [open "~/.gitk-new" w]
2490 puts $f [list set mainfont $mainfont]
2491 puts $f [list set textfont $textfont]
2492 puts $f [list set uifont $uifont]
2493 puts $f [list set tabstop $tabstop]
2494 puts $f [list set findmergefiles $findmergefiles]
2495 puts $f [list set maxgraphpct $maxgraphpct]
2496 puts $f [list set maxwidth $maxwidth]
2497 puts $f [list set cmitmode $cmitmode]
2498 puts $f [list set wrapcomment $wrapcomment]
2499 puts $f [list set autoselect $autoselect]
2500 puts $f [list set showneartags $showneartags]
2501 puts $f [list set showlocalchanges $showlocalchanges]
2502 puts $f [list set datetimeformat $datetimeformat]
2503 puts $f [list set limitdiffs $limitdiffs]
2504 puts $f [list set bgcolor $bgcolor]
2505 puts $f [list set fgcolor $fgcolor]
2506 puts $f [list set colors $colors]
2507 puts $f [list set diffcolors $diffcolors]
2508 puts $f [list set markbgcolor $markbgcolor]
2509 puts $f [list set diffcontext $diffcontext]
2510 puts $f [list set selectbgcolor $selectbgcolor]
2511 puts $f [list set extdifftool $extdifftool]
2512 puts $f [list set perfile_attrs $perfile_attrs]
2514 puts $f "set geometry(main) [wm geometry .]"
2515 puts $f "set geometry(topwidth) [winfo width .tf]"
2516 puts $f "set geometry(topheight) [winfo height .tf]"
2517 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2518 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2519 puts $f "set geometry(botwidth) [winfo width .bleft]"
2520 puts $f "set geometry(botheight) [winfo height .bleft]"
2522 puts -nonewline $f "set permviews {"
2523 for {set v 0} {$v < $nextviewnum} {incr v} {
2524 if {$viewperm($v)} {
2525 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2528 puts $f "}"
2529 close $f
2530 file rename -force "~/.gitk-new" "~/.gitk"
2532 set stuffsaved 1
2535 proc resizeclistpanes {win w} {
2536 global oldwidth
2537 if {[info exists oldwidth($win)]} {
2538 set s0 [$win sash coord 0]
2539 set s1 [$win sash coord 1]
2540 if {$w < 60} {
2541 set sash0 [expr {int($w/2 - 2)}]
2542 set sash1 [expr {int($w*5/6 - 2)}]
2543 } else {
2544 set factor [expr {1.0 * $w / $oldwidth($win)}]
2545 set sash0 [expr {int($factor * [lindex $s0 0])}]
2546 set sash1 [expr {int($factor * [lindex $s1 0])}]
2547 if {$sash0 < 30} {
2548 set sash0 30
2550 if {$sash1 < $sash0 + 20} {
2551 set sash1 [expr {$sash0 + 20}]
2553 if {$sash1 > $w - 10} {
2554 set sash1 [expr {$w - 10}]
2555 if {$sash0 > $sash1 - 20} {
2556 set sash0 [expr {$sash1 - 20}]
2560 $win sash place 0 $sash0 [lindex $s0 1]
2561 $win sash place 1 $sash1 [lindex $s1 1]
2563 set oldwidth($win) $w
2566 proc resizecdetpanes {win w} {
2567 global oldwidth
2568 if {[info exists oldwidth($win)]} {
2569 set s0 [$win sash coord 0]
2570 if {$w < 60} {
2571 set sash0 [expr {int($w*3/4 - 2)}]
2572 } else {
2573 set factor [expr {1.0 * $w / $oldwidth($win)}]
2574 set sash0 [expr {int($factor * [lindex $s0 0])}]
2575 if {$sash0 < 45} {
2576 set sash0 45
2578 if {$sash0 > $w - 15} {
2579 set sash0 [expr {$w - 15}]
2582 $win sash place 0 $sash0 [lindex $s0 1]
2584 set oldwidth($win) $w
2587 proc allcanvs args {
2588 global canv canv2 canv3
2589 eval $canv $args
2590 eval $canv2 $args
2591 eval $canv3 $args
2594 proc bindall {event action} {
2595 global canv canv2 canv3
2596 bind $canv $event $action
2597 bind $canv2 $event $action
2598 bind $canv3 $event $action
2601 proc about {} {
2602 global uifont
2603 set w .about
2604 if {[winfo exists $w]} {
2605 raise $w
2606 return
2608 toplevel $w
2609 wm title $w [mc "About gitk"]
2610 make_transient $w .
2611 message $w.m -text [mc "
2612 Gitk - a commit viewer for git
2614 Copyright © 2005-2008 Paul Mackerras
2616 Use and redistribute under the terms of the GNU General Public License"] \
2617 -justify center -aspect 400 -border 2 -bg white -relief groove
2618 pack $w.m -side top -fill x -padx 2 -pady 2
2619 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2620 pack $w.ok -side bottom
2621 bind $w <Visibility> "focus $w.ok"
2622 bind $w <Key-Escape> "destroy $w"
2623 bind $w <Key-Return> "destroy $w"
2626 proc keys {} {
2627 set w .keys
2628 if {[winfo exists $w]} {
2629 raise $w
2630 return
2632 if {[tk windowingsystem] eq {aqua}} {
2633 set M1T Cmd
2634 } else {
2635 set M1T Ctrl
2637 toplevel $w
2638 wm title $w [mc "Gitk key bindings"]
2639 make_transient $w .
2640 message $w.m -text "
2641 [mc "Gitk key bindings:"]
2643 [mc "<%s-Q> Quit" $M1T]
2644 [mc "<Home> Move to first commit"]
2645 [mc "<End> Move to last commit"]
2646 [mc "<Up>, p, i Move up one commit"]
2647 [mc "<Down>, n, k Move down one commit"]
2648 [mc "<Left>, z, j Go back in history list"]
2649 [mc "<Right>, x, l Go forward in history list"]
2650 [mc "<PageUp> Move up one page in commit list"]
2651 [mc "<PageDown> Move down one page in commit list"]
2652 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2653 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2654 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2655 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2656 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2657 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2658 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2659 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2660 [mc "<Delete>, b Scroll diff view up one page"]
2661 [mc "<Backspace> Scroll diff view up one page"]
2662 [mc "<Space> Scroll diff view down one page"]
2663 [mc "u Scroll diff view up 18 lines"]
2664 [mc "d Scroll diff view down 18 lines"]
2665 [mc "<%s-F> Find" $M1T]
2666 [mc "<%s-G> Move to next find hit" $M1T]
2667 [mc "<Return> Move to next find hit"]
2668 [mc "/ Focus the search box"]
2669 [mc "? Move to previous find hit"]
2670 [mc "f Scroll diff view to next file"]
2671 [mc "<%s-S> Search for next hit in diff view" $M1T]
2672 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2673 [mc "<%s-KP+> Increase font size" $M1T]
2674 [mc "<%s-plus> Increase font size" $M1T]
2675 [mc "<%s-KP-> Decrease font size" $M1T]
2676 [mc "<%s-minus> Decrease font size" $M1T]
2677 [mc "<F5> Update"]
2679 -justify left -bg white -border 2 -relief groove
2680 pack $w.m -side top -fill both -padx 2 -pady 2
2681 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2682 bind $w <Key-Escape> [list destroy $w]
2683 pack $w.ok -side bottom
2684 bind $w <Visibility> "focus $w.ok"
2685 bind $w <Key-Escape> "destroy $w"
2686 bind $w <Key-Return> "destroy $w"
2689 # Procedures for manipulating the file list window at the
2690 # bottom right of the overall window.
2692 proc treeview {w l openlevs} {
2693 global treecontents treediropen treeheight treeparent treeindex
2695 set ix 0
2696 set treeindex() 0
2697 set lev 0
2698 set prefix {}
2699 set prefixend -1
2700 set prefendstack {}
2701 set htstack {}
2702 set ht 0
2703 set treecontents() {}
2704 $w conf -state normal
2705 foreach f $l {
2706 while {[string range $f 0 $prefixend] ne $prefix} {
2707 if {$lev <= $openlevs} {
2708 $w mark set e:$treeindex($prefix) "end -1c"
2709 $w mark gravity e:$treeindex($prefix) left
2711 set treeheight($prefix) $ht
2712 incr ht [lindex $htstack end]
2713 set htstack [lreplace $htstack end end]
2714 set prefixend [lindex $prefendstack end]
2715 set prefendstack [lreplace $prefendstack end end]
2716 set prefix [string range $prefix 0 $prefixend]
2717 incr lev -1
2719 set tail [string range $f [expr {$prefixend+1}] end]
2720 while {[set slash [string first "/" $tail]] >= 0} {
2721 lappend htstack $ht
2722 set ht 0
2723 lappend prefendstack $prefixend
2724 incr prefixend [expr {$slash + 1}]
2725 set d [string range $tail 0 $slash]
2726 lappend treecontents($prefix) $d
2727 set oldprefix $prefix
2728 append prefix $d
2729 set treecontents($prefix) {}
2730 set treeindex($prefix) [incr ix]
2731 set treeparent($prefix) $oldprefix
2732 set tail [string range $tail [expr {$slash+1}] end]
2733 if {$lev <= $openlevs} {
2734 set ht 1
2735 set treediropen($prefix) [expr {$lev < $openlevs}]
2736 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2737 $w mark set d:$ix "end -1c"
2738 $w mark gravity d:$ix left
2739 set str "\n"
2740 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2741 $w insert end $str
2742 $w image create end -align center -image $bm -padx 1 \
2743 -name a:$ix
2744 $w insert end $d [highlight_tag $prefix]
2745 $w mark set s:$ix "end -1c"
2746 $w mark gravity s:$ix left
2748 incr lev
2750 if {$tail ne {}} {
2751 if {$lev <= $openlevs} {
2752 incr ht
2753 set str "\n"
2754 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2755 $w insert end $str
2756 $w insert end $tail [highlight_tag $f]
2758 lappend treecontents($prefix) $tail
2761 while {$htstack ne {}} {
2762 set treeheight($prefix) $ht
2763 incr ht [lindex $htstack end]
2764 set htstack [lreplace $htstack end end]
2765 set prefixend [lindex $prefendstack end]
2766 set prefendstack [lreplace $prefendstack end end]
2767 set prefix [string range $prefix 0 $prefixend]
2769 $w conf -state disabled
2772 proc linetoelt {l} {
2773 global treeheight treecontents
2775 set y 2
2776 set prefix {}
2777 while {1} {
2778 foreach e $treecontents($prefix) {
2779 if {$y == $l} {
2780 return "$prefix$e"
2782 set n 1
2783 if {[string index $e end] eq "/"} {
2784 set n $treeheight($prefix$e)
2785 if {$y + $n > $l} {
2786 append prefix $e
2787 incr y
2788 break
2791 incr y $n
2796 proc highlight_tree {y prefix} {
2797 global treeheight treecontents cflist
2799 foreach e $treecontents($prefix) {
2800 set path $prefix$e
2801 if {[highlight_tag $path] ne {}} {
2802 $cflist tag add bold $y.0 "$y.0 lineend"
2804 incr y
2805 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2806 set y [highlight_tree $y $path]
2809 return $y
2812 proc treeclosedir {w dir} {
2813 global treediropen treeheight treeparent treeindex
2815 set ix $treeindex($dir)
2816 $w conf -state normal
2817 $w delete s:$ix e:$ix
2818 set treediropen($dir) 0
2819 $w image configure a:$ix -image tri-rt
2820 $w conf -state disabled
2821 set n [expr {1 - $treeheight($dir)}]
2822 while {$dir ne {}} {
2823 incr treeheight($dir) $n
2824 set dir $treeparent($dir)
2828 proc treeopendir {w dir} {
2829 global treediropen treeheight treeparent treecontents treeindex
2831 set ix $treeindex($dir)
2832 $w conf -state normal
2833 $w image configure a:$ix -image tri-dn
2834 $w mark set e:$ix s:$ix
2835 $w mark gravity e:$ix right
2836 set lev 0
2837 set str "\n"
2838 set n [llength $treecontents($dir)]
2839 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2840 incr lev
2841 append str "\t"
2842 incr treeheight($x) $n
2844 foreach e $treecontents($dir) {
2845 set de $dir$e
2846 if {[string index $e end] eq "/"} {
2847 set iy $treeindex($de)
2848 $w mark set d:$iy e:$ix
2849 $w mark gravity d:$iy left
2850 $w insert e:$ix $str
2851 set treediropen($de) 0
2852 $w image create e:$ix -align center -image tri-rt -padx 1 \
2853 -name a:$iy
2854 $w insert e:$ix $e [highlight_tag $de]
2855 $w mark set s:$iy e:$ix
2856 $w mark gravity s:$iy left
2857 set treeheight($de) 1
2858 } else {
2859 $w insert e:$ix $str
2860 $w insert e:$ix $e [highlight_tag $de]
2863 $w mark gravity e:$ix right
2864 $w conf -state disabled
2865 set treediropen($dir) 1
2866 set top [lindex [split [$w index @0,0] .] 0]
2867 set ht [$w cget -height]
2868 set l [lindex [split [$w index s:$ix] .] 0]
2869 if {$l < $top} {
2870 $w yview $l.0
2871 } elseif {$l + $n + 1 > $top + $ht} {
2872 set top [expr {$l + $n + 2 - $ht}]
2873 if {$l < $top} {
2874 set top $l
2876 $w yview $top.0
2880 proc treeclick {w x y} {
2881 global treediropen cmitmode ctext cflist cflist_top
2883 if {$cmitmode ne "tree"} return
2884 if {![info exists cflist_top]} return
2885 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2886 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2887 $cflist tag add highlight $l.0 "$l.0 lineend"
2888 set cflist_top $l
2889 if {$l == 1} {
2890 $ctext yview 1.0
2891 return
2893 set e [linetoelt $l]
2894 if {[string index $e end] ne "/"} {
2895 showfile $e
2896 } elseif {$treediropen($e)} {
2897 treeclosedir $w $e
2898 } else {
2899 treeopendir $w $e
2903 proc setfilelist {id} {
2904 global treefilelist cflist jump_to_here
2906 treeview $cflist $treefilelist($id) 0
2907 if {$jump_to_here ne {}} {
2908 set f [lindex $jump_to_here 0]
2909 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2910 showfile $f
2915 image create bitmap tri-rt -background black -foreground blue -data {
2916 #define tri-rt_width 13
2917 #define tri-rt_height 13
2918 static unsigned char tri-rt_bits[] = {
2919 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2920 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2921 0x00, 0x00};
2922 } -maskdata {
2923 #define tri-rt-mask_width 13
2924 #define tri-rt-mask_height 13
2925 static unsigned char tri-rt-mask_bits[] = {
2926 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2927 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2928 0x08, 0x00};
2930 image create bitmap tri-dn -background black -foreground blue -data {
2931 #define tri-dn_width 13
2932 #define tri-dn_height 13
2933 static unsigned char tri-dn_bits[] = {
2934 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2935 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2936 0x00, 0x00};
2937 } -maskdata {
2938 #define tri-dn-mask_width 13
2939 #define tri-dn-mask_height 13
2940 static unsigned char tri-dn-mask_bits[] = {
2941 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2942 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2943 0x00, 0x00};
2946 image create bitmap reficon-T -background black -foreground yellow -data {
2947 #define tagicon_width 13
2948 #define tagicon_height 9
2949 static unsigned char tagicon_bits[] = {
2950 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2951 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2952 } -maskdata {
2953 #define tagicon-mask_width 13
2954 #define tagicon-mask_height 9
2955 static unsigned char tagicon-mask_bits[] = {
2956 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2957 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2959 set rectdata {
2960 #define headicon_width 13
2961 #define headicon_height 9
2962 static unsigned char headicon_bits[] = {
2963 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2964 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2966 set rectmask {
2967 #define headicon-mask_width 13
2968 #define headicon-mask_height 9
2969 static unsigned char headicon-mask_bits[] = {
2970 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2971 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2973 image create bitmap reficon-H -background black -foreground green \
2974 -data $rectdata -maskdata $rectmask
2975 image create bitmap reficon-o -background black -foreground "#ddddff" \
2976 -data $rectdata -maskdata $rectmask
2978 proc init_flist {first} {
2979 global cflist cflist_top difffilestart
2981 $cflist conf -state normal
2982 $cflist delete 0.0 end
2983 if {$first ne {}} {
2984 $cflist insert end $first
2985 set cflist_top 1
2986 $cflist tag add highlight 1.0 "1.0 lineend"
2987 } else {
2988 catch {unset cflist_top}
2990 $cflist conf -state disabled
2991 set difffilestart {}
2994 proc highlight_tag {f} {
2995 global highlight_paths
2997 foreach p $highlight_paths {
2998 if {[string match $p $f]} {
2999 return "bold"
3002 return {}
3005 proc highlight_filelist {} {
3006 global cmitmode cflist
3008 $cflist conf -state normal
3009 if {$cmitmode ne "tree"} {
3010 set end [lindex [split [$cflist index end] .] 0]
3011 for {set l 2} {$l < $end} {incr l} {
3012 set line [$cflist get $l.0 "$l.0 lineend"]
3013 if {[highlight_tag $line] ne {}} {
3014 $cflist tag add bold $l.0 "$l.0 lineend"
3017 } else {
3018 highlight_tree 2 {}
3020 $cflist conf -state disabled
3023 proc unhighlight_filelist {} {
3024 global cflist
3026 $cflist conf -state normal
3027 $cflist tag remove bold 1.0 end
3028 $cflist conf -state disabled
3031 proc add_flist {fl} {
3032 global cflist
3034 $cflist conf -state normal
3035 foreach f $fl {
3036 $cflist insert end "\n"
3037 $cflist insert end $f [highlight_tag $f]
3039 $cflist conf -state disabled
3042 proc sel_flist {w x y} {
3043 global ctext difffilestart cflist cflist_top cmitmode
3045 if {$cmitmode eq "tree"} return
3046 if {![info exists cflist_top]} return
3047 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3048 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3049 $cflist tag add highlight $l.0 "$l.0 lineend"
3050 set cflist_top $l
3051 if {$l == 1} {
3052 $ctext yview 1.0
3053 } else {
3054 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3058 proc pop_flist_menu {w X Y x y} {
3059 global ctext cflist cmitmode flist_menu flist_menu_file
3060 global treediffs diffids
3062 stopfinding
3063 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3064 if {$l <= 1} return
3065 if {$cmitmode eq "tree"} {
3066 set e [linetoelt $l]
3067 if {[string index $e end] eq "/"} return
3068 } else {
3069 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3071 set flist_menu_file $e
3072 set xdiffstate "normal"
3073 if {$cmitmode eq "tree"} {
3074 set xdiffstate "disabled"
3076 # Disable "External diff" item in tree mode
3077 $flist_menu entryconf 2 -state $xdiffstate
3078 tk_popup $flist_menu $X $Y
3081 proc find_ctext_fileinfo {line} {
3082 global ctext_file_names ctext_file_lines
3084 set ok [bsearch $ctext_file_lines $line]
3085 set tline [lindex $ctext_file_lines $ok]
3087 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3088 return {}
3089 } else {
3090 return [list [lindex $ctext_file_names $ok] $tline]
3094 proc pop_diff_menu {w X Y x y} {
3095 global ctext diff_menu flist_menu_file
3096 global diff_menu_txtpos diff_menu_line
3097 global diff_menu_filebase
3099 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3100 set diff_menu_line [lindex $diff_menu_txtpos 0]
3101 # don't pop up the menu on hunk-separator or file-separator lines
3102 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3103 return
3105 stopfinding
3106 set f [find_ctext_fileinfo $diff_menu_line]
3107 if {$f eq {}} return
3108 set flist_menu_file [lindex $f 0]
3109 set diff_menu_filebase [lindex $f 1]
3110 tk_popup $diff_menu $X $Y
3113 proc flist_hl {only} {
3114 global flist_menu_file findstring gdttype
3116 set x [shellquote $flist_menu_file]
3117 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3118 set findstring $x
3119 } else {
3120 append findstring " " $x
3122 set gdttype [mc "touching paths:"]
3125 proc save_file_from_commit {filename output what} {
3126 global nullfile
3128 if {[catch {exec git show $filename -- > $output} err]} {
3129 if {[string match "fatal: bad revision *" $err]} {
3130 return $nullfile
3132 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3133 return {}
3135 return $output
3138 proc external_diff_get_one_file {diffid filename diffdir} {
3139 global nullid nullid2 nullfile
3140 global gitdir
3142 if {$diffid == $nullid} {
3143 set difffile [file join [file dirname $gitdir] $filename]
3144 if {[file exists $difffile]} {
3145 return $difffile
3147 return $nullfile
3149 if {$diffid == $nullid2} {
3150 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3151 return [save_file_from_commit :$filename $difffile index]
3153 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3154 return [save_file_from_commit $diffid:$filename $difffile \
3155 "revision $diffid"]
3158 proc external_diff {} {
3159 global gitktmpdir nullid nullid2
3160 global flist_menu_file
3161 global diffids
3162 global diffnum
3163 global gitdir extdifftool
3165 if {[llength $diffids] == 1} {
3166 # no reference commit given
3167 set diffidto [lindex $diffids 0]
3168 if {$diffidto eq $nullid} {
3169 # diffing working copy with index
3170 set diffidfrom $nullid2
3171 } elseif {$diffidto eq $nullid2} {
3172 # diffing index with HEAD
3173 set diffidfrom "HEAD"
3174 } else {
3175 # use first parent commit
3176 global parentlist selectedline
3177 set diffidfrom [lindex $parentlist $selectedline 0]
3179 } else {
3180 set diffidfrom [lindex $diffids 0]
3181 set diffidto [lindex $diffids 1]
3184 # make sure that several diffs wont collide
3185 if {![info exists gitktmpdir]} {
3186 set gitktmpdir [file join [file dirname $gitdir] \
3187 [format ".gitk-tmp.%s" [pid]]]
3188 if {[catch {file mkdir $gitktmpdir} err]} {
3189 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3190 unset gitktmpdir
3191 return
3193 set diffnum 0
3195 incr diffnum
3196 set diffdir [file join $gitktmpdir $diffnum]
3197 if {[catch {file mkdir $diffdir} err]} {
3198 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3199 return
3202 # gather files to diff
3203 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3204 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3206 if {$difffromfile ne {} && $difftofile ne {}} {
3207 set cmd [concat | [shellsplit $extdifftool] \
3208 [list $difffromfile $difftofile]]
3209 if {[catch {set fl [open $cmd r]} err]} {
3210 file delete -force $diffdir
3211 error_popup "$extdifftool: [mc "command failed:"] $err"
3212 } else {
3213 fconfigure $fl -blocking 0
3214 filerun $fl [list delete_at_eof $fl $diffdir]
3219 proc find_hunk_blamespec {base line} {
3220 global ctext
3222 # Find and parse the hunk header
3223 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3224 if {$s_lix eq {}} return
3226 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3227 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3228 s_line old_specs osz osz1 new_line nsz]} {
3229 return
3232 # base lines for the parents
3233 set base_lines [list $new_line]
3234 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3235 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3236 old_spec old_line osz]} {
3237 return
3239 lappend base_lines $old_line
3242 # Now scan the lines to determine offset within the hunk
3243 set max_parent [expr {[llength $base_lines]-2}]
3244 set dline 0
3245 set s_lno [lindex [split $s_lix "."] 0]
3247 # Determine if the line is removed
3248 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3249 if {[string match {[-+ ]*} $chunk]} {
3250 set removed_idx [string first "-" $chunk]
3251 # Choose a parent index
3252 if {$removed_idx >= 0} {
3253 set parent $removed_idx
3254 } else {
3255 set unchanged_idx [string first " " $chunk]
3256 if {$unchanged_idx >= 0} {
3257 set parent $unchanged_idx
3258 } else {
3259 # blame the current commit
3260 set parent -1
3263 # then count other lines that belong to it
3264 for {set i $line} {[incr i -1] > $s_lno} {} {
3265 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3266 # Determine if the line is removed
3267 set removed_idx [string first "-" $chunk]
3268 if {$parent >= 0} {
3269 set code [string index $chunk $parent]
3270 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3271 incr dline
3273 } else {
3274 if {$removed_idx < 0} {
3275 incr dline
3279 incr parent
3280 } else {
3281 set parent 0
3284 incr dline [lindex $base_lines $parent]
3285 return [list $parent $dline]
3288 proc external_blame_diff {} {
3289 global currentid cmitmode
3290 global diff_menu_txtpos diff_menu_line
3291 global diff_menu_filebase flist_menu_file
3293 if {$cmitmode eq "tree"} {
3294 set parent_idx 0
3295 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3296 } else {
3297 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3298 if {$hinfo ne {}} {
3299 set parent_idx [lindex $hinfo 0]
3300 set line [lindex $hinfo 1]
3301 } else {
3302 set parent_idx 0
3303 set line 0
3307 external_blame $parent_idx $line
3310 # Find the SHA1 ID of the blob for file $fname in the index
3311 # at stage 0 or 2
3312 proc index_sha1 {fname} {
3313 set f [open [list | git ls-files -s $fname] r]
3314 while {[gets $f line] >= 0} {
3315 set info [lindex [split $line "\t"] 0]
3316 set stage [lindex $info 2]
3317 if {$stage eq "0" || $stage eq "2"} {
3318 close $f
3319 return [lindex $info 1]
3322 close $f
3323 return {}
3326 # Turn an absolute path into one relative to the current directory
3327 proc make_relative {f} {
3328 set elts [file split $f]
3329 set here [file split [pwd]]
3330 set ei 0
3331 set hi 0
3332 set res {}
3333 foreach d $here {
3334 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3335 lappend res ".."
3336 } else {
3337 incr ei
3339 incr hi
3341 set elts [concat $res [lrange $elts $ei end]]
3342 return [eval file join $elts]
3345 proc external_blame {parent_idx {line {}}} {
3346 global flist_menu_file gitdir
3347 global nullid nullid2
3348 global parentlist selectedline currentid
3350 if {$parent_idx > 0} {
3351 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3352 } else {
3353 set base_commit $currentid
3356 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3357 error_popup [mc "No such commit"]
3358 return
3361 set cmdline [list git gui blame]
3362 if {$line ne {} && $line > 1} {
3363 lappend cmdline "--line=$line"
3365 set f [file join [file dirname $gitdir] $flist_menu_file]
3366 # Unfortunately it seems git gui blame doesn't like
3367 # being given an absolute path...
3368 set f [make_relative $f]
3369 lappend cmdline $base_commit $f
3370 if {[catch {eval exec $cmdline &} err]} {
3371 error_popup "[mc "git gui blame: command failed:"] $err"
3375 proc show_line_source {} {
3376 global cmitmode currentid parents curview blamestuff blameinst
3377 global diff_menu_line diff_menu_filebase flist_menu_file
3378 global nullid nullid2 gitdir
3380 set from_index {}
3381 if {$cmitmode eq "tree"} {
3382 set id $currentid
3383 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3384 } else {
3385 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3386 if {$h eq {}} return
3387 set pi [lindex $h 0]
3388 if {$pi == 0} {
3389 mark_ctext_line $diff_menu_line
3390 return
3392 incr pi -1
3393 if {$currentid eq $nullid} {
3394 if {$pi > 0} {
3395 # must be a merge in progress...
3396 if {[catch {
3397 # get the last line from .git/MERGE_HEAD
3398 set f [open [file join $gitdir MERGE_HEAD] r]
3399 set id [lindex [split [read $f] "\n"] end-1]
3400 close $f
3401 } err]} {
3402 error_popup [mc "Couldn't read merge head: %s" $err]
3403 return
3405 } elseif {$parents($curview,$currentid) eq $nullid2} {
3406 # need to do the blame from the index
3407 if {[catch {
3408 set from_index [index_sha1 $flist_menu_file]
3409 } err]} {
3410 error_popup [mc "Error reading index: %s" $err]
3411 return
3413 } else {
3414 set id $parents($curview,$currentid)
3416 } else {
3417 set id [lindex $parents($curview,$currentid) $pi]
3419 set line [lindex $h 1]
3421 set blameargs {}
3422 if {$from_index ne {}} {
3423 lappend blameargs | git cat-file blob $from_index
3425 lappend blameargs | git blame -p -L$line,+1
3426 if {$from_index ne {}} {
3427 lappend blameargs --contents -
3428 } else {
3429 lappend blameargs $id
3431 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3432 if {[catch {
3433 set f [open $blameargs r]
3434 } err]} {
3435 error_popup [mc "Couldn't start git blame: %s" $err]
3436 return
3438 nowbusy blaming [mc "Searching"]
3439 fconfigure $f -blocking 0
3440 set i [reg_instance $f]
3441 set blamestuff($i) {}
3442 set blameinst $i
3443 filerun $f [list read_line_source $f $i]
3446 proc stopblaming {} {
3447 global blameinst
3449 if {[info exists blameinst]} {
3450 stop_instance $blameinst
3451 unset blameinst
3452 notbusy blaming
3456 proc read_line_source {fd inst} {
3457 global blamestuff curview commfd blameinst nullid nullid2
3459 while {[gets $fd line] >= 0} {
3460 lappend blamestuff($inst) $line
3462 if {![eof $fd]} {
3463 return 1
3465 unset commfd($inst)
3466 unset blameinst
3467 notbusy blaming
3468 fconfigure $fd -blocking 1
3469 if {[catch {close $fd} err]} {
3470 error_popup [mc "Error running git blame: %s" $err]
3471 return 0
3474 set fname {}
3475 set line [split [lindex $blamestuff($inst) 0] " "]
3476 set id [lindex $line 0]
3477 set lnum [lindex $line 1]
3478 if {[string length $id] == 40 && [string is xdigit $id] &&
3479 [string is digit -strict $lnum]} {
3480 # look for "filename" line
3481 foreach l $blamestuff($inst) {
3482 if {[string match "filename *" $l]} {
3483 set fname [string range $l 9 end]
3484 break
3488 if {$fname ne {}} {
3489 # all looks good, select it
3490 if {$id eq $nullid} {
3491 # blame uses all-zeroes to mean not committed,
3492 # which would mean a change in the index
3493 set id $nullid2
3495 if {[commitinview $id $curview]} {
3496 selectline [rowofcommit $id] 1 [list $fname $lnum]
3497 } else {
3498 error_popup [mc "That line comes from commit %s, \
3499 which is not in this view" [shortids $id]]
3501 } else {
3502 puts "oops couldn't parse git blame output"
3504 return 0
3507 # delete $dir when we see eof on $f (presumably because the child has exited)
3508 proc delete_at_eof {f dir} {
3509 while {[gets $f line] >= 0} {}
3510 if {[eof $f]} {
3511 if {[catch {close $f} err]} {
3512 error_popup "[mc "External diff viewer failed:"] $err"
3514 file delete -force $dir
3515 return 0
3517 return 1
3520 # Functions for adding and removing shell-type quoting
3522 proc shellquote {str} {
3523 if {![string match "*\['\"\\ \t]*" $str]} {
3524 return $str
3526 if {![string match "*\['\"\\]*" $str]} {
3527 return "\"$str\""
3529 if {![string match "*'*" $str]} {
3530 return "'$str'"
3532 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3535 proc shellarglist {l} {
3536 set str {}
3537 foreach a $l {
3538 if {$str ne {}} {
3539 append str " "
3541 append str [shellquote $a]
3543 return $str
3546 proc shelldequote {str} {
3547 set ret {}
3548 set used -1
3549 while {1} {
3550 incr used
3551 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3552 append ret [string range $str $used end]
3553 set used [string length $str]
3554 break
3556 set first [lindex $first 0]
3557 set ch [string index $str $first]
3558 if {$first > $used} {
3559 append ret [string range $str $used [expr {$first - 1}]]
3560 set used $first
3562 if {$ch eq " " || $ch eq "\t"} break
3563 incr used
3564 if {$ch eq "'"} {
3565 set first [string first "'" $str $used]
3566 if {$first < 0} {
3567 error "unmatched single-quote"
3569 append ret [string range $str $used [expr {$first - 1}]]
3570 set used $first
3571 continue
3573 if {$ch eq "\\"} {
3574 if {$used >= [string length $str]} {
3575 error "trailing backslash"
3577 append ret [string index $str $used]
3578 continue
3580 # here ch == "\""
3581 while {1} {
3582 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3583 error "unmatched double-quote"
3585 set first [lindex $first 0]
3586 set ch [string index $str $first]
3587 if {$first > $used} {
3588 append ret [string range $str $used [expr {$first - 1}]]
3589 set used $first
3591 if {$ch eq "\""} break
3592 incr used
3593 append ret [string index $str $used]
3594 incr used
3597 return [list $used $ret]
3600 proc shellsplit {str} {
3601 set l {}
3602 while {1} {
3603 set str [string trimleft $str]
3604 if {$str eq {}} break
3605 set dq [shelldequote $str]
3606 set n [lindex $dq 0]
3607 set word [lindex $dq 1]
3608 set str [string range $str $n end]
3609 lappend l $word
3611 return $l
3614 # Code to implement multiple views
3616 proc newview {ishighlight} {
3617 global nextviewnum newviewname newishighlight
3618 global revtreeargs viewargscmd newviewopts curview
3620 set newishighlight $ishighlight
3621 set top .gitkview
3622 if {[winfo exists $top]} {
3623 raise $top
3624 return
3626 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3627 set newviewopts($nextviewnum,perm) 0
3628 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3629 decode_view_opts $nextviewnum $revtreeargs
3630 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3633 set known_view_options {
3634 {perm b . {} {mc "Remember this view"}}
3635 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3636 {all b * "--all" {mc "Use all refs"}}
3637 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3638 {lright b . "--left-right" {mc "Mark branch sides"}}
3639 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3640 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3641 {limit t10 + "--max-count=*" {mc "Max count:"}}
3642 {skip t10 . "--skip=*" {mc "Skip:"}}
3643 {first b . "--first-parent" {mc "Limit to first parent"}}
3644 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3647 proc encode_view_opts {n} {
3648 global known_view_options newviewopts
3650 set rargs [list]
3651 foreach opt $known_view_options {
3652 set patterns [lindex $opt 3]
3653 if {$patterns eq {}} continue
3654 set pattern [lindex $patterns 0]
3656 set val $newviewopts($n,[lindex $opt 0])
3658 if {[lindex $opt 1] eq "b"} {
3659 if {$val} {
3660 lappend rargs $pattern
3662 } else {
3663 set val [string trim $val]
3664 if {$val ne {}} {
3665 set pfix [string range $pattern 0 end-1]
3666 lappend rargs $pfix$val
3670 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3673 proc decode_view_opts {n view_args} {
3674 global known_view_options newviewopts
3676 foreach opt $known_view_options {
3677 if {[lindex $opt 1] eq "b"} {
3678 set val 0
3679 } else {
3680 set val {}
3682 set newviewopts($n,[lindex $opt 0]) $val
3684 set oargs [list]
3685 foreach arg $view_args {
3686 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3687 && ![info exists found(limit)]} {
3688 set newviewopts($n,limit) $cnt
3689 set found(limit) 1
3690 continue
3692 catch { unset val }
3693 foreach opt $known_view_options {
3694 set id [lindex $opt 0]
3695 if {[info exists found($id)]} continue
3696 foreach pattern [lindex $opt 3] {
3697 if {![string match $pattern $arg]} continue
3698 if {[lindex $opt 1] ne "b"} {
3699 set size [string length $pattern]
3700 set val [string range $arg [expr {$size-1}] end]
3701 } else {
3702 set val 1
3704 set newviewopts($n,$id) $val
3705 set found($id) 1
3706 break
3708 if {[info exists val]} break
3710 if {[info exists val]} continue
3711 lappend oargs $arg
3713 set newviewopts($n,args) [shellarglist $oargs]
3716 proc edit_or_newview {} {
3717 global curview
3719 if {$curview > 0} {
3720 editview
3721 } else {
3722 newview 0
3726 proc editview {} {
3727 global curview
3728 global viewname viewperm newviewname newviewopts
3729 global viewargs viewargscmd
3731 set top .gitkvedit-$curview
3732 if {[winfo exists $top]} {
3733 raise $top
3734 return
3736 set newviewname($curview) $viewname($curview)
3737 set newviewopts($curview,perm) $viewperm($curview)
3738 set newviewopts($curview,cmd) $viewargscmd($curview)
3739 decode_view_opts $curview $viewargs($curview)
3740 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3743 proc vieweditor {top n title} {
3744 global newviewname newviewopts viewfiles bgcolor
3745 global known_view_options
3747 toplevel $top
3748 wm title $top $title
3749 make_transient $top .
3751 # View name
3752 frame $top.nfr
3753 label $top.nl -text [mc "Name"]
3754 entry $top.name -width 20 -textvariable newviewname($n)
3755 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3756 pack $top.nl -in $top.nfr -side left -padx {0 30}
3757 pack $top.name -in $top.nfr -side left
3759 # View options
3760 set cframe $top.nfr
3761 set cexpand 0
3762 set cnt 0
3763 foreach opt $known_view_options {
3764 set id [lindex $opt 0]
3765 set type [lindex $opt 1]
3766 set flags [lindex $opt 2]
3767 set title [eval [lindex $opt 4]]
3768 set lxpad 0
3770 if {$flags eq "+" || $flags eq "*"} {
3771 set cframe $top.fr$cnt
3772 incr cnt
3773 frame $cframe
3774 pack $cframe -in $top -fill x -pady 3 -padx 3
3775 set cexpand [expr {$flags eq "*"}]
3776 } else {
3777 set lxpad 5
3780 if {$type eq "b"} {
3781 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3782 pack $cframe.c_$id -in $cframe -side left \
3783 -padx [list $lxpad 0] -expand $cexpand -anchor w
3784 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3785 message $cframe.l_$id -aspect 1500 -text $title
3786 entry $cframe.e_$id -width $sz -background $bgcolor \
3787 -textvariable newviewopts($n,$id)
3788 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3789 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3790 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3791 message $cframe.l_$id -aspect 1500 -text $title
3792 entry $cframe.e_$id -width $sz -background $bgcolor \
3793 -textvariable newviewopts($n,$id)
3794 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3795 pack $cframe.e_$id -in $cframe -side top -fill x
3799 # Path list
3800 message $top.l -aspect 1500 \
3801 -text [mc "Enter files and directories to include, one per line:"]
3802 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3803 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3804 if {[info exists viewfiles($n)]} {
3805 foreach f $viewfiles($n) {
3806 $top.t insert end $f
3807 $top.t insert end "\n"
3809 $top.t delete {end - 1c} end
3810 $top.t mark set insert 0.0
3812 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3813 frame $top.buts
3814 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3815 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3816 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3817 bind $top <Control-Return> [list newviewok $top $n]
3818 bind $top <F5> [list newviewok $top $n 1]
3819 bind $top <Escape> [list destroy $top]
3820 grid $top.buts.ok $top.buts.apply $top.buts.can
3821 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3822 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3823 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3824 pack $top.buts -in $top -side top -fill x
3825 focus $top.t
3828 proc doviewmenu {m first cmd op argv} {
3829 set nmenu [$m index end]
3830 for {set i $first} {$i <= $nmenu} {incr i} {
3831 if {[$m entrycget $i -command] eq $cmd} {
3832 eval $m $op $i $argv
3833 break
3838 proc allviewmenus {n op args} {
3839 # global viewhlmenu
3841 doviewmenu .bar.view 5 [list showview $n] $op $args
3842 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3845 proc newviewok {top n {apply 0}} {
3846 global nextviewnum newviewperm newviewname newishighlight
3847 global viewname viewfiles viewperm selectedview curview
3848 global viewargs viewargscmd newviewopts viewhlmenu
3850 if {[catch {
3851 set newargs [encode_view_opts $n]
3852 } err]} {
3853 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3854 return
3856 set files {}
3857 foreach f [split [$top.t get 0.0 end] "\n"] {
3858 set ft [string trim $f]
3859 if {$ft ne {}} {
3860 lappend files $ft
3863 if {![info exists viewfiles($n)]} {
3864 # creating a new view
3865 incr nextviewnum
3866 set viewname($n) $newviewname($n)
3867 set viewperm($n) $newviewopts($n,perm)
3868 set viewfiles($n) $files
3869 set viewargs($n) $newargs
3870 set viewargscmd($n) $newviewopts($n,cmd)
3871 addviewmenu $n
3872 if {!$newishighlight} {
3873 run showview $n
3874 } else {
3875 run addvhighlight $n
3877 } else {
3878 # editing an existing view
3879 set viewperm($n) $newviewopts($n,perm)
3880 if {$newviewname($n) ne $viewname($n)} {
3881 set viewname($n) $newviewname($n)
3882 doviewmenu .bar.view 5 [list showview $n] \
3883 entryconf [list -label $viewname($n)]
3884 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3885 # entryconf [list -label $viewname($n) -value $viewname($n)]
3887 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3888 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3889 set viewfiles($n) $files
3890 set viewargs($n) $newargs
3891 set viewargscmd($n) $newviewopts($n,cmd)
3892 if {$curview == $n} {
3893 run reloadcommits
3897 if {$apply} return
3898 catch {destroy $top}
3901 proc delview {} {
3902 global curview viewperm hlview selectedhlview
3904 if {$curview == 0} return
3905 if {[info exists hlview] && $hlview == $curview} {
3906 set selectedhlview [mc "None"]
3907 unset hlview
3909 allviewmenus $curview delete
3910 set viewperm($curview) 0
3911 showview 0
3914 proc addviewmenu {n} {
3915 global viewname viewhlmenu
3917 .bar.view add radiobutton -label $viewname($n) \
3918 -command [list showview $n] -variable selectedview -value $n
3919 #$viewhlmenu add radiobutton -label $viewname($n) \
3920 # -command [list addvhighlight $n] -variable selectedhlview
3923 proc showview {n} {
3924 global curview cached_commitrow ordertok
3925 global displayorder parentlist rowidlist rowisopt rowfinal
3926 global colormap rowtextx nextcolor canvxmax
3927 global numcommits viewcomplete
3928 global selectedline currentid canv canvy0
3929 global treediffs
3930 global pending_select mainheadid
3931 global commitidx
3932 global selectedview
3933 global hlview selectedhlview commitinterest
3935 if {$n == $curview} return
3936 set selid {}
3937 set ymax [lindex [$canv cget -scrollregion] 3]
3938 set span [$canv yview]
3939 set ytop [expr {[lindex $span 0] * $ymax}]
3940 set ybot [expr {[lindex $span 1] * $ymax}]
3941 set yscreen [expr {($ybot - $ytop) / 2}]
3942 if {$selectedline ne {}} {
3943 set selid $currentid
3944 set y [yc $selectedline]
3945 if {$ytop < $y && $y < $ybot} {
3946 set yscreen [expr {$y - $ytop}]
3948 } elseif {[info exists pending_select]} {
3949 set selid $pending_select
3950 unset pending_select
3952 unselectline
3953 normalline
3954 catch {unset treediffs}
3955 clear_display
3956 if {[info exists hlview] && $hlview == $n} {
3957 unset hlview
3958 set selectedhlview [mc "None"]
3960 catch {unset commitinterest}
3961 catch {unset cached_commitrow}
3962 catch {unset ordertok}
3964 set curview $n
3965 set selectedview $n
3966 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3967 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3969 run refill_reflist
3970 if {![info exists viewcomplete($n)]} {
3971 getcommits $selid
3972 return
3975 set displayorder {}
3976 set parentlist {}
3977 set rowidlist {}
3978 set rowisopt {}
3979 set rowfinal {}
3980 set numcommits $commitidx($n)
3982 catch {unset colormap}
3983 catch {unset rowtextx}
3984 set nextcolor 0
3985 set canvxmax [$canv cget -width]
3986 set curview $n
3987 set row 0
3988 setcanvscroll
3989 set yf 0
3990 set row {}
3991 if {$selid ne {} && [commitinview $selid $n]} {
3992 set row [rowofcommit $selid]
3993 # try to get the selected row in the same position on the screen
3994 set ymax [lindex [$canv cget -scrollregion] 3]
3995 set ytop [expr {[yc $row] - $yscreen}]
3996 if {$ytop < 0} {
3997 set ytop 0
3999 set yf [expr {$ytop * 1.0 / $ymax}]
4001 allcanvs yview moveto $yf
4002 drawvisible
4003 if {$row ne {}} {
4004 selectline $row 0
4005 } elseif {!$viewcomplete($n)} {
4006 reset_pending_select $selid
4007 } else {
4008 reset_pending_select {}
4010 if {[commitinview $pending_select $curview]} {
4011 selectline [rowofcommit $pending_select] 1
4012 } else {
4013 set row [first_real_row]
4014 if {$row < $numcommits} {
4015 selectline $row 0
4019 if {!$viewcomplete($n)} {
4020 if {$numcommits == 0} {
4021 show_status [mc "Reading commits..."]
4023 } elseif {$numcommits == 0} {
4024 show_status [mc "No commits selected"]
4028 # Stuff relating to the highlighting facility
4030 proc ishighlighted {id} {
4031 global vhighlights fhighlights nhighlights rhighlights
4033 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4034 return $nhighlights($id)
4036 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4037 return $vhighlights($id)
4039 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4040 return $fhighlights($id)
4042 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4043 return $rhighlights($id)
4045 return 0
4048 proc bolden {id font} {
4049 global canv linehtag currentid boldids need_redisplay
4051 # need_redisplay = 1 means the display is stale and about to be redrawn
4052 if {$need_redisplay} return
4053 lappend boldids $id
4054 $canv itemconf $linehtag($id) -font $font
4055 if {[info exists currentid] && $id eq $currentid} {
4056 $canv delete secsel
4057 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4058 -outline {{}} -tags secsel \
4059 -fill [$canv cget -selectbackground]]
4060 $canv lower $t
4064 proc bolden_name {id font} {
4065 global canv2 linentag currentid boldnameids need_redisplay
4067 if {$need_redisplay} return
4068 lappend boldnameids $id
4069 $canv2 itemconf $linentag($id) -font $font
4070 if {[info exists currentid] && $id eq $currentid} {
4071 $canv2 delete secsel
4072 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4073 -outline {{}} -tags secsel \
4074 -fill [$canv2 cget -selectbackground]]
4075 $canv2 lower $t
4079 proc unbolden {} {
4080 global boldids
4082 set stillbold {}
4083 foreach id $boldids {
4084 if {![ishighlighted $id]} {
4085 bolden $id mainfont
4086 } else {
4087 lappend stillbold $id
4090 set boldids $stillbold
4093 proc addvhighlight {n} {
4094 global hlview viewcomplete curview vhl_done commitidx
4096 if {[info exists hlview]} {
4097 delvhighlight
4099 set hlview $n
4100 if {$n != $curview && ![info exists viewcomplete($n)]} {
4101 start_rev_list $n
4103 set vhl_done $commitidx($hlview)
4104 if {$vhl_done > 0} {
4105 drawvisible
4109 proc delvhighlight {} {
4110 global hlview vhighlights
4112 if {![info exists hlview]} return
4113 unset hlview
4114 catch {unset vhighlights}
4115 unbolden
4118 proc vhighlightmore {} {
4119 global hlview vhl_done commitidx vhighlights curview
4121 set max $commitidx($hlview)
4122 set vr [visiblerows]
4123 set r0 [lindex $vr 0]
4124 set r1 [lindex $vr 1]
4125 for {set i $vhl_done} {$i < $max} {incr i} {
4126 set id [commitonrow $i $hlview]
4127 if {[commitinview $id $curview]} {
4128 set row [rowofcommit $id]
4129 if {$r0 <= $row && $row <= $r1} {
4130 if {![highlighted $row]} {
4131 bolden $id mainfontbold
4133 set vhighlights($id) 1
4137 set vhl_done $max
4138 return 0
4141 proc askvhighlight {row id} {
4142 global hlview vhighlights iddrawn
4144 if {[commitinview $id $hlview]} {
4145 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4146 bolden $id mainfontbold
4148 set vhighlights($id) 1
4149 } else {
4150 set vhighlights($id) 0
4154 proc hfiles_change {} {
4155 global highlight_files filehighlight fhighlights fh_serial
4156 global highlight_paths
4158 if {[info exists filehighlight]} {
4159 # delete previous highlights
4160 catch {close $filehighlight}
4161 unset filehighlight
4162 catch {unset fhighlights}
4163 unbolden
4164 unhighlight_filelist
4166 set highlight_paths {}
4167 after cancel do_file_hl $fh_serial
4168 incr fh_serial
4169 if {$highlight_files ne {}} {
4170 after 300 do_file_hl $fh_serial
4174 proc gdttype_change {name ix op} {
4175 global gdttype highlight_files findstring findpattern
4177 stopfinding
4178 if {$findstring ne {}} {
4179 if {$gdttype eq [mc "containing:"]} {
4180 if {$highlight_files ne {}} {
4181 set highlight_files {}
4182 hfiles_change
4184 findcom_change
4185 } else {
4186 if {$findpattern ne {}} {
4187 set findpattern {}
4188 findcom_change
4190 set highlight_files $findstring
4191 hfiles_change
4193 drawvisible
4195 # enable/disable findtype/findloc menus too
4198 proc find_change {name ix op} {
4199 global gdttype findstring highlight_files
4201 stopfinding
4202 if {$gdttype eq [mc "containing:"]} {
4203 findcom_change
4204 } else {
4205 if {$highlight_files ne $findstring} {
4206 set highlight_files $findstring
4207 hfiles_change
4210 drawvisible
4213 proc findcom_change args {
4214 global nhighlights boldnameids
4215 global findpattern findtype findstring gdttype
4217 stopfinding
4218 # delete previous highlights, if any
4219 foreach id $boldnameids {
4220 bolden_name $id mainfont
4222 set boldnameids {}
4223 catch {unset nhighlights}
4224 unbolden
4225 unmarkmatches
4226 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4227 set findpattern {}
4228 } elseif {$findtype eq [mc "Regexp"]} {
4229 set findpattern $findstring
4230 } else {
4231 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4232 $findstring]
4233 set findpattern "*$e*"
4237 proc makepatterns {l} {
4238 set ret {}
4239 foreach e $l {
4240 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4241 if {[string index $ee end] eq "/"} {
4242 lappend ret "$ee*"
4243 } else {
4244 lappend ret $ee
4245 lappend ret "$ee/*"
4248 return $ret
4251 proc do_file_hl {serial} {
4252 global highlight_files filehighlight highlight_paths gdttype fhl_list
4254 if {$gdttype eq [mc "touching paths:"]} {
4255 if {[catch {set paths [shellsplit $highlight_files]}]} return
4256 set highlight_paths [makepatterns $paths]
4257 highlight_filelist
4258 set gdtargs [concat -- $paths]
4259 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4260 set gdtargs [list "-S$highlight_files"]
4261 } else {
4262 # must be "containing:", i.e. we're searching commit info
4263 return
4265 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4266 set filehighlight [open $cmd r+]
4267 fconfigure $filehighlight -blocking 0
4268 filerun $filehighlight readfhighlight
4269 set fhl_list {}
4270 drawvisible
4271 flushhighlights
4274 proc flushhighlights {} {
4275 global filehighlight fhl_list
4277 if {[info exists filehighlight]} {
4278 lappend fhl_list {}
4279 puts $filehighlight ""
4280 flush $filehighlight
4284 proc askfilehighlight {row id} {
4285 global filehighlight fhighlights fhl_list
4287 lappend fhl_list $id
4288 set fhighlights($id) -1
4289 puts $filehighlight $id
4292 proc readfhighlight {} {
4293 global filehighlight fhighlights curview iddrawn
4294 global fhl_list find_dirn
4296 if {![info exists filehighlight]} {
4297 return 0
4299 set nr 0
4300 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4301 set line [string trim $line]
4302 set i [lsearch -exact $fhl_list $line]
4303 if {$i < 0} continue
4304 for {set j 0} {$j < $i} {incr j} {
4305 set id [lindex $fhl_list $j]
4306 set fhighlights($id) 0
4308 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4309 if {$line eq {}} continue
4310 if {![commitinview $line $curview]} continue
4311 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4312 bolden $line mainfontbold
4314 set fhighlights($line) 1
4316 if {[eof $filehighlight]} {
4317 # strange...
4318 puts "oops, git diff-tree died"
4319 catch {close $filehighlight}
4320 unset filehighlight
4321 return 0
4323 if {[info exists find_dirn]} {
4324 run findmore
4326 return 1
4329 proc doesmatch {f} {
4330 global findtype findpattern
4332 if {$findtype eq [mc "Regexp"]} {
4333 return [regexp $findpattern $f]
4334 } elseif {$findtype eq [mc "IgnCase"]} {
4335 return [string match -nocase $findpattern $f]
4336 } else {
4337 return [string match $findpattern $f]
4341 proc askfindhighlight {row id} {
4342 global nhighlights commitinfo iddrawn
4343 global findloc
4344 global markingmatches
4346 if {![info exists commitinfo($id)]} {
4347 getcommit $id
4349 set info $commitinfo($id)
4350 set isbold 0
4351 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4352 foreach f $info ty $fldtypes {
4353 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4354 [doesmatch $f]} {
4355 if {$ty eq [mc "Author"]} {
4356 set isbold 2
4357 break
4359 set isbold 1
4362 if {$isbold && [info exists iddrawn($id)]} {
4363 if {![ishighlighted $id]} {
4364 bolden $id mainfontbold
4365 if {$isbold > 1} {
4366 bolden_name $id mainfontbold
4369 if {$markingmatches} {
4370 markrowmatches $row $id
4373 set nhighlights($id) $isbold
4376 proc markrowmatches {row id} {
4377 global canv canv2 linehtag linentag commitinfo findloc
4379 set headline [lindex $commitinfo($id) 0]
4380 set author [lindex $commitinfo($id) 1]
4381 $canv delete match$row
4382 $canv2 delete match$row
4383 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4384 set m [findmatches $headline]
4385 if {$m ne {}} {
4386 markmatches $canv $row $headline $linehtag($id) $m \
4387 [$canv itemcget $linehtag($id) -font] $row
4390 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4391 set m [findmatches $author]
4392 if {$m ne {}} {
4393 markmatches $canv2 $row $author $linentag($id) $m \
4394 [$canv2 itemcget $linentag($id) -font] $row
4399 proc vrel_change {name ix op} {
4400 global highlight_related
4402 rhighlight_none
4403 if {$highlight_related ne [mc "None"]} {
4404 run drawvisible
4408 # prepare for testing whether commits are descendents or ancestors of a
4409 proc rhighlight_sel {a} {
4410 global descendent desc_todo ancestor anc_todo
4411 global highlight_related
4413 catch {unset descendent}
4414 set desc_todo [list $a]
4415 catch {unset ancestor}
4416 set anc_todo [list $a]
4417 if {$highlight_related ne [mc "None"]} {
4418 rhighlight_none
4419 run drawvisible
4423 proc rhighlight_none {} {
4424 global rhighlights
4426 catch {unset rhighlights}
4427 unbolden
4430 proc is_descendent {a} {
4431 global curview children descendent desc_todo
4433 set v $curview
4434 set la [rowofcommit $a]
4435 set todo $desc_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 {[rowofcommit $do] < $la} {
4441 lappend leftover $do
4442 continue
4444 foreach nk $children($v,$do) {
4445 if {![info exists descendent($nk)]} {
4446 set descendent($nk) 1
4447 lappend todo $nk
4448 if {$nk eq $a} {
4449 set done 1
4453 if {$done} {
4454 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4455 return
4458 set descendent($a) 0
4459 set desc_todo $leftover
4462 proc is_ancestor {a} {
4463 global curview parents ancestor anc_todo
4465 set v $curview
4466 set la [rowofcommit $a]
4467 set todo $anc_todo
4468 set leftover {}
4469 set done 0
4470 for {set i 0} {$i < [llength $todo]} {incr i} {
4471 set do [lindex $todo $i]
4472 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4473 lappend leftover $do
4474 continue
4476 foreach np $parents($v,$do) {
4477 if {![info exists ancestor($np)]} {
4478 set ancestor($np) 1
4479 lappend todo $np
4480 if {$np eq $a} {
4481 set done 1
4485 if {$done} {
4486 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4487 return
4490 set ancestor($a) 0
4491 set anc_todo $leftover
4494 proc askrelhighlight {row id} {
4495 global descendent highlight_related iddrawn rhighlights
4496 global selectedline ancestor
4498 if {$selectedline eq {}} return
4499 set isbold 0
4500 if {$highlight_related eq [mc "Descendant"] ||
4501 $highlight_related eq [mc "Not descendant"]} {
4502 if {![info exists descendent($id)]} {
4503 is_descendent $id
4505 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4506 set isbold 1
4508 } elseif {$highlight_related eq [mc "Ancestor"] ||
4509 $highlight_related eq [mc "Not ancestor"]} {
4510 if {![info exists ancestor($id)]} {
4511 is_ancestor $id
4513 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4514 set isbold 1
4517 if {[info exists iddrawn($id)]} {
4518 if {$isbold && ![ishighlighted $id]} {
4519 bolden $id mainfontbold
4522 set rhighlights($id) $isbold
4525 # Graph layout functions
4527 proc shortids {ids} {
4528 set res {}
4529 foreach id $ids {
4530 if {[llength $id] > 1} {
4531 lappend res [shortids $id]
4532 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4533 lappend res [string range $id 0 7]
4534 } else {
4535 lappend res $id
4538 return $res
4541 proc ntimes {n o} {
4542 set ret {}
4543 set o [list $o]
4544 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4545 if {($n & $mask) != 0} {
4546 set ret [concat $ret $o]
4548 set o [concat $o $o]
4550 return $ret
4553 proc ordertoken {id} {
4554 global ordertok curview varcid varcstart varctok curview parents children
4555 global nullid nullid2
4557 if {[info exists ordertok($id)]} {
4558 return $ordertok($id)
4560 set origid $id
4561 set todo {}
4562 while {1} {
4563 if {[info exists varcid($curview,$id)]} {
4564 set a $varcid($curview,$id)
4565 set p [lindex $varcstart($curview) $a]
4566 } else {
4567 set p [lindex $children($curview,$id) 0]
4569 if {[info exists ordertok($p)]} {
4570 set tok $ordertok($p)
4571 break
4573 set id [first_real_child $curview,$p]
4574 if {$id eq {}} {
4575 # it's a root
4576 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4577 break
4579 if {[llength $parents($curview,$id)] == 1} {
4580 lappend todo [list $p {}]
4581 } else {
4582 set j [lsearch -exact $parents($curview,$id) $p]
4583 if {$j < 0} {
4584 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4586 lappend todo [list $p [strrep $j]]
4589 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4590 set p [lindex $todo $i 0]
4591 append tok [lindex $todo $i 1]
4592 set ordertok($p) $tok
4594 set ordertok($origid) $tok
4595 return $tok
4598 # Work out where id should go in idlist so that order-token
4599 # values increase from left to right
4600 proc idcol {idlist id {i 0}} {
4601 set t [ordertoken $id]
4602 if {$i < 0} {
4603 set i 0
4605 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4606 if {$i > [llength $idlist]} {
4607 set i [llength $idlist]
4609 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4610 incr i
4611 } else {
4612 if {$t > [ordertoken [lindex $idlist $i]]} {
4613 while {[incr i] < [llength $idlist] &&
4614 $t >= [ordertoken [lindex $idlist $i]]} {}
4617 return $i
4620 proc initlayout {} {
4621 global rowidlist rowisopt rowfinal displayorder parentlist
4622 global numcommits canvxmax canv
4623 global nextcolor
4624 global colormap rowtextx
4626 set numcommits 0
4627 set displayorder {}
4628 set parentlist {}
4629 set nextcolor 0
4630 set rowidlist {}
4631 set rowisopt {}
4632 set rowfinal {}
4633 set canvxmax [$canv cget -width]
4634 catch {unset colormap}
4635 catch {unset rowtextx}
4636 setcanvscroll
4639 proc setcanvscroll {} {
4640 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4641 global lastscrollset lastscrollrows
4643 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4644 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4645 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4646 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4647 set lastscrollset [clock clicks -milliseconds]
4648 set lastscrollrows $numcommits
4651 proc visiblerows {} {
4652 global canv numcommits linespc
4654 set ymax [lindex [$canv cget -scrollregion] 3]
4655 if {$ymax eq {} || $ymax == 0} return
4656 set f [$canv yview]
4657 set y0 [expr {int([lindex $f 0] * $ymax)}]
4658 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4659 if {$r0 < 0} {
4660 set r0 0
4662 set y1 [expr {int([lindex $f 1] * $ymax)}]
4663 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4664 if {$r1 >= $numcommits} {
4665 set r1 [expr {$numcommits - 1}]
4667 return [list $r0 $r1]
4670 proc layoutmore {} {
4671 global commitidx viewcomplete curview
4672 global numcommits pending_select curview
4673 global lastscrollset lastscrollrows
4675 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4676 [clock clicks -milliseconds] - $lastscrollset > 500} {
4677 setcanvscroll
4679 if {[info exists pending_select] &&
4680 [commitinview $pending_select $curview]} {
4681 update
4682 selectline [rowofcommit $pending_select] 1
4684 drawvisible
4687 # With path limiting, we mightn't get the actual HEAD commit,
4688 # so ask git rev-list what is the first ancestor of HEAD that
4689 # touches a file in the path limit.
4690 proc get_viewmainhead {view} {
4691 global viewmainheadid vfilelimit viewinstances mainheadid
4693 catch {
4694 set rfd [open [concat | git rev-list -1 $mainheadid \
4695 -- $vfilelimit($view)] r]
4696 set j [reg_instance $rfd]
4697 lappend viewinstances($view) $j
4698 fconfigure $rfd -blocking 0
4699 filerun $rfd [list getviewhead $rfd $j $view]
4700 set viewmainheadid($curview) {}
4704 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4705 proc getviewhead {fd inst view} {
4706 global viewmainheadid commfd curview viewinstances showlocalchanges
4708 set id {}
4709 if {[gets $fd line] < 0} {
4710 if {![eof $fd]} {
4711 return 1
4713 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4714 set id $line
4716 set viewmainheadid($view) $id
4717 close $fd
4718 unset commfd($inst)
4719 set i [lsearch -exact $viewinstances($view) $inst]
4720 if {$i >= 0} {
4721 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4723 if {$showlocalchanges && $id ne {} && $view == $curview} {
4724 doshowlocalchanges
4726 return 0
4729 proc doshowlocalchanges {} {
4730 global curview viewmainheadid
4732 if {$viewmainheadid($curview) eq {}} return
4733 if {[commitinview $viewmainheadid($curview) $curview]} {
4734 dodiffindex
4735 } else {
4736 interestedin $viewmainheadid($curview) dodiffindex
4740 proc dohidelocalchanges {} {
4741 global nullid nullid2 lserial curview
4743 if {[commitinview $nullid $curview]} {
4744 removefakerow $nullid
4746 if {[commitinview $nullid2 $curview]} {
4747 removefakerow $nullid2
4749 incr lserial
4752 # spawn off a process to do git diff-index --cached HEAD
4753 proc dodiffindex {} {
4754 global lserial showlocalchanges vfilelimit curview
4755 global isworktree
4757 if {!$showlocalchanges || !$isworktree} return
4758 incr lserial
4759 set cmd "|git diff-index --cached HEAD"
4760 if {$vfilelimit($curview) ne {}} {
4761 set cmd [concat $cmd -- $vfilelimit($curview)]
4763 set fd [open $cmd r]
4764 fconfigure $fd -blocking 0
4765 set i [reg_instance $fd]
4766 filerun $fd [list readdiffindex $fd $lserial $i]
4769 proc readdiffindex {fd serial inst} {
4770 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4771 global vfilelimit
4773 set isdiff 1
4774 if {[gets $fd line] < 0} {
4775 if {![eof $fd]} {
4776 return 1
4778 set isdiff 0
4780 # we only need to see one line and we don't really care what it says...
4781 stop_instance $inst
4783 if {$serial != $lserial} {
4784 return 0
4787 # now see if there are any local changes not checked in to the index
4788 set cmd "|git diff-files"
4789 if {$vfilelimit($curview) ne {}} {
4790 set cmd [concat $cmd -- $vfilelimit($curview)]
4792 set fd [open $cmd r]
4793 fconfigure $fd -blocking 0
4794 set i [reg_instance $fd]
4795 filerun $fd [list readdifffiles $fd $serial $i]
4797 if {$isdiff && ![commitinview $nullid2 $curview]} {
4798 # add the line for the changes in the index to the graph
4799 set hl [mc "Local changes checked in to index but not committed"]
4800 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4801 set commitdata($nullid2) "\n $hl\n"
4802 if {[commitinview $nullid $curview]} {
4803 removefakerow $nullid
4805 insertfakerow $nullid2 $viewmainheadid($curview)
4806 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4807 if {[commitinview $nullid $curview]} {
4808 removefakerow $nullid
4810 removefakerow $nullid2
4812 return 0
4815 proc readdifffiles {fd serial inst} {
4816 global viewmainheadid nullid nullid2 curview
4817 global commitinfo commitdata lserial
4819 set isdiff 1
4820 if {[gets $fd line] < 0} {
4821 if {![eof $fd]} {
4822 return 1
4824 set isdiff 0
4826 # we only need to see one line and we don't really care what it says...
4827 stop_instance $inst
4829 if {$serial != $lserial} {
4830 return 0
4833 if {$isdiff && ![commitinview $nullid $curview]} {
4834 # add the line for the local diff to the graph
4835 set hl [mc "Local uncommitted changes, not checked in to index"]
4836 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4837 set commitdata($nullid) "\n $hl\n"
4838 if {[commitinview $nullid2 $curview]} {
4839 set p $nullid2
4840 } else {
4841 set p $viewmainheadid($curview)
4843 insertfakerow $nullid $p
4844 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4845 removefakerow $nullid
4847 return 0
4850 proc nextuse {id row} {
4851 global curview children
4853 if {[info exists children($curview,$id)]} {
4854 foreach kid $children($curview,$id) {
4855 if {![commitinview $kid $curview]} {
4856 return -1
4858 if {[rowofcommit $kid] > $row} {
4859 return [rowofcommit $kid]
4863 if {[commitinview $id $curview]} {
4864 return [rowofcommit $id]
4866 return -1
4869 proc prevuse {id row} {
4870 global curview children
4872 set ret -1
4873 if {[info exists children($curview,$id)]} {
4874 foreach kid $children($curview,$id) {
4875 if {![commitinview $kid $curview]} break
4876 if {[rowofcommit $kid] < $row} {
4877 set ret [rowofcommit $kid]
4881 return $ret
4884 proc make_idlist {row} {
4885 global displayorder parentlist uparrowlen downarrowlen mingaplen
4886 global commitidx curview children
4888 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4889 if {$r < 0} {
4890 set r 0
4892 set ra [expr {$row - $downarrowlen}]
4893 if {$ra < 0} {
4894 set ra 0
4896 set rb [expr {$row + $uparrowlen}]
4897 if {$rb > $commitidx($curview)} {
4898 set rb $commitidx($curview)
4900 make_disporder $r [expr {$rb + 1}]
4901 set ids {}
4902 for {} {$r < $ra} {incr r} {
4903 set nextid [lindex $displayorder [expr {$r + 1}]]
4904 foreach p [lindex $parentlist $r] {
4905 if {$p eq $nextid} continue
4906 set rn [nextuse $p $r]
4907 if {$rn >= $row &&
4908 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4909 lappend ids [list [ordertoken $p] $p]
4913 for {} {$r < $row} {incr r} {
4914 set nextid [lindex $displayorder [expr {$r + 1}]]
4915 foreach p [lindex $parentlist $r] {
4916 if {$p eq $nextid} continue
4917 set rn [nextuse $p $r]
4918 if {$rn < 0 || $rn >= $row} {
4919 lappend ids [list [ordertoken $p] $p]
4923 set id [lindex $displayorder $row]
4924 lappend ids [list [ordertoken $id] $id]
4925 while {$r < $rb} {
4926 foreach p [lindex $parentlist $r] {
4927 set firstkid [lindex $children($curview,$p) 0]
4928 if {[rowofcommit $firstkid] < $row} {
4929 lappend ids [list [ordertoken $p] $p]
4932 incr r
4933 set id [lindex $displayorder $r]
4934 if {$id ne {}} {
4935 set firstkid [lindex $children($curview,$id) 0]
4936 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4937 lappend ids [list [ordertoken $id] $id]
4941 set idlist {}
4942 foreach idx [lsort -unique $ids] {
4943 lappend idlist [lindex $idx 1]
4945 return $idlist
4948 proc rowsequal {a b} {
4949 while {[set i [lsearch -exact $a {}]] >= 0} {
4950 set a [lreplace $a $i $i]
4952 while {[set i [lsearch -exact $b {}]] >= 0} {
4953 set b [lreplace $b $i $i]
4955 return [expr {$a eq $b}]
4958 proc makeupline {id row rend col} {
4959 global rowidlist uparrowlen downarrowlen mingaplen
4961 for {set r $rend} {1} {set r $rstart} {
4962 set rstart [prevuse $id $r]
4963 if {$rstart < 0} return
4964 if {$rstart < $row} break
4966 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4967 set rstart [expr {$rend - $uparrowlen - 1}]
4969 for {set r $rstart} {[incr r] <= $row} {} {
4970 set idlist [lindex $rowidlist $r]
4971 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4972 set col [idcol $idlist $id $col]
4973 lset rowidlist $r [linsert $idlist $col $id]
4974 changedrow $r
4979 proc layoutrows {row endrow} {
4980 global rowidlist rowisopt rowfinal displayorder
4981 global uparrowlen downarrowlen maxwidth mingaplen
4982 global children parentlist
4983 global commitidx viewcomplete curview
4985 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4986 set idlist {}
4987 if {$row > 0} {
4988 set rm1 [expr {$row - 1}]
4989 foreach id [lindex $rowidlist $rm1] {
4990 if {$id ne {}} {
4991 lappend idlist $id
4994 set final [lindex $rowfinal $rm1]
4996 for {} {$row < $endrow} {incr row} {
4997 set rm1 [expr {$row - 1}]
4998 if {$rm1 < 0 || $idlist eq {}} {
4999 set idlist [make_idlist $row]
5000 set final 1
5001 } else {
5002 set id [lindex $displayorder $rm1]
5003 set col [lsearch -exact $idlist $id]
5004 set idlist [lreplace $idlist $col $col]
5005 foreach p [lindex $parentlist $rm1] {
5006 if {[lsearch -exact $idlist $p] < 0} {
5007 set col [idcol $idlist $p $col]
5008 set idlist [linsert $idlist $col $p]
5009 # if not the first child, we have to insert a line going up
5010 if {$id ne [lindex $children($curview,$p) 0]} {
5011 makeupline $p $rm1 $row $col
5015 set id [lindex $displayorder $row]
5016 if {$row > $downarrowlen} {
5017 set termrow [expr {$row - $downarrowlen - 1}]
5018 foreach p [lindex $parentlist $termrow] {
5019 set i [lsearch -exact $idlist $p]
5020 if {$i < 0} continue
5021 set nr [nextuse $p $termrow]
5022 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5023 set idlist [lreplace $idlist $i $i]
5027 set col [lsearch -exact $idlist $id]
5028 if {$col < 0} {
5029 set col [idcol $idlist $id]
5030 set idlist [linsert $idlist $col $id]
5031 if {$children($curview,$id) ne {}} {
5032 makeupline $id $rm1 $row $col
5035 set r [expr {$row + $uparrowlen - 1}]
5036 if {$r < $commitidx($curview)} {
5037 set x $col
5038 foreach p [lindex $parentlist $r] {
5039 if {[lsearch -exact $idlist $p] >= 0} continue
5040 set fk [lindex $children($curview,$p) 0]
5041 if {[rowofcommit $fk] < $row} {
5042 set x [idcol $idlist $p $x]
5043 set idlist [linsert $idlist $x $p]
5046 if {[incr r] < $commitidx($curview)} {
5047 set p [lindex $displayorder $r]
5048 if {[lsearch -exact $idlist $p] < 0} {
5049 set fk [lindex $children($curview,$p) 0]
5050 if {$fk ne {} && [rowofcommit $fk] < $row} {
5051 set x [idcol $idlist $p $x]
5052 set idlist [linsert $idlist $x $p]
5058 if {$final && !$viewcomplete($curview) &&
5059 $row + $uparrowlen + $mingaplen + $downarrowlen
5060 >= $commitidx($curview)} {
5061 set final 0
5063 set l [llength $rowidlist]
5064 if {$row == $l} {
5065 lappend rowidlist $idlist
5066 lappend rowisopt 0
5067 lappend rowfinal $final
5068 } elseif {$row < $l} {
5069 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5070 lset rowidlist $row $idlist
5071 changedrow $row
5073 lset rowfinal $row $final
5074 } else {
5075 set pad [ntimes [expr {$row - $l}] {}]
5076 set rowidlist [concat $rowidlist $pad]
5077 lappend rowidlist $idlist
5078 set rowfinal [concat $rowfinal $pad]
5079 lappend rowfinal $final
5080 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5083 return $row
5086 proc changedrow {row} {
5087 global displayorder iddrawn rowisopt need_redisplay
5089 set l [llength $rowisopt]
5090 if {$row < $l} {
5091 lset rowisopt $row 0
5092 if {$row + 1 < $l} {
5093 lset rowisopt [expr {$row + 1}] 0
5094 if {$row + 2 < $l} {
5095 lset rowisopt [expr {$row + 2}] 0
5099 set id [lindex $displayorder $row]
5100 if {[info exists iddrawn($id)]} {
5101 set need_redisplay 1
5105 proc insert_pad {row col npad} {
5106 global rowidlist
5108 set pad [ntimes $npad {}]
5109 set idlist [lindex $rowidlist $row]
5110 set bef [lrange $idlist 0 [expr {$col - 1}]]
5111 set aft [lrange $idlist $col end]
5112 set i [lsearch -exact $aft {}]
5113 if {$i > 0} {
5114 set aft [lreplace $aft $i $i]
5116 lset rowidlist $row [concat $bef $pad $aft]
5117 changedrow $row
5120 proc optimize_rows {row col endrow} {
5121 global rowidlist rowisopt displayorder curview children
5123 if {$row < 1} {
5124 set row 1
5126 for {} {$row < $endrow} {incr row; set col 0} {
5127 if {[lindex $rowisopt $row]} continue
5128 set haspad 0
5129 set y0 [expr {$row - 1}]
5130 set ym [expr {$row - 2}]
5131 set idlist [lindex $rowidlist $row]
5132 set previdlist [lindex $rowidlist $y0]
5133 if {$idlist eq {} || $previdlist eq {}} continue
5134 if {$ym >= 0} {
5135 set pprevidlist [lindex $rowidlist $ym]
5136 if {$pprevidlist eq {}} continue
5137 } else {
5138 set pprevidlist {}
5140 set x0 -1
5141 set xm -1
5142 for {} {$col < [llength $idlist]} {incr col} {
5143 set id [lindex $idlist $col]
5144 if {[lindex $previdlist $col] eq $id} continue
5145 if {$id eq {}} {
5146 set haspad 1
5147 continue
5149 set x0 [lsearch -exact $previdlist $id]
5150 if {$x0 < 0} continue
5151 set z [expr {$x0 - $col}]
5152 set isarrow 0
5153 set z0 {}
5154 if {$ym >= 0} {
5155 set xm [lsearch -exact $pprevidlist $id]
5156 if {$xm >= 0} {
5157 set z0 [expr {$xm - $x0}]
5160 if {$z0 eq {}} {
5161 # if row y0 is the first child of $id then it's not an arrow
5162 if {[lindex $children($curview,$id) 0] ne
5163 [lindex $displayorder $y0]} {
5164 set isarrow 1
5167 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5168 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5169 set isarrow 1
5171 # Looking at lines from this row to the previous row,
5172 # make them go straight up if they end in an arrow on
5173 # the previous row; otherwise make them go straight up
5174 # or at 45 degrees.
5175 if {$z < -1 || ($z < 0 && $isarrow)} {
5176 # Line currently goes left too much;
5177 # insert pads in the previous row, then optimize it
5178 set npad [expr {-1 - $z + $isarrow}]
5179 insert_pad $y0 $x0 $npad
5180 if {$y0 > 0} {
5181 optimize_rows $y0 $x0 $row
5183 set previdlist [lindex $rowidlist $y0]
5184 set x0 [lsearch -exact $previdlist $id]
5185 set z [expr {$x0 - $col}]
5186 if {$z0 ne {}} {
5187 set pprevidlist [lindex $rowidlist $ym]
5188 set xm [lsearch -exact $pprevidlist $id]
5189 set z0 [expr {$xm - $x0}]
5191 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5192 # Line currently goes right too much;
5193 # insert pads in this line
5194 set npad [expr {$z - 1 + $isarrow}]
5195 insert_pad $row $col $npad
5196 set idlist [lindex $rowidlist $row]
5197 incr col $npad
5198 set z [expr {$x0 - $col}]
5199 set haspad 1
5201 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5202 # this line links to its first child on row $row-2
5203 set id [lindex $displayorder $ym]
5204 set xc [lsearch -exact $pprevidlist $id]
5205 if {$xc >= 0} {
5206 set z0 [expr {$xc - $x0}]
5209 # avoid lines jigging left then immediately right
5210 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5211 insert_pad $y0 $x0 1
5212 incr x0
5213 optimize_rows $y0 $x0 $row
5214 set previdlist [lindex $rowidlist $y0]
5217 if {!$haspad} {
5218 # Find the first column that doesn't have a line going right
5219 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5220 set id [lindex $idlist $col]
5221 if {$id eq {}} break
5222 set x0 [lsearch -exact $previdlist $id]
5223 if {$x0 < 0} {
5224 # check if this is the link to the first child
5225 set kid [lindex $displayorder $y0]
5226 if {[lindex $children($curview,$id) 0] eq $kid} {
5227 # it is, work out offset to child
5228 set x0 [lsearch -exact $previdlist $kid]
5231 if {$x0 <= $col} break
5233 # Insert a pad at that column as long as it has a line and
5234 # isn't the last column
5235 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5236 set idlist [linsert $idlist $col {}]
5237 lset rowidlist $row $idlist
5238 changedrow $row
5244 proc xc {row col} {
5245 global canvx0 linespc
5246 return [expr {$canvx0 + $col * $linespc}]
5249 proc yc {row} {
5250 global canvy0 linespc
5251 return [expr {$canvy0 + $row * $linespc}]
5254 proc linewidth {id} {
5255 global thickerline lthickness
5257 set wid $lthickness
5258 if {[info exists thickerline] && $id eq $thickerline} {
5259 set wid [expr {2 * $lthickness}]
5261 return $wid
5264 proc rowranges {id} {
5265 global curview children uparrowlen downarrowlen
5266 global rowidlist
5268 set kids $children($curview,$id)
5269 if {$kids eq {}} {
5270 return {}
5272 set ret {}
5273 lappend kids $id
5274 foreach child $kids {
5275 if {![commitinview $child $curview]} break
5276 set row [rowofcommit $child]
5277 if {![info exists prev]} {
5278 lappend ret [expr {$row + 1}]
5279 } else {
5280 if {$row <= $prevrow} {
5281 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5283 # see if the line extends the whole way from prevrow to row
5284 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5285 [lsearch -exact [lindex $rowidlist \
5286 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5287 # it doesn't, see where it ends
5288 set r [expr {$prevrow + $downarrowlen}]
5289 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5290 while {[incr r -1] > $prevrow &&
5291 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5292 } else {
5293 while {[incr r] <= $row &&
5294 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5295 incr r -1
5297 lappend ret $r
5298 # see where it starts up again
5299 set r [expr {$row - $uparrowlen}]
5300 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5301 while {[incr r] < $row &&
5302 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5303 } else {
5304 while {[incr r -1] >= $prevrow &&
5305 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5306 incr r
5308 lappend ret $r
5311 if {$child eq $id} {
5312 lappend ret $row
5314 set prev $child
5315 set prevrow $row
5317 return $ret
5320 proc drawlineseg {id row endrow arrowlow} {
5321 global rowidlist displayorder iddrawn linesegs
5322 global canv colormap linespc curview maxlinelen parentlist
5324 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5325 set le [expr {$row + 1}]
5326 set arrowhigh 1
5327 while {1} {
5328 set c [lsearch -exact [lindex $rowidlist $le] $id]
5329 if {$c < 0} {
5330 incr le -1
5331 break
5333 lappend cols $c
5334 set x [lindex $displayorder $le]
5335 if {$x eq $id} {
5336 set arrowhigh 0
5337 break
5339 if {[info exists iddrawn($x)] || $le == $endrow} {
5340 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5341 if {$c >= 0} {
5342 lappend cols $c
5343 set arrowhigh 0
5345 break
5347 incr le
5349 if {$le <= $row} {
5350 return $row
5353 set lines {}
5354 set i 0
5355 set joinhigh 0
5356 if {[info exists linesegs($id)]} {
5357 set lines $linesegs($id)
5358 foreach li $lines {
5359 set r0 [lindex $li 0]
5360 if {$r0 > $row} {
5361 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5362 set joinhigh 1
5364 break
5366 incr i
5369 set joinlow 0
5370 if {$i > 0} {
5371 set li [lindex $lines [expr {$i-1}]]
5372 set r1 [lindex $li 1]
5373 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5374 set joinlow 1
5378 set x [lindex $cols [expr {$le - $row}]]
5379 set xp [lindex $cols [expr {$le - 1 - $row}]]
5380 set dir [expr {$xp - $x}]
5381 if {$joinhigh} {
5382 set ith [lindex $lines $i 2]
5383 set coords [$canv coords $ith]
5384 set ah [$canv itemcget $ith -arrow]
5385 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5386 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5387 if {$x2 ne {} && $x - $x2 == $dir} {
5388 set coords [lrange $coords 0 end-2]
5390 } else {
5391 set coords [list [xc $le $x] [yc $le]]
5393 if {$joinlow} {
5394 set itl [lindex $lines [expr {$i-1}] 2]
5395 set al [$canv itemcget $itl -arrow]
5396 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5397 } elseif {$arrowlow} {
5398 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5399 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5400 set arrowlow 0
5403 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5404 for {set y $le} {[incr y -1] > $row} {} {
5405 set x $xp
5406 set xp [lindex $cols [expr {$y - 1 - $row}]]
5407 set ndir [expr {$xp - $x}]
5408 if {$dir != $ndir || $xp < 0} {
5409 lappend coords [xc $y $x] [yc $y]
5411 set dir $ndir
5413 if {!$joinlow} {
5414 if {$xp < 0} {
5415 # join parent line to first child
5416 set ch [lindex $displayorder $row]
5417 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5418 if {$xc < 0} {
5419 puts "oops: drawlineseg: child $ch not on row $row"
5420 } elseif {$xc != $x} {
5421 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5422 set d [expr {int(0.5 * $linespc)}]
5423 set x1 [xc $row $x]
5424 if {$xc < $x} {
5425 set x2 [expr {$x1 - $d}]
5426 } else {
5427 set x2 [expr {$x1 + $d}]
5429 set y2 [yc $row]
5430 set y1 [expr {$y2 + $d}]
5431 lappend coords $x1 $y1 $x2 $y2
5432 } elseif {$xc < $x - 1} {
5433 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5434 } elseif {$xc > $x + 1} {
5435 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5437 set x $xc
5439 lappend coords [xc $row $x] [yc $row]
5440 } else {
5441 set xn [xc $row $xp]
5442 set yn [yc $row]
5443 lappend coords $xn $yn
5445 if {!$joinhigh} {
5446 assigncolor $id
5447 set t [$canv create line $coords -width [linewidth $id] \
5448 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5449 $canv lower $t
5450 bindline $t $id
5451 set lines [linsert $lines $i [list $row $le $t]]
5452 } else {
5453 $canv coords $ith $coords
5454 if {$arrow ne $ah} {
5455 $canv itemconf $ith -arrow $arrow
5457 lset lines $i 0 $row
5459 } else {
5460 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5461 set ndir [expr {$xo - $xp}]
5462 set clow [$canv coords $itl]
5463 if {$dir == $ndir} {
5464 set clow [lrange $clow 2 end]
5466 set coords [concat $coords $clow]
5467 if {!$joinhigh} {
5468 lset lines [expr {$i-1}] 1 $le
5469 } else {
5470 # coalesce two pieces
5471 $canv delete $ith
5472 set b [lindex $lines [expr {$i-1}] 0]
5473 set e [lindex $lines $i 1]
5474 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5476 $canv coords $itl $coords
5477 if {$arrow ne $al} {
5478 $canv itemconf $itl -arrow $arrow
5482 set linesegs($id) $lines
5483 return $le
5486 proc drawparentlinks {id row} {
5487 global rowidlist canv colormap curview parentlist
5488 global idpos linespc
5490 set rowids [lindex $rowidlist $row]
5491 set col [lsearch -exact $rowids $id]
5492 if {$col < 0} return
5493 set olds [lindex $parentlist $row]
5494 set row2 [expr {$row + 1}]
5495 set x [xc $row $col]
5496 set y [yc $row]
5497 set y2 [yc $row2]
5498 set d [expr {int(0.5 * $linespc)}]
5499 set ymid [expr {$y + $d}]
5500 set ids [lindex $rowidlist $row2]
5501 # rmx = right-most X coord used
5502 set rmx 0
5503 foreach p $olds {
5504 set i [lsearch -exact $ids $p]
5505 if {$i < 0} {
5506 puts "oops, parent $p of $id not in list"
5507 continue
5509 set x2 [xc $row2 $i]
5510 if {$x2 > $rmx} {
5511 set rmx $x2
5513 set j [lsearch -exact $rowids $p]
5514 if {$j < 0} {
5515 # drawlineseg will do this one for us
5516 continue
5518 assigncolor $p
5519 # should handle duplicated parents here...
5520 set coords [list $x $y]
5521 if {$i != $col} {
5522 # if attaching to a vertical segment, draw a smaller
5523 # slant for visual distinctness
5524 if {$i == $j} {
5525 if {$i < $col} {
5526 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5527 } else {
5528 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5530 } elseif {$i < $col && $i < $j} {
5531 # segment slants towards us already
5532 lappend coords [xc $row $j] $y
5533 } else {
5534 if {$i < $col - 1} {
5535 lappend coords [expr {$x2 + $linespc}] $y
5536 } elseif {$i > $col + 1} {
5537 lappend coords [expr {$x2 - $linespc}] $y
5539 lappend coords $x2 $y2
5541 } else {
5542 lappend coords $x2 $y2
5544 set t [$canv create line $coords -width [linewidth $p] \
5545 -fill $colormap($p) -tags lines.$p]
5546 $canv lower $t
5547 bindline $t $p
5549 if {$rmx > [lindex $idpos($id) 1]} {
5550 lset idpos($id) 1 $rmx
5551 redrawtags $id
5555 proc drawlines {id} {
5556 global canv
5558 $canv itemconf lines.$id -width [linewidth $id]
5561 proc drawcmittext {id row col} {
5562 global linespc canv canv2 canv3 fgcolor curview
5563 global cmitlisted commitinfo rowidlist parentlist
5564 global rowtextx idpos idtags idheads idotherrefs
5565 global linehtag linentag linedtag selectedline
5566 global canvxmax boldids boldnameids fgcolor
5567 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5569 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5570 set listed $cmitlisted($curview,$id)
5571 if {$id eq $nullid} {
5572 set ofill red
5573 } elseif {$id eq $nullid2} {
5574 set ofill green
5575 } elseif {$id eq $mainheadid} {
5576 set ofill yellow
5577 } else {
5578 set ofill [lindex $circlecolors $listed]
5580 set x [xc $row $col]
5581 set y [yc $row]
5582 set orad [expr {$linespc / 3}]
5583 if {$listed <= 2} {
5584 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5585 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5586 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5587 } elseif {$listed == 3} {
5588 # triangle pointing left for left-side commits
5589 set t [$canv create polygon \
5590 [expr {$x - $orad}] $y \
5591 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5592 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5593 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5594 } else {
5595 # triangle pointing right for right-side commits
5596 set t [$canv create polygon \
5597 [expr {$x + $orad - 1}] $y \
5598 [expr {$x - $orad}] [expr {$y - $orad}] \
5599 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5600 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5602 set circleitem($row) $t
5603 $canv raise $t
5604 $canv bind $t <1> {selcanvline {} %x %y}
5605 set rmx [llength [lindex $rowidlist $row]]
5606 set olds [lindex $parentlist $row]
5607 if {$olds ne {}} {
5608 set nextids [lindex $rowidlist [expr {$row + 1}]]
5609 foreach p $olds {
5610 set i [lsearch -exact $nextids $p]
5611 if {$i > $rmx} {
5612 set rmx $i
5616 set xt [xc $row $rmx]
5617 set rowtextx($row) $xt
5618 set idpos($id) [list $x $xt $y]
5619 if {[info exists idtags($id)] || [info exists idheads($id)]
5620 || [info exists idotherrefs($id)]} {
5621 set xt [drawtags $id $x $xt $y]
5623 set headline [lindex $commitinfo($id) 0]
5624 set name [lindex $commitinfo($id) 1]
5625 set date [lindex $commitinfo($id) 2]
5626 set date [formatdate $date]
5627 set font mainfont
5628 set nfont mainfont
5629 set isbold [ishighlighted $id]
5630 if {$isbold > 0} {
5631 lappend boldids $id
5632 set font mainfontbold
5633 if {$isbold > 1} {
5634 lappend boldnameids $id
5635 set nfont mainfontbold
5638 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5639 -text $headline -font $font -tags text]
5640 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5641 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5642 -text $name -font $nfont -tags text]
5643 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5644 -text $date -font mainfont -tags text]
5645 if {$selectedline == $row} {
5646 make_secsel $id
5648 set xr [expr {$xt + [font measure $font $headline]}]
5649 if {$xr > $canvxmax} {
5650 set canvxmax $xr
5651 setcanvscroll
5655 proc drawcmitrow {row} {
5656 global displayorder rowidlist nrows_drawn
5657 global iddrawn markingmatches
5658 global commitinfo numcommits
5659 global filehighlight fhighlights findpattern nhighlights
5660 global hlview vhighlights
5661 global highlight_related rhighlights
5663 if {$row >= $numcommits} return
5665 set id [lindex $displayorder $row]
5666 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5667 askvhighlight $row $id
5669 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5670 askfilehighlight $row $id
5672 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5673 askfindhighlight $row $id
5675 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5676 askrelhighlight $row $id
5678 if {![info exists iddrawn($id)]} {
5679 set col [lsearch -exact [lindex $rowidlist $row] $id]
5680 if {$col < 0} {
5681 puts "oops, row $row id $id not in list"
5682 return
5684 if {![info exists commitinfo($id)]} {
5685 getcommit $id
5687 assigncolor $id
5688 drawcmittext $id $row $col
5689 set iddrawn($id) 1
5690 incr nrows_drawn
5692 if {$markingmatches} {
5693 markrowmatches $row $id
5697 proc drawcommits {row {endrow {}}} {
5698 global numcommits iddrawn displayorder curview need_redisplay
5699 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5701 if {$row < 0} {
5702 set row 0
5704 if {$endrow eq {}} {
5705 set endrow $row
5707 if {$endrow >= $numcommits} {
5708 set endrow [expr {$numcommits - 1}]
5711 set rl1 [expr {$row - $downarrowlen - 3}]
5712 if {$rl1 < 0} {
5713 set rl1 0
5715 set ro1 [expr {$row - 3}]
5716 if {$ro1 < 0} {
5717 set ro1 0
5719 set r2 [expr {$endrow + $uparrowlen + 3}]
5720 if {$r2 > $numcommits} {
5721 set r2 $numcommits
5723 for {set r $rl1} {$r < $r2} {incr r} {
5724 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5725 if {$rl1 < $r} {
5726 layoutrows $rl1 $r
5728 set rl1 [expr {$r + 1}]
5731 if {$rl1 < $r} {
5732 layoutrows $rl1 $r
5734 optimize_rows $ro1 0 $r2
5735 if {$need_redisplay || $nrows_drawn > 2000} {
5736 clear_display
5739 # make the lines join to already-drawn rows either side
5740 set r [expr {$row - 1}]
5741 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5742 set r $row
5744 set er [expr {$endrow + 1}]
5745 if {$er >= $numcommits ||
5746 ![info exists iddrawn([lindex $displayorder $er])]} {
5747 set er $endrow
5749 for {} {$r <= $er} {incr r} {
5750 set id [lindex $displayorder $r]
5751 set wasdrawn [info exists iddrawn($id)]
5752 drawcmitrow $r
5753 if {$r == $er} break
5754 set nextid [lindex $displayorder [expr {$r + 1}]]
5755 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5756 drawparentlinks $id $r
5758 set rowids [lindex $rowidlist $r]
5759 foreach lid $rowids {
5760 if {$lid eq {}} continue
5761 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5762 if {$lid eq $id} {
5763 # see if this is the first child of any of its parents
5764 foreach p [lindex $parentlist $r] {
5765 if {[lsearch -exact $rowids $p] < 0} {
5766 # make this line extend up to the child
5767 set lineend($p) [drawlineseg $p $r $er 0]
5770 } else {
5771 set lineend($lid) [drawlineseg $lid $r $er 1]
5777 proc undolayout {row} {
5778 global uparrowlen mingaplen downarrowlen
5779 global rowidlist rowisopt rowfinal need_redisplay
5781 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5782 if {$r < 0} {
5783 set r 0
5785 if {[llength $rowidlist] > $r} {
5786 incr r -1
5787 set rowidlist [lrange $rowidlist 0 $r]
5788 set rowfinal [lrange $rowfinal 0 $r]
5789 set rowisopt [lrange $rowisopt 0 $r]
5790 set need_redisplay 1
5791 run drawvisible
5795 proc drawvisible {} {
5796 global canv linespc curview vrowmod selectedline targetrow targetid
5797 global need_redisplay cscroll numcommits
5799 set fs [$canv yview]
5800 set ymax [lindex [$canv cget -scrollregion] 3]
5801 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5802 set f0 [lindex $fs 0]
5803 set f1 [lindex $fs 1]
5804 set y0 [expr {int($f0 * $ymax)}]
5805 set y1 [expr {int($f1 * $ymax)}]
5807 if {[info exists targetid]} {
5808 if {[commitinview $targetid $curview]} {
5809 set r [rowofcommit $targetid]
5810 if {$r != $targetrow} {
5811 # Fix up the scrollregion and change the scrolling position
5812 # now that our target row has moved.
5813 set diff [expr {($r - $targetrow) * $linespc}]
5814 set targetrow $r
5815 setcanvscroll
5816 set ymax [lindex [$canv cget -scrollregion] 3]
5817 incr y0 $diff
5818 incr y1 $diff
5819 set f0 [expr {$y0 / $ymax}]
5820 set f1 [expr {$y1 / $ymax}]
5821 allcanvs yview moveto $f0
5822 $cscroll set $f0 $f1
5823 set need_redisplay 1
5825 } else {
5826 unset targetid
5830 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5831 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5832 if {$endrow >= $vrowmod($curview)} {
5833 update_arcrows $curview
5835 if {$selectedline ne {} &&
5836 $row <= $selectedline && $selectedline <= $endrow} {
5837 set targetrow $selectedline
5838 } elseif {[info exists targetid]} {
5839 set targetrow [expr {int(($row + $endrow) / 2)}]
5841 if {[info exists targetrow]} {
5842 if {$targetrow >= $numcommits} {
5843 set targetrow [expr {$numcommits - 1}]
5845 set targetid [commitonrow $targetrow]
5847 drawcommits $row $endrow
5850 proc clear_display {} {
5851 global iddrawn linesegs need_redisplay nrows_drawn
5852 global vhighlights fhighlights nhighlights rhighlights
5853 global linehtag linentag linedtag boldids boldnameids
5855 allcanvs delete all
5856 catch {unset iddrawn}
5857 catch {unset linesegs}
5858 catch {unset linehtag}
5859 catch {unset linentag}
5860 catch {unset linedtag}
5861 set boldids {}
5862 set boldnameids {}
5863 catch {unset vhighlights}
5864 catch {unset fhighlights}
5865 catch {unset nhighlights}
5866 catch {unset rhighlights}
5867 set need_redisplay 0
5868 set nrows_drawn 0
5871 proc findcrossings {id} {
5872 global rowidlist parentlist numcommits displayorder
5874 set cross {}
5875 set ccross {}
5876 foreach {s e} [rowranges $id] {
5877 if {$e >= $numcommits} {
5878 set e [expr {$numcommits - 1}]
5880 if {$e <= $s} continue
5881 for {set row $e} {[incr row -1] >= $s} {} {
5882 set x [lsearch -exact [lindex $rowidlist $row] $id]
5883 if {$x < 0} break
5884 set olds [lindex $parentlist $row]
5885 set kid [lindex $displayorder $row]
5886 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5887 if {$kidx < 0} continue
5888 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5889 foreach p $olds {
5890 set px [lsearch -exact $nextrow $p]
5891 if {$px < 0} continue
5892 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5893 if {[lsearch -exact $ccross $p] >= 0} continue
5894 if {$x == $px + ($kidx < $px? -1: 1)} {
5895 lappend ccross $p
5896 } elseif {[lsearch -exact $cross $p] < 0} {
5897 lappend cross $p
5903 return [concat $ccross {{}} $cross]
5906 proc assigncolor {id} {
5907 global colormap colors nextcolor
5908 global parents children children curview
5910 if {[info exists colormap($id)]} return
5911 set ncolors [llength $colors]
5912 if {[info exists children($curview,$id)]} {
5913 set kids $children($curview,$id)
5914 } else {
5915 set kids {}
5917 if {[llength $kids] == 1} {
5918 set child [lindex $kids 0]
5919 if {[info exists colormap($child)]
5920 && [llength $parents($curview,$child)] == 1} {
5921 set colormap($id) $colormap($child)
5922 return
5925 set badcolors {}
5926 set origbad {}
5927 foreach x [findcrossings $id] {
5928 if {$x eq {}} {
5929 # delimiter between corner crossings and other crossings
5930 if {[llength $badcolors] >= $ncolors - 1} break
5931 set origbad $badcolors
5933 if {[info exists colormap($x)]
5934 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5935 lappend badcolors $colormap($x)
5938 if {[llength $badcolors] >= $ncolors} {
5939 set badcolors $origbad
5941 set origbad $badcolors
5942 if {[llength $badcolors] < $ncolors - 1} {
5943 foreach child $kids {
5944 if {[info exists colormap($child)]
5945 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5946 lappend badcolors $colormap($child)
5948 foreach p $parents($curview,$child) {
5949 if {[info exists colormap($p)]
5950 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5951 lappend badcolors $colormap($p)
5955 if {[llength $badcolors] >= $ncolors} {
5956 set badcolors $origbad
5959 for {set i 0} {$i <= $ncolors} {incr i} {
5960 set c [lindex $colors $nextcolor]
5961 if {[incr nextcolor] >= $ncolors} {
5962 set nextcolor 0
5964 if {[lsearch -exact $badcolors $c]} break
5966 set colormap($id) $c
5969 proc bindline {t id} {
5970 global canv
5972 $canv bind $t <Enter> "lineenter %x %y $id"
5973 $canv bind $t <Motion> "linemotion %x %y $id"
5974 $canv bind $t <Leave> "lineleave $id"
5975 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5978 proc drawtags {id x xt y1} {
5979 global idtags idheads idotherrefs mainhead
5980 global linespc lthickness
5981 global canv rowtextx curview fgcolor bgcolor ctxbut
5983 set marks {}
5984 set ntags 0
5985 set nheads 0
5986 if {[info exists idtags($id)]} {
5987 set marks $idtags($id)
5988 set ntags [llength $marks]
5990 if {[info exists idheads($id)]} {
5991 set marks [concat $marks $idheads($id)]
5992 set nheads [llength $idheads($id)]
5994 if {[info exists idotherrefs($id)]} {
5995 set marks [concat $marks $idotherrefs($id)]
5997 if {$marks eq {}} {
5998 return $xt
6001 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6002 set yt [expr {$y1 - 0.5 * $linespc}]
6003 set yb [expr {$yt + $linespc - 1}]
6004 set xvals {}
6005 set wvals {}
6006 set i -1
6007 foreach tag $marks {
6008 incr i
6009 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6010 set wid [font measure mainfontbold $tag]
6011 } else {
6012 set wid [font measure mainfont $tag]
6014 lappend xvals $xt
6015 lappend wvals $wid
6016 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6018 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6019 -width $lthickness -fill black -tags tag.$id]
6020 $canv lower $t
6021 foreach tag $marks x $xvals wid $wvals {
6022 set xl [expr {$x + $delta}]
6023 set xr [expr {$x + $delta + $wid + $lthickness}]
6024 set font mainfont
6025 if {[incr ntags -1] >= 0} {
6026 # draw a tag
6027 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6028 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6029 -width 1 -outline black -fill yellow -tags tag.$id]
6030 $canv bind $t <1> [list showtag $tag 1]
6031 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6032 } else {
6033 # draw a head or other ref
6034 if {[incr nheads -1] >= 0} {
6035 set col green
6036 if {$tag eq $mainhead} {
6037 set font mainfontbold
6039 } else {
6040 set col "#ddddff"
6042 set xl [expr {$xl - $delta/2}]
6043 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6044 -width 1 -outline black -fill $col -tags tag.$id
6045 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6046 set rwid [font measure mainfont $remoteprefix]
6047 set xi [expr {$x + 1}]
6048 set yti [expr {$yt + 1}]
6049 set xri [expr {$x + $rwid}]
6050 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6051 -width 0 -fill "#ffddaa" -tags tag.$id
6054 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6055 -font $font -tags [list tag.$id text]]
6056 if {$ntags >= 0} {
6057 $canv bind $t <1> [list showtag $tag 1]
6058 } elseif {$nheads >= 0} {
6059 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6062 return $xt
6065 proc xcoord {i level ln} {
6066 global canvx0 xspc1 xspc2
6068 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6069 if {$i > 0 && $i == $level} {
6070 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6071 } elseif {$i > $level} {
6072 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6074 return $x
6077 proc show_status {msg} {
6078 global canv fgcolor
6080 clear_display
6081 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6082 -tags text -fill $fgcolor
6085 # Don't change the text pane cursor if it is currently the hand cursor,
6086 # showing that we are over a sha1 ID link.
6087 proc settextcursor {c} {
6088 global ctext curtextcursor
6090 if {[$ctext cget -cursor] == $curtextcursor} {
6091 $ctext config -cursor $c
6093 set curtextcursor $c
6096 proc nowbusy {what {name {}}} {
6097 global isbusy busyname statusw
6099 if {[array names isbusy] eq {}} {
6100 . config -cursor watch
6101 settextcursor watch
6103 set isbusy($what) 1
6104 set busyname($what) $name
6105 if {$name ne {}} {
6106 $statusw conf -text $name
6110 proc notbusy {what} {
6111 global isbusy maincursor textcursor busyname statusw
6113 catch {
6114 unset isbusy($what)
6115 if {$busyname($what) ne {} &&
6116 [$statusw cget -text] eq $busyname($what)} {
6117 $statusw conf -text {}
6120 if {[array names isbusy] eq {}} {
6121 . config -cursor $maincursor
6122 settextcursor $textcursor
6126 proc findmatches {f} {
6127 global findtype findstring
6128 if {$findtype == [mc "Regexp"]} {
6129 set matches [regexp -indices -all -inline $findstring $f]
6130 } else {
6131 set fs $findstring
6132 if {$findtype == [mc "IgnCase"]} {
6133 set f [string tolower $f]
6134 set fs [string tolower $fs]
6136 set matches {}
6137 set i 0
6138 set l [string length $fs]
6139 while {[set j [string first $fs $f $i]] >= 0} {
6140 lappend matches [list $j [expr {$j+$l-1}]]
6141 set i [expr {$j + $l}]
6144 return $matches
6147 proc dofind {{dirn 1} {wrap 1}} {
6148 global findstring findstartline findcurline selectedline numcommits
6149 global gdttype filehighlight fh_serial find_dirn findallowwrap
6151 if {[info exists find_dirn]} {
6152 if {$find_dirn == $dirn} return
6153 stopfinding
6155 focus .
6156 if {$findstring eq {} || $numcommits == 0} return
6157 if {$selectedline eq {}} {
6158 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6159 } else {
6160 set findstartline $selectedline
6162 set findcurline $findstartline
6163 nowbusy finding [mc "Searching"]
6164 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6165 after cancel do_file_hl $fh_serial
6166 do_file_hl $fh_serial
6168 set find_dirn $dirn
6169 set findallowwrap $wrap
6170 run findmore
6173 proc stopfinding {} {
6174 global find_dirn findcurline fprogcoord
6176 if {[info exists find_dirn]} {
6177 unset find_dirn
6178 unset findcurline
6179 notbusy finding
6180 set fprogcoord 0
6181 adjustprogress
6183 stopblaming
6186 proc findmore {} {
6187 global commitdata commitinfo numcommits findpattern findloc
6188 global findstartline findcurline findallowwrap
6189 global find_dirn gdttype fhighlights fprogcoord
6190 global curview varcorder vrownum varccommits vrowmod
6192 if {![info exists find_dirn]} {
6193 return 0
6195 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6196 set l $findcurline
6197 set moretodo 0
6198 if {$find_dirn > 0} {
6199 incr l
6200 if {$l >= $numcommits} {
6201 set l 0
6203 if {$l <= $findstartline} {
6204 set lim [expr {$findstartline + 1}]
6205 } else {
6206 set lim $numcommits
6207 set moretodo $findallowwrap
6209 } else {
6210 if {$l == 0} {
6211 set l $numcommits
6213 incr l -1
6214 if {$l >= $findstartline} {
6215 set lim [expr {$findstartline - 1}]
6216 } else {
6217 set lim -1
6218 set moretodo $findallowwrap
6221 set n [expr {($lim - $l) * $find_dirn}]
6222 if {$n > 500} {
6223 set n 500
6224 set moretodo 1
6226 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6227 update_arcrows $curview
6229 set found 0
6230 set domore 1
6231 set ai [bsearch $vrownum($curview) $l]
6232 set a [lindex $varcorder($curview) $ai]
6233 set arow [lindex $vrownum($curview) $ai]
6234 set ids [lindex $varccommits($curview,$a)]
6235 set arowend [expr {$arow + [llength $ids]}]
6236 if {$gdttype eq [mc "containing:"]} {
6237 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6238 if {$l < $arow || $l >= $arowend} {
6239 incr ai $find_dirn
6240 set a [lindex $varcorder($curview) $ai]
6241 set arow [lindex $vrownum($curview) $ai]
6242 set ids [lindex $varccommits($curview,$a)]
6243 set arowend [expr {$arow + [llength $ids]}]
6245 set id [lindex $ids [expr {$l - $arow}]]
6246 # shouldn't happen unless git log doesn't give all the commits...
6247 if {![info exists commitdata($id)] ||
6248 ![doesmatch $commitdata($id)]} {
6249 continue
6251 if {![info exists commitinfo($id)]} {
6252 getcommit $id
6254 set info $commitinfo($id)
6255 foreach f $info ty $fldtypes {
6256 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6257 [doesmatch $f]} {
6258 set found 1
6259 break
6262 if {$found} break
6264 } else {
6265 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6266 if {$l < $arow || $l >= $arowend} {
6267 incr ai $find_dirn
6268 set a [lindex $varcorder($curview) $ai]
6269 set arow [lindex $vrownum($curview) $ai]
6270 set ids [lindex $varccommits($curview,$a)]
6271 set arowend [expr {$arow + [llength $ids]}]
6273 set id [lindex $ids [expr {$l - $arow}]]
6274 if {![info exists fhighlights($id)]} {
6275 # this sets fhighlights($id) to -1
6276 askfilehighlight $l $id
6278 if {$fhighlights($id) > 0} {
6279 set found $domore
6280 break
6282 if {$fhighlights($id) < 0} {
6283 if {$domore} {
6284 set domore 0
6285 set findcurline [expr {$l - $find_dirn}]
6290 if {$found || ($domore && !$moretodo)} {
6291 unset findcurline
6292 unset find_dirn
6293 notbusy finding
6294 set fprogcoord 0
6295 adjustprogress
6296 if {$found} {
6297 findselectline $l
6298 } else {
6299 bell
6301 return 0
6303 if {!$domore} {
6304 flushhighlights
6305 } else {
6306 set findcurline [expr {$l - $find_dirn}]
6308 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6309 if {$n < 0} {
6310 incr n $numcommits
6312 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6313 adjustprogress
6314 return $domore
6317 proc findselectline {l} {
6318 global findloc commentend ctext findcurline markingmatches gdttype
6320 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6321 set findcurline $l
6322 selectline $l 1
6323 if {$markingmatches &&
6324 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6325 # highlight the matches in the comments
6326 set f [$ctext get 1.0 $commentend]
6327 set matches [findmatches $f]
6328 foreach match $matches {
6329 set start [lindex $match 0]
6330 set end [expr {[lindex $match 1] + 1}]
6331 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6334 drawvisible
6337 # mark the bits of a headline or author that match a find string
6338 proc markmatches {canv l str tag matches font row} {
6339 global selectedline
6341 set bbox [$canv bbox $tag]
6342 set x0 [lindex $bbox 0]
6343 set y0 [lindex $bbox 1]
6344 set y1 [lindex $bbox 3]
6345 foreach match $matches {
6346 set start [lindex $match 0]
6347 set end [lindex $match 1]
6348 if {$start > $end} continue
6349 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6350 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6351 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6352 [expr {$x0+$xlen+2}] $y1 \
6353 -outline {} -tags [list match$l matches] -fill yellow]
6354 $canv lower $t
6355 if {$row == $selectedline} {
6356 $canv raise $t secsel
6361 proc unmarkmatches {} {
6362 global markingmatches
6364 allcanvs delete matches
6365 set markingmatches 0
6366 stopfinding
6369 proc selcanvline {w x y} {
6370 global canv canvy0 ctext linespc
6371 global rowtextx
6372 set ymax [lindex [$canv cget -scrollregion] 3]
6373 if {$ymax == {}} return
6374 set yfrac [lindex [$canv yview] 0]
6375 set y [expr {$y + $yfrac * $ymax}]
6376 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6377 if {$l < 0} {
6378 set l 0
6380 if {$w eq $canv} {
6381 set xmax [lindex [$canv cget -scrollregion] 2]
6382 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6383 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6385 unmarkmatches
6386 selectline $l 1
6389 proc commit_descriptor {p} {
6390 global commitinfo
6391 if {![info exists commitinfo($p)]} {
6392 getcommit $p
6394 set l "..."
6395 if {[llength $commitinfo($p)] > 1} {
6396 set l [lindex $commitinfo($p) 0]
6398 return "$p ($l)\n"
6401 # append some text to the ctext widget, and make any SHA1 ID
6402 # that we know about be a clickable link.
6403 proc appendwithlinks {text tags} {
6404 global ctext linknum curview
6406 set start [$ctext index "end - 1c"]
6407 $ctext insert end $text $tags
6408 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6409 foreach l $links {
6410 set s [lindex $l 0]
6411 set e [lindex $l 1]
6412 set linkid [string range $text $s $e]
6413 incr e
6414 $ctext tag delete link$linknum
6415 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6416 setlink $linkid link$linknum
6417 incr linknum
6421 proc setlink {id lk} {
6422 global curview ctext pendinglinks
6424 set known 0
6425 if {[string length $id] < 40} {
6426 set matches [longid $id]
6427 if {[llength $matches] > 0} {
6428 if {[llength $matches] > 1} return
6429 set known 1
6430 set id [lindex $matches 0]
6432 } else {
6433 set known [commitinview $id $curview]
6435 if {$known} {
6436 $ctext tag conf $lk -foreground blue -underline 1
6437 $ctext tag bind $lk <1> [list selbyid $id]
6438 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6439 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6440 } else {
6441 lappend pendinglinks($id) $lk
6442 interestedin $id {makelink %P}
6446 proc makelink {id} {
6447 global pendinglinks
6449 if {![info exists pendinglinks($id)]} return
6450 foreach lk $pendinglinks($id) {
6451 setlink $id $lk
6453 unset pendinglinks($id)
6456 proc linkcursor {w inc} {
6457 global linkentercount curtextcursor
6459 if {[incr linkentercount $inc] > 0} {
6460 $w configure -cursor hand2
6461 } else {
6462 $w configure -cursor $curtextcursor
6463 if {$linkentercount < 0} {
6464 set linkentercount 0
6469 proc viewnextline {dir} {
6470 global canv linespc
6472 $canv delete hover
6473 set ymax [lindex [$canv cget -scrollregion] 3]
6474 set wnow [$canv yview]
6475 set wtop [expr {[lindex $wnow 0] * $ymax}]
6476 set newtop [expr {$wtop + $dir * $linespc}]
6477 if {$newtop < 0} {
6478 set newtop 0
6479 } elseif {$newtop > $ymax} {
6480 set newtop $ymax
6482 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6485 # add a list of tag or branch names at position pos
6486 # returns the number of names inserted
6487 proc appendrefs {pos ids var} {
6488 global ctext linknum curview $var maxrefs
6490 if {[catch {$ctext index $pos}]} {
6491 return 0
6493 $ctext conf -state normal
6494 $ctext delete $pos "$pos lineend"
6495 set tags {}
6496 foreach id $ids {
6497 foreach tag [set $var\($id\)] {
6498 lappend tags [list $tag $id]
6501 if {[llength $tags] > $maxrefs} {
6502 $ctext insert $pos "many ([llength $tags])"
6503 } else {
6504 set tags [lsort -index 0 -decreasing $tags]
6505 set sep {}
6506 foreach ti $tags {
6507 set id [lindex $ti 1]
6508 set lk link$linknum
6509 incr linknum
6510 $ctext tag delete $lk
6511 $ctext insert $pos $sep
6512 $ctext insert $pos [lindex $ti 0] $lk
6513 setlink $id $lk
6514 set sep ", "
6517 $ctext conf -state disabled
6518 return [llength $tags]
6521 # called when we have finished computing the nearby tags
6522 proc dispneartags {delay} {
6523 global selectedline currentid showneartags tagphase
6525 if {$selectedline eq {} || !$showneartags} return
6526 after cancel dispnexttag
6527 if {$delay} {
6528 after 200 dispnexttag
6529 set tagphase -1
6530 } else {
6531 after idle dispnexttag
6532 set tagphase 0
6536 proc dispnexttag {} {
6537 global selectedline currentid showneartags tagphase ctext
6539 if {$selectedline eq {} || !$showneartags} return
6540 switch -- $tagphase {
6542 set dtags [desctags $currentid]
6543 if {$dtags ne {}} {
6544 appendrefs precedes $dtags idtags
6548 set atags [anctags $currentid]
6549 if {$atags ne {}} {
6550 appendrefs follows $atags idtags
6554 set dheads [descheads $currentid]
6555 if {$dheads ne {}} {
6556 if {[appendrefs branch $dheads idheads] > 1
6557 && [$ctext get "branch -3c"] eq "h"} {
6558 # turn "Branch" into "Branches"
6559 $ctext conf -state normal
6560 $ctext insert "branch -2c" "es"
6561 $ctext conf -state disabled
6566 if {[incr tagphase] <= 2} {
6567 after idle dispnexttag
6571 proc make_secsel {id} {
6572 global linehtag linentag linedtag canv canv2 canv3
6574 if {![info exists linehtag($id)]} return
6575 $canv delete secsel
6576 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6577 -tags secsel -fill [$canv cget -selectbackground]]
6578 $canv lower $t
6579 $canv2 delete secsel
6580 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6581 -tags secsel -fill [$canv2 cget -selectbackground]]
6582 $canv2 lower $t
6583 $canv3 delete secsel
6584 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6585 -tags secsel -fill [$canv3 cget -selectbackground]]
6586 $canv3 lower $t
6589 proc selectline {l isnew {desired_loc {}}} {
6590 global canv ctext commitinfo selectedline
6591 global canvy0 linespc parents children curview
6592 global currentid sha1entry
6593 global commentend idtags linknum
6594 global mergemax numcommits pending_select
6595 global cmitmode showneartags allcommits
6596 global targetrow targetid lastscrollrows
6597 global autoselect jump_to_here
6599 catch {unset pending_select}
6600 $canv delete hover
6601 normalline
6602 unsel_reflist
6603 stopfinding
6604 if {$l < 0 || $l >= $numcommits} return
6605 set id [commitonrow $l]
6606 set targetid $id
6607 set targetrow $l
6608 set selectedline $l
6609 set currentid $id
6610 if {$lastscrollrows < $numcommits} {
6611 setcanvscroll
6614 set y [expr {$canvy0 + $l * $linespc}]
6615 set ymax [lindex [$canv cget -scrollregion] 3]
6616 set ytop [expr {$y - $linespc - 1}]
6617 set ybot [expr {$y + $linespc + 1}]
6618 set wnow [$canv yview]
6619 set wtop [expr {[lindex $wnow 0] * $ymax}]
6620 set wbot [expr {[lindex $wnow 1] * $ymax}]
6621 set wh [expr {$wbot - $wtop}]
6622 set newtop $wtop
6623 if {$ytop < $wtop} {
6624 if {$ybot < $wtop} {
6625 set newtop [expr {$y - $wh / 2.0}]
6626 } else {
6627 set newtop $ytop
6628 if {$newtop > $wtop - $linespc} {
6629 set newtop [expr {$wtop - $linespc}]
6632 } elseif {$ybot > $wbot} {
6633 if {$ytop > $wbot} {
6634 set newtop [expr {$y - $wh / 2.0}]
6635 } else {
6636 set newtop [expr {$ybot - $wh}]
6637 if {$newtop < $wtop + $linespc} {
6638 set newtop [expr {$wtop + $linespc}]
6642 if {$newtop != $wtop} {
6643 if {$newtop < 0} {
6644 set newtop 0
6646 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6647 drawvisible
6650 make_secsel $id
6652 if {$isnew} {
6653 addtohistory [list selbyid $id]
6656 $sha1entry delete 0 end
6657 $sha1entry insert 0 $id
6658 if {$autoselect} {
6659 $sha1entry selection from 0
6660 $sha1entry selection to end
6662 rhighlight_sel $id
6664 $ctext conf -state normal
6665 clear_ctext
6666 set linknum 0
6667 if {![info exists commitinfo($id)]} {
6668 getcommit $id
6670 set info $commitinfo($id)
6671 set date [formatdate [lindex $info 2]]
6672 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6673 set date [formatdate [lindex $info 4]]
6674 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6675 if {[info exists idtags($id)]} {
6676 $ctext insert end [mc "Tags:"]
6677 foreach tag $idtags($id) {
6678 $ctext insert end " $tag"
6680 $ctext insert end "\n"
6683 set headers {}
6684 set olds $parents($curview,$id)
6685 if {[llength $olds] > 1} {
6686 set np 0
6687 foreach p $olds {
6688 if {$np >= $mergemax} {
6689 set tag mmax
6690 } else {
6691 set tag m$np
6693 $ctext insert end "[mc "Parent"]: " $tag
6694 appendwithlinks [commit_descriptor $p] {}
6695 incr np
6697 } else {
6698 foreach p $olds {
6699 append headers "[mc "Parent"]: [commit_descriptor $p]"
6703 foreach c $children($curview,$id) {
6704 append headers "[mc "Child"]: [commit_descriptor $c]"
6707 # make anything that looks like a SHA1 ID be a clickable link
6708 appendwithlinks $headers {}
6709 if {$showneartags} {
6710 if {![info exists allcommits]} {
6711 getallcommits
6713 $ctext insert end "[mc "Branch"]: "
6714 $ctext mark set branch "end -1c"
6715 $ctext mark gravity branch left
6716 $ctext insert end "\n[mc "Follows"]: "
6717 $ctext mark set follows "end -1c"
6718 $ctext mark gravity follows left
6719 $ctext insert end "\n[mc "Precedes"]: "
6720 $ctext mark set precedes "end -1c"
6721 $ctext mark gravity precedes left
6722 $ctext insert end "\n"
6723 dispneartags 1
6725 $ctext insert end "\n"
6726 set comment [lindex $info 5]
6727 if {[string first "\r" $comment] >= 0} {
6728 set comment [string map {"\r" "\n "} $comment]
6730 appendwithlinks $comment {comment}
6732 $ctext tag remove found 1.0 end
6733 $ctext conf -state disabled
6734 set commentend [$ctext index "end - 1c"]
6736 set jump_to_here $desired_loc
6737 init_flist [mc "Comments"]
6738 if {$cmitmode eq "tree"} {
6739 gettree $id
6740 } elseif {[llength $olds] <= 1} {
6741 startdiff $id
6742 } else {
6743 mergediff $id
6747 proc selfirstline {} {
6748 unmarkmatches
6749 selectline 0 1
6752 proc sellastline {} {
6753 global numcommits
6754 unmarkmatches
6755 set l [expr {$numcommits - 1}]
6756 selectline $l 1
6759 proc selnextline {dir} {
6760 global selectedline
6761 focus .
6762 if {$selectedline eq {}} return
6763 set l [expr {$selectedline + $dir}]
6764 unmarkmatches
6765 selectline $l 1
6768 proc selnextpage {dir} {
6769 global canv linespc selectedline numcommits
6771 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6772 if {$lpp < 1} {
6773 set lpp 1
6775 allcanvs yview scroll [expr {$dir * $lpp}] units
6776 drawvisible
6777 if {$selectedline eq {}} return
6778 set l [expr {$selectedline + $dir * $lpp}]
6779 if {$l < 0} {
6780 set l 0
6781 } elseif {$l >= $numcommits} {
6782 set l [expr $numcommits - 1]
6784 unmarkmatches
6785 selectline $l 1
6788 proc unselectline {} {
6789 global selectedline currentid
6791 set selectedline {}
6792 catch {unset currentid}
6793 allcanvs delete secsel
6794 rhighlight_none
6797 proc reselectline {} {
6798 global selectedline
6800 if {$selectedline ne {}} {
6801 selectline $selectedline 0
6805 proc addtohistory {cmd} {
6806 global history historyindex curview
6808 set elt [list $curview $cmd]
6809 if {$historyindex > 0
6810 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6811 return
6814 if {$historyindex < [llength $history]} {
6815 set history [lreplace $history $historyindex end $elt]
6816 } else {
6817 lappend history $elt
6819 incr historyindex
6820 if {$historyindex > 1} {
6821 .tf.bar.leftbut conf -state normal
6822 } else {
6823 .tf.bar.leftbut conf -state disabled
6825 .tf.bar.rightbut conf -state disabled
6828 proc godo {elt} {
6829 global curview
6831 set view [lindex $elt 0]
6832 set cmd [lindex $elt 1]
6833 if {$curview != $view} {
6834 showview $view
6836 eval $cmd
6839 proc goback {} {
6840 global history historyindex
6841 focus .
6843 if {$historyindex > 1} {
6844 incr historyindex -1
6845 godo [lindex $history [expr {$historyindex - 1}]]
6846 .tf.bar.rightbut conf -state normal
6848 if {$historyindex <= 1} {
6849 .tf.bar.leftbut conf -state disabled
6853 proc goforw {} {
6854 global history historyindex
6855 focus .
6857 if {$historyindex < [llength $history]} {
6858 set cmd [lindex $history $historyindex]
6859 incr historyindex
6860 godo $cmd
6861 .tf.bar.leftbut conf -state normal
6863 if {$historyindex >= [llength $history]} {
6864 .tf.bar.rightbut conf -state disabled
6868 proc gettree {id} {
6869 global treefilelist treeidlist diffids diffmergeid treepending
6870 global nullid nullid2
6872 set diffids $id
6873 catch {unset diffmergeid}
6874 if {![info exists treefilelist($id)]} {
6875 if {![info exists treepending]} {
6876 if {$id eq $nullid} {
6877 set cmd [list | git ls-files]
6878 } elseif {$id eq $nullid2} {
6879 set cmd [list | git ls-files --stage -t]
6880 } else {
6881 set cmd [list | git ls-tree -r $id]
6883 if {[catch {set gtf [open $cmd r]}]} {
6884 return
6886 set treepending $id
6887 set treefilelist($id) {}
6888 set treeidlist($id) {}
6889 fconfigure $gtf -blocking 0 -encoding binary
6890 filerun $gtf [list gettreeline $gtf $id]
6892 } else {
6893 setfilelist $id
6897 proc gettreeline {gtf id} {
6898 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6900 set nl 0
6901 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6902 if {$diffids eq $nullid} {
6903 set fname $line
6904 } else {
6905 set i [string first "\t" $line]
6906 if {$i < 0} continue
6907 set fname [string range $line [expr {$i+1}] end]
6908 set line [string range $line 0 [expr {$i-1}]]
6909 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6910 set sha1 [lindex $line 2]
6911 lappend treeidlist($id) $sha1
6913 if {[string index $fname 0] eq "\""} {
6914 set fname [lindex $fname 0]
6916 set fname [encoding convertfrom $fname]
6917 lappend treefilelist($id) $fname
6919 if {![eof $gtf]} {
6920 return [expr {$nl >= 1000? 2: 1}]
6922 close $gtf
6923 unset treepending
6924 if {$cmitmode ne "tree"} {
6925 if {![info exists diffmergeid]} {
6926 gettreediffs $diffids
6928 } elseif {$id ne $diffids} {
6929 gettree $diffids
6930 } else {
6931 setfilelist $id
6933 return 0
6936 proc showfile {f} {
6937 global treefilelist treeidlist diffids nullid nullid2
6938 global ctext_file_names ctext_file_lines
6939 global ctext commentend
6941 set i [lsearch -exact $treefilelist($diffids) $f]
6942 if {$i < 0} {
6943 puts "oops, $f not in list for id $diffids"
6944 return
6946 if {$diffids eq $nullid} {
6947 if {[catch {set bf [open $f r]} err]} {
6948 puts "oops, can't read $f: $err"
6949 return
6951 } else {
6952 set blob [lindex $treeidlist($diffids) $i]
6953 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6954 puts "oops, error reading blob $blob: $err"
6955 return
6958 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6959 filerun $bf [list getblobline $bf $diffids]
6960 $ctext config -state normal
6961 clear_ctext $commentend
6962 lappend ctext_file_names $f
6963 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6964 $ctext insert end "\n"
6965 $ctext insert end "$f\n" filesep
6966 $ctext config -state disabled
6967 $ctext yview $commentend
6968 settabs 0
6971 proc getblobline {bf id} {
6972 global diffids cmitmode ctext
6974 if {$id ne $diffids || $cmitmode ne "tree"} {
6975 catch {close $bf}
6976 return 0
6978 $ctext config -state normal
6979 set nl 0
6980 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6981 $ctext insert end "$line\n"
6983 if {[eof $bf]} {
6984 global jump_to_here ctext_file_names commentend
6986 # delete last newline
6987 $ctext delete "end - 2c" "end - 1c"
6988 close $bf
6989 if {$jump_to_here ne {} &&
6990 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6991 set lnum [expr {[lindex $jump_to_here 1] +
6992 [lindex [split $commentend .] 0]}]
6993 mark_ctext_line $lnum
6995 return 0
6997 $ctext config -state disabled
6998 return [expr {$nl >= 1000? 2: 1}]
7001 proc mark_ctext_line {lnum} {
7002 global ctext markbgcolor
7004 $ctext tag delete omark
7005 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7006 $ctext tag conf omark -background $markbgcolor
7007 $ctext see $lnum.0
7010 proc mergediff {id} {
7011 global diffmergeid
7012 global diffids treediffs
7013 global parents curview
7015 set diffmergeid $id
7016 set diffids $id
7017 set treediffs($id) {}
7018 set np [llength $parents($curview,$id)]
7019 settabs $np
7020 getblobdiffs $id
7023 proc startdiff {ids} {
7024 global treediffs diffids treepending diffmergeid nullid nullid2
7026 settabs 1
7027 set diffids $ids
7028 catch {unset diffmergeid}
7029 if {![info exists treediffs($ids)] ||
7030 [lsearch -exact $ids $nullid] >= 0 ||
7031 [lsearch -exact $ids $nullid2] >= 0} {
7032 if {![info exists treepending]} {
7033 gettreediffs $ids
7035 } else {
7036 addtocflist $ids
7040 proc path_filter {filter name} {
7041 foreach p $filter {
7042 set l [string length $p]
7043 if {[string index $p end] eq "/"} {
7044 if {[string compare -length $l $p $name] == 0} {
7045 return 1
7047 } else {
7048 if {[string compare -length $l $p $name] == 0 &&
7049 ([string length $name] == $l ||
7050 [string index $name $l] eq "/")} {
7051 return 1
7055 return 0
7058 proc addtocflist {ids} {
7059 global treediffs
7061 add_flist $treediffs($ids)
7062 getblobdiffs $ids
7065 proc diffcmd {ids flags} {
7066 global nullid nullid2
7068 set i [lsearch -exact $ids $nullid]
7069 set j [lsearch -exact $ids $nullid2]
7070 if {$i >= 0} {
7071 if {[llength $ids] > 1 && $j < 0} {
7072 # comparing working directory with some specific revision
7073 set cmd [concat | git diff-index $flags]
7074 if {$i == 0} {
7075 lappend cmd -R [lindex $ids 1]
7076 } else {
7077 lappend cmd [lindex $ids 0]
7079 } else {
7080 # comparing working directory with index
7081 set cmd [concat | git diff-files $flags]
7082 if {$j == 1} {
7083 lappend cmd -R
7086 } elseif {$j >= 0} {
7087 set cmd [concat | git diff-index --cached $flags]
7088 if {[llength $ids] > 1} {
7089 # comparing index with specific revision
7090 if {$i == 0} {
7091 lappend cmd -R [lindex $ids 1]
7092 } else {
7093 lappend cmd [lindex $ids 0]
7095 } else {
7096 # comparing index with HEAD
7097 lappend cmd HEAD
7099 } else {
7100 set cmd [concat | git diff-tree -r $flags $ids]
7102 return $cmd
7105 proc gettreediffs {ids} {
7106 global treediff treepending
7108 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7110 set treepending $ids
7111 set treediff {}
7112 fconfigure $gdtf -blocking 0 -encoding binary
7113 filerun $gdtf [list gettreediffline $gdtf $ids]
7116 proc gettreediffline {gdtf ids} {
7117 global treediff treediffs treepending diffids diffmergeid
7118 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7120 set nr 0
7121 set sublist {}
7122 set max 1000
7123 if {$perfile_attrs} {
7124 # cache_gitattr is slow, and even slower on win32 where we
7125 # have to invoke it for only about 30 paths at a time
7126 set max 500
7127 if {[tk windowingsystem] == "win32"} {
7128 set max 120
7131 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7132 set i [string first "\t" $line]
7133 if {$i >= 0} {
7134 set file [string range $line [expr {$i+1}] end]
7135 if {[string index $file 0] eq "\""} {
7136 set file [lindex $file 0]
7138 set file [encoding convertfrom $file]
7139 if {$file ne [lindex $treediff end]} {
7140 lappend treediff $file
7141 lappend sublist $file
7145 if {$perfile_attrs} {
7146 cache_gitattr encoding $sublist
7148 if {![eof $gdtf]} {
7149 return [expr {$nr >= $max? 2: 1}]
7151 close $gdtf
7152 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7153 set flist {}
7154 foreach f $treediff {
7155 if {[path_filter $vfilelimit($curview) $f]} {
7156 lappend flist $f
7159 set treediffs($ids) $flist
7160 } else {
7161 set treediffs($ids) $treediff
7163 unset treepending
7164 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7165 gettree $diffids
7166 } elseif {$ids != $diffids} {
7167 if {![info exists diffmergeid]} {
7168 gettreediffs $diffids
7170 } else {
7171 addtocflist $ids
7173 return 0
7176 # empty string or positive integer
7177 proc diffcontextvalidate {v} {
7178 return [regexp {^(|[1-9][0-9]*)$} $v]
7181 proc diffcontextchange {n1 n2 op} {
7182 global diffcontextstring diffcontext
7184 if {[string is integer -strict $diffcontextstring]} {
7185 if {$diffcontextstring > 0} {
7186 set diffcontext $diffcontextstring
7187 reselectline
7192 proc changeignorespace {} {
7193 reselectline
7196 proc getblobdiffs {ids} {
7197 global blobdifffd diffids env
7198 global diffinhdr treediffs
7199 global diffcontext
7200 global ignorespace
7201 global limitdiffs vfilelimit curview
7202 global diffencoding targetline diffnparents
7204 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7205 if {$ignorespace} {
7206 append cmd " -w"
7208 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7209 set cmd [concat $cmd -- $vfilelimit($curview)]
7211 if {[catch {set bdf [open $cmd r]} err]} {
7212 error_popup [mc "Error getting diffs: %s" $err]
7213 return
7215 set targetline {}
7216 set diffnparents 0
7217 set diffinhdr 0
7218 set diffencoding [get_path_encoding {}]
7219 fconfigure $bdf -blocking 0 -encoding binary
7220 set blobdifffd($ids) $bdf
7221 filerun $bdf [list getblobdiffline $bdf $diffids]
7224 proc setinlist {var i val} {
7225 global $var
7227 while {[llength [set $var]] < $i} {
7228 lappend $var {}
7230 if {[llength [set $var]] == $i} {
7231 lappend $var $val
7232 } else {
7233 lset $var $i $val
7237 proc makediffhdr {fname ids} {
7238 global ctext curdiffstart treediffs diffencoding
7239 global ctext_file_names jump_to_here targetline diffline
7241 set fname [encoding convertfrom $fname]
7242 set diffencoding [get_path_encoding $fname]
7243 set i [lsearch -exact $treediffs($ids) $fname]
7244 if {$i >= 0} {
7245 setinlist difffilestart $i $curdiffstart
7247 lset ctext_file_names end $fname
7248 set l [expr {(78 - [string length $fname]) / 2}]
7249 set pad [string range "----------------------------------------" 1 $l]
7250 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7251 set targetline {}
7252 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7253 set targetline [lindex $jump_to_here 1]
7255 set diffline 0
7258 proc getblobdiffline {bdf ids} {
7259 global diffids blobdifffd ctext curdiffstart
7260 global diffnexthead diffnextnote difffilestart
7261 global ctext_file_names ctext_file_lines
7262 global diffinhdr treediffs mergemax diffnparents
7263 global diffencoding jump_to_here targetline diffline
7265 set nr 0
7266 $ctext conf -state normal
7267 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7268 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7269 close $bdf
7270 return 0
7272 if {![string compare -length 5 "diff " $line]} {
7273 if {![regexp {^diff (--cc|--git) } $line m type]} {
7274 set line [encoding convertfrom $line]
7275 $ctext insert end "$line\n" hunksep
7276 continue
7278 # start of a new file
7279 set diffinhdr 1
7280 $ctext insert end "\n"
7281 set curdiffstart [$ctext index "end - 1c"]
7282 lappend ctext_file_names ""
7283 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7284 $ctext insert end "\n" filesep
7286 if {$type eq "--cc"} {
7287 # start of a new file in a merge diff
7288 set fname [string range $line 10 end]
7289 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7290 lappend treediffs($ids) $fname
7291 add_flist [list $fname]
7294 } else {
7295 set line [string range $line 11 end]
7296 # If the name hasn't changed the length will be odd,
7297 # the middle char will be a space, and the two bits either
7298 # side will be a/name and b/name, or "a/name" and "b/name".
7299 # If the name has changed we'll get "rename from" and
7300 # "rename to" or "copy from" and "copy to" lines following
7301 # this, and we'll use them to get the filenames.
7302 # This complexity is necessary because spaces in the
7303 # filename(s) don't get escaped.
7304 set l [string length $line]
7305 set i [expr {$l / 2}]
7306 if {!(($l & 1) && [string index $line $i] eq " " &&
7307 [string range $line 2 [expr {$i - 1}]] eq \
7308 [string range $line [expr {$i + 3}] end])} {
7309 continue
7311 # unescape if quoted and chop off the a/ from the front
7312 if {[string index $line 0] eq "\""} {
7313 set fname [string range [lindex $line 0] 2 end]
7314 } else {
7315 set fname [string range $line 2 [expr {$i - 1}]]
7318 makediffhdr $fname $ids
7320 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7321 set fname [encoding convertfrom [string range $line 16 end]]
7322 $ctext insert end "\n"
7323 set curdiffstart [$ctext index "end - 1c"]
7324 lappend ctext_file_names $fname
7325 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7326 $ctext insert end "$line\n" filesep
7327 set i [lsearch -exact $treediffs($ids) $fname]
7328 if {$i >= 0} {
7329 setinlist difffilestart $i $curdiffstart
7332 } elseif {![string compare -length 2 "@@" $line]} {
7333 regexp {^@@+} $line ats
7334 set line [encoding convertfrom $diffencoding $line]
7335 $ctext insert end "$line\n" hunksep
7336 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7337 set diffline $nl
7339 set diffnparents [expr {[string length $ats] - 1}]
7340 set diffinhdr 0
7342 } elseif {$diffinhdr} {
7343 if {![string compare -length 12 "rename from " $line]} {
7344 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7345 if {[string index $fname 0] eq "\""} {
7346 set fname [lindex $fname 0]
7348 set fname [encoding convertfrom $fname]
7349 set i [lsearch -exact $treediffs($ids) $fname]
7350 if {$i >= 0} {
7351 setinlist difffilestart $i $curdiffstart
7353 } elseif {![string compare -length 10 $line "rename to "] ||
7354 ![string compare -length 8 $line "copy to "]} {
7355 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7356 if {[string index $fname 0] eq "\""} {
7357 set fname [lindex $fname 0]
7359 makediffhdr $fname $ids
7360 } elseif {[string compare -length 3 $line "---"] == 0} {
7361 # do nothing
7362 continue
7363 } elseif {[string compare -length 3 $line "+++"] == 0} {
7364 set diffinhdr 0
7365 continue
7367 $ctext insert end "$line\n" filesep
7369 } else {
7370 set line [encoding convertfrom $diffencoding $line]
7371 # parse the prefix - one ' ', '-' or '+' for each parent
7372 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7373 set tag [expr {$diffnparents > 1? "m": "d"}]
7374 if {[string trim $prefix " -+"] eq {}} {
7375 # prefix only has " ", "-" and "+" in it: normal diff line
7376 set num [string first "-" $prefix]
7377 if {$num >= 0} {
7378 # removed line, first parent with line is $num
7379 if {$num >= $mergemax} {
7380 set num "max"
7382 $ctext insert end "$line\n" $tag$num
7383 } else {
7384 set tags {}
7385 if {[string first "+" $prefix] >= 0} {
7386 # added line
7387 lappend tags ${tag}result
7388 if {$diffnparents > 1} {
7389 set num [string first " " $prefix]
7390 if {$num >= 0} {
7391 if {$num >= $mergemax} {
7392 set num "max"
7394 lappend tags m$num
7398 if {$targetline ne {}} {
7399 if {$diffline == $targetline} {
7400 set seehere [$ctext index "end - 1 chars"]
7401 set targetline {}
7402 } else {
7403 incr diffline
7406 $ctext insert end "$line\n" $tags
7408 } else {
7409 # "\ No newline at end of file",
7410 # or something else we don't recognize
7411 $ctext insert end "$line\n" hunksep
7415 if {[info exists seehere]} {
7416 mark_ctext_line [lindex [split $seehere .] 0]
7418 $ctext conf -state disabled
7419 if {[eof $bdf]} {
7420 close $bdf
7421 return 0
7423 return [expr {$nr >= 1000? 2: 1}]
7426 proc changediffdisp {} {
7427 global ctext diffelide
7429 $ctext tag conf d0 -elide [lindex $diffelide 0]
7430 $ctext tag conf dresult -elide [lindex $diffelide 1]
7433 proc highlightfile {loc cline} {
7434 global ctext cflist cflist_top
7436 $ctext yview $loc
7437 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7438 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7439 $cflist see $cline.0
7440 set cflist_top $cline
7443 proc prevfile {} {
7444 global difffilestart ctext cmitmode
7446 if {$cmitmode eq "tree"} return
7447 set prev 0.0
7448 set prevline 1
7449 set here [$ctext index @0,0]
7450 foreach loc $difffilestart {
7451 if {[$ctext compare $loc >= $here]} {
7452 highlightfile $prev $prevline
7453 return
7455 set prev $loc
7456 incr prevline
7458 highlightfile $prev $prevline
7461 proc nextfile {} {
7462 global difffilestart ctext cmitmode
7464 if {$cmitmode eq "tree"} return
7465 set here [$ctext index @0,0]
7466 set line 1
7467 foreach loc $difffilestart {
7468 incr line
7469 if {[$ctext compare $loc > $here]} {
7470 highlightfile $loc $line
7471 return
7476 proc clear_ctext {{first 1.0}} {
7477 global ctext smarktop smarkbot
7478 global ctext_file_names ctext_file_lines
7479 global pendinglinks
7481 set l [lindex [split $first .] 0]
7482 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7483 set smarktop $l
7485 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7486 set smarkbot $l
7488 $ctext delete $first end
7489 if {$first eq "1.0"} {
7490 catch {unset pendinglinks}
7492 set ctext_file_names {}
7493 set ctext_file_lines {}
7496 proc settabs {{firstab {}}} {
7497 global firsttabstop tabstop ctext have_tk85
7499 if {$firstab ne {} && $have_tk85} {
7500 set firsttabstop $firstab
7502 set w [font measure textfont "0"]
7503 if {$firsttabstop != 0} {
7504 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7505 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7506 } elseif {$have_tk85 || $tabstop != 8} {
7507 $ctext conf -tabs [expr {$tabstop * $w}]
7508 } else {
7509 $ctext conf -tabs {}
7513 proc incrsearch {name ix op} {
7514 global ctext searchstring searchdirn
7516 $ctext tag remove found 1.0 end
7517 if {[catch {$ctext index anchor}]} {
7518 # no anchor set, use start of selection, or of visible area
7519 set sel [$ctext tag ranges sel]
7520 if {$sel ne {}} {
7521 $ctext mark set anchor [lindex $sel 0]
7522 } elseif {$searchdirn eq "-forwards"} {
7523 $ctext mark set anchor @0,0
7524 } else {
7525 $ctext mark set anchor @0,[winfo height $ctext]
7528 if {$searchstring ne {}} {
7529 set here [$ctext search $searchdirn -- $searchstring anchor]
7530 if {$here ne {}} {
7531 $ctext see $here
7533 searchmarkvisible 1
7537 proc dosearch {} {
7538 global sstring ctext searchstring searchdirn
7540 focus $sstring
7541 $sstring icursor end
7542 set searchdirn -forwards
7543 if {$searchstring ne {}} {
7544 set sel [$ctext tag ranges sel]
7545 if {$sel ne {}} {
7546 set start "[lindex $sel 0] + 1c"
7547 } elseif {[catch {set start [$ctext index anchor]}]} {
7548 set start "@0,0"
7550 set match [$ctext search -count mlen -- $searchstring $start]
7551 $ctext tag remove sel 1.0 end
7552 if {$match eq {}} {
7553 bell
7554 return
7556 $ctext see $match
7557 set mend "$match + $mlen c"
7558 $ctext tag add sel $match $mend
7559 $ctext mark unset anchor
7563 proc dosearchback {} {
7564 global sstring ctext searchstring searchdirn
7566 focus $sstring
7567 $sstring icursor end
7568 set searchdirn -backwards
7569 if {$searchstring ne {}} {
7570 set sel [$ctext tag ranges sel]
7571 if {$sel ne {}} {
7572 set start [lindex $sel 0]
7573 } elseif {[catch {set start [$ctext index anchor]}]} {
7574 set start @0,[winfo height $ctext]
7576 set match [$ctext search -backwards -count ml -- $searchstring $start]
7577 $ctext tag remove sel 1.0 end
7578 if {$match eq {}} {
7579 bell
7580 return
7582 $ctext see $match
7583 set mend "$match + $ml c"
7584 $ctext tag add sel $match $mend
7585 $ctext mark unset anchor
7589 proc searchmark {first last} {
7590 global ctext searchstring
7592 set mend $first.0
7593 while {1} {
7594 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7595 if {$match eq {}} break
7596 set mend "$match + $mlen c"
7597 $ctext tag add found $match $mend
7601 proc searchmarkvisible {doall} {
7602 global ctext smarktop smarkbot
7604 set topline [lindex [split [$ctext index @0,0] .] 0]
7605 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7606 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7607 # no overlap with previous
7608 searchmark $topline $botline
7609 set smarktop $topline
7610 set smarkbot $botline
7611 } else {
7612 if {$topline < $smarktop} {
7613 searchmark $topline [expr {$smarktop-1}]
7614 set smarktop $topline
7616 if {$botline > $smarkbot} {
7617 searchmark [expr {$smarkbot+1}] $botline
7618 set smarkbot $botline
7623 proc scrolltext {f0 f1} {
7624 global searchstring
7626 .bleft.bottom.sb set $f0 $f1
7627 if {$searchstring ne {}} {
7628 searchmarkvisible 0
7632 proc setcoords {} {
7633 global linespc charspc canvx0 canvy0
7634 global xspc1 xspc2 lthickness
7636 set linespc [font metrics mainfont -linespace]
7637 set charspc [font measure mainfont "m"]
7638 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7639 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7640 set lthickness [expr {int($linespc / 9) + 1}]
7641 set xspc1(0) $linespc
7642 set xspc2 $linespc
7645 proc redisplay {} {
7646 global canv
7647 global selectedline
7649 set ymax [lindex [$canv cget -scrollregion] 3]
7650 if {$ymax eq {} || $ymax == 0} return
7651 set span [$canv yview]
7652 clear_display
7653 setcanvscroll
7654 allcanvs yview moveto [lindex $span 0]
7655 drawvisible
7656 if {$selectedline ne {}} {
7657 selectline $selectedline 0
7658 allcanvs yview moveto [lindex $span 0]
7662 proc parsefont {f n} {
7663 global fontattr
7665 set fontattr($f,family) [lindex $n 0]
7666 set s [lindex $n 1]
7667 if {$s eq {} || $s == 0} {
7668 set s 10
7669 } elseif {$s < 0} {
7670 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7672 set fontattr($f,size) $s
7673 set fontattr($f,weight) normal
7674 set fontattr($f,slant) roman
7675 foreach style [lrange $n 2 end] {
7676 switch -- $style {
7677 "normal" -
7678 "bold" {set fontattr($f,weight) $style}
7679 "roman" -
7680 "italic" {set fontattr($f,slant) $style}
7685 proc fontflags {f {isbold 0}} {
7686 global fontattr
7688 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7689 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7690 -slant $fontattr($f,slant)]
7693 proc fontname {f} {
7694 global fontattr
7696 set n [list $fontattr($f,family) $fontattr($f,size)]
7697 if {$fontattr($f,weight) eq "bold"} {
7698 lappend n "bold"
7700 if {$fontattr($f,slant) eq "italic"} {
7701 lappend n "italic"
7703 return $n
7706 proc incrfont {inc} {
7707 global mainfont textfont ctext canv cflist showrefstop
7708 global stopped entries fontattr
7710 unmarkmatches
7711 set s $fontattr(mainfont,size)
7712 incr s $inc
7713 if {$s < 1} {
7714 set s 1
7716 set fontattr(mainfont,size) $s
7717 font config mainfont -size $s
7718 font config mainfontbold -size $s
7719 set mainfont [fontname mainfont]
7720 set s $fontattr(textfont,size)
7721 incr s $inc
7722 if {$s < 1} {
7723 set s 1
7725 set fontattr(textfont,size) $s
7726 font config textfont -size $s
7727 font config textfontbold -size $s
7728 set textfont [fontname textfont]
7729 setcoords
7730 settabs
7731 redisplay
7734 proc clearsha1 {} {
7735 global sha1entry sha1string
7736 if {[string length $sha1string] == 40} {
7737 $sha1entry delete 0 end
7741 proc sha1change {n1 n2 op} {
7742 global sha1string currentid sha1but
7743 if {$sha1string == {}
7744 || ([info exists currentid] && $sha1string == $currentid)} {
7745 set state disabled
7746 } else {
7747 set state normal
7749 if {[$sha1but cget -state] == $state} return
7750 if {$state == "normal"} {
7751 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7752 } else {
7753 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7757 proc gotocommit {} {
7758 global sha1string tagids headids curview varcid
7760 if {$sha1string == {}
7761 || ([info exists currentid] && $sha1string == $currentid)} return
7762 if {[info exists tagids($sha1string)]} {
7763 set id $tagids($sha1string)
7764 } elseif {[info exists headids($sha1string)]} {
7765 set id $headids($sha1string)
7766 } else {
7767 set id [string tolower $sha1string]
7768 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7769 set matches [longid $id]
7770 if {$matches ne {}} {
7771 if {[llength $matches] > 1} {
7772 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7773 return
7775 set id [lindex $matches 0]
7779 if {[commitinview $id $curview]} {
7780 selectline [rowofcommit $id] 1
7781 return
7783 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7784 set msg [mc "SHA1 id %s is not known" $sha1string]
7785 } else {
7786 set msg [mc "Tag/Head %s is not known" $sha1string]
7788 error_popup $msg
7791 proc lineenter {x y id} {
7792 global hoverx hovery hoverid hovertimer
7793 global commitinfo canv
7795 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7796 set hoverx $x
7797 set hovery $y
7798 set hoverid $id
7799 if {[info exists hovertimer]} {
7800 after cancel $hovertimer
7802 set hovertimer [after 500 linehover]
7803 $canv delete hover
7806 proc linemotion {x y id} {
7807 global hoverx hovery hoverid hovertimer
7809 if {[info exists hoverid] && $id == $hoverid} {
7810 set hoverx $x
7811 set hovery $y
7812 if {[info exists hovertimer]} {
7813 after cancel $hovertimer
7815 set hovertimer [after 500 linehover]
7819 proc lineleave {id} {
7820 global hoverid hovertimer canv
7822 if {[info exists hoverid] && $id == $hoverid} {
7823 $canv delete hover
7824 if {[info exists hovertimer]} {
7825 after cancel $hovertimer
7826 unset hovertimer
7828 unset hoverid
7832 proc linehover {} {
7833 global hoverx hovery hoverid hovertimer
7834 global canv linespc lthickness
7835 global commitinfo
7837 set text [lindex $commitinfo($hoverid) 0]
7838 set ymax [lindex [$canv cget -scrollregion] 3]
7839 if {$ymax == {}} return
7840 set yfrac [lindex [$canv yview] 0]
7841 set x [expr {$hoverx + 2 * $linespc}]
7842 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7843 set x0 [expr {$x - 2 * $lthickness}]
7844 set y0 [expr {$y - 2 * $lthickness}]
7845 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7846 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7847 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7848 -fill \#ffff80 -outline black -width 1 -tags hover]
7849 $canv raise $t
7850 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7851 -font mainfont]
7852 $canv raise $t
7855 proc clickisonarrow {id y} {
7856 global lthickness
7858 set ranges [rowranges $id]
7859 set thresh [expr {2 * $lthickness + 6}]
7860 set n [expr {[llength $ranges] - 1}]
7861 for {set i 1} {$i < $n} {incr i} {
7862 set row [lindex $ranges $i]
7863 if {abs([yc $row] - $y) < $thresh} {
7864 return $i
7867 return {}
7870 proc arrowjump {id n y} {
7871 global canv
7873 # 1 <-> 2, 3 <-> 4, etc...
7874 set n [expr {(($n - 1) ^ 1) + 1}]
7875 set row [lindex [rowranges $id] $n]
7876 set yt [yc $row]
7877 set ymax [lindex [$canv cget -scrollregion] 3]
7878 if {$ymax eq {} || $ymax <= 0} return
7879 set view [$canv yview]
7880 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7881 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7882 if {$yfrac < 0} {
7883 set yfrac 0
7885 allcanvs yview moveto $yfrac
7888 proc lineclick {x y id isnew} {
7889 global ctext commitinfo children canv thickerline curview
7891 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7892 unmarkmatches
7893 unselectline
7894 normalline
7895 $canv delete hover
7896 # draw this line thicker than normal
7897 set thickerline $id
7898 drawlines $id
7899 if {$isnew} {
7900 set ymax [lindex [$canv cget -scrollregion] 3]
7901 if {$ymax eq {}} return
7902 set yfrac [lindex [$canv yview] 0]
7903 set y [expr {$y + $yfrac * $ymax}]
7905 set dirn [clickisonarrow $id $y]
7906 if {$dirn ne {}} {
7907 arrowjump $id $dirn $y
7908 return
7911 if {$isnew} {
7912 addtohistory [list lineclick $x $y $id 0]
7914 # fill the details pane with info about this line
7915 $ctext conf -state normal
7916 clear_ctext
7917 settabs 0
7918 $ctext insert end "[mc "Parent"]:\t"
7919 $ctext insert end $id link0
7920 setlink $id link0
7921 set info $commitinfo($id)
7922 $ctext insert end "\n\t[lindex $info 0]\n"
7923 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7924 set date [formatdate [lindex $info 2]]
7925 $ctext insert end "\t[mc "Date"]:\t$date\n"
7926 set kids $children($curview,$id)
7927 if {$kids ne {}} {
7928 $ctext insert end "\n[mc "Children"]:"
7929 set i 0
7930 foreach child $kids {
7931 incr i
7932 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7933 set info $commitinfo($child)
7934 $ctext insert end "\n\t"
7935 $ctext insert end $child link$i
7936 setlink $child link$i
7937 $ctext insert end "\n\t[lindex $info 0]"
7938 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7939 set date [formatdate [lindex $info 2]]
7940 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7943 $ctext conf -state disabled
7944 init_flist {}
7947 proc normalline {} {
7948 global thickerline
7949 if {[info exists thickerline]} {
7950 set id $thickerline
7951 unset thickerline
7952 drawlines $id
7956 proc selbyid {id} {
7957 global curview
7958 if {[commitinview $id $curview]} {
7959 selectline [rowofcommit $id] 1
7963 proc mstime {} {
7964 global startmstime
7965 if {![info exists startmstime]} {
7966 set startmstime [clock clicks -milliseconds]
7968 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7971 proc rowmenu {x y id} {
7972 global rowctxmenu selectedline rowmenuid curview
7973 global nullid nullid2 fakerowmenu mainhead
7975 stopfinding
7976 set rowmenuid $id
7977 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7978 set state disabled
7979 } else {
7980 set state normal
7982 if {$id ne $nullid && $id ne $nullid2} {
7983 set menu $rowctxmenu
7984 if {$mainhead ne {}} {
7985 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
7986 } else {
7987 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7989 } else {
7990 set menu $fakerowmenu
7992 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7993 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7994 $menu entryconfigure [mca "Make patch"] -state $state
7995 tk_popup $menu $x $y
7998 proc diffvssel {dirn} {
7999 global rowmenuid selectedline
8001 if {$selectedline eq {}} return
8002 if {$dirn} {
8003 set oldid [commitonrow $selectedline]
8004 set newid $rowmenuid
8005 } else {
8006 set oldid $rowmenuid
8007 set newid [commitonrow $selectedline]
8009 addtohistory [list doseldiff $oldid $newid]
8010 doseldiff $oldid $newid
8013 proc doseldiff {oldid newid} {
8014 global ctext
8015 global commitinfo
8017 $ctext conf -state normal
8018 clear_ctext
8019 init_flist [mc "Top"]
8020 $ctext insert end "[mc "From"] "
8021 $ctext insert end $oldid link0
8022 setlink $oldid link0
8023 $ctext insert end "\n "
8024 $ctext insert end [lindex $commitinfo($oldid) 0]
8025 $ctext insert end "\n\n[mc "To"] "
8026 $ctext insert end $newid link1
8027 setlink $newid link1
8028 $ctext insert end "\n "
8029 $ctext insert end [lindex $commitinfo($newid) 0]
8030 $ctext insert end "\n"
8031 $ctext conf -state disabled
8032 $ctext tag remove found 1.0 end
8033 startdiff [list $oldid $newid]
8036 proc mkpatch {} {
8037 global rowmenuid currentid commitinfo patchtop patchnum
8039 if {![info exists currentid]} return
8040 set oldid $currentid
8041 set oldhead [lindex $commitinfo($oldid) 0]
8042 set newid $rowmenuid
8043 set newhead [lindex $commitinfo($newid) 0]
8044 set top .patch
8045 set patchtop $top
8046 catch {destroy $top}
8047 toplevel $top
8048 make_transient $top .
8049 label $top.title -text [mc "Generate patch"]
8050 grid $top.title - -pady 10
8051 label $top.from -text [mc "From:"]
8052 entry $top.fromsha1 -width 40 -relief flat
8053 $top.fromsha1 insert 0 $oldid
8054 $top.fromsha1 conf -state readonly
8055 grid $top.from $top.fromsha1 -sticky w
8056 entry $top.fromhead -width 60 -relief flat
8057 $top.fromhead insert 0 $oldhead
8058 $top.fromhead conf -state readonly
8059 grid x $top.fromhead -sticky w
8060 label $top.to -text [mc "To:"]
8061 entry $top.tosha1 -width 40 -relief flat
8062 $top.tosha1 insert 0 $newid
8063 $top.tosha1 conf -state readonly
8064 grid $top.to $top.tosha1 -sticky w
8065 entry $top.tohead -width 60 -relief flat
8066 $top.tohead insert 0 $newhead
8067 $top.tohead conf -state readonly
8068 grid x $top.tohead -sticky w
8069 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8070 grid $top.rev x -pady 10
8071 label $top.flab -text [mc "Output file:"]
8072 entry $top.fname -width 60
8073 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8074 incr patchnum
8075 grid $top.flab $top.fname -sticky w
8076 frame $top.buts
8077 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8078 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8079 bind $top <Key-Return> mkpatchgo
8080 bind $top <Key-Escape> mkpatchcan
8081 grid $top.buts.gen $top.buts.can
8082 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8083 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8084 grid $top.buts - -pady 10 -sticky ew
8085 focus $top.fname
8088 proc mkpatchrev {} {
8089 global patchtop
8091 set oldid [$patchtop.fromsha1 get]
8092 set oldhead [$patchtop.fromhead get]
8093 set newid [$patchtop.tosha1 get]
8094 set newhead [$patchtop.tohead get]
8095 foreach e [list fromsha1 fromhead tosha1 tohead] \
8096 v [list $newid $newhead $oldid $oldhead] {
8097 $patchtop.$e conf -state normal
8098 $patchtop.$e delete 0 end
8099 $patchtop.$e insert 0 $v
8100 $patchtop.$e conf -state readonly
8104 proc mkpatchgo {} {
8105 global patchtop nullid nullid2
8107 set oldid [$patchtop.fromsha1 get]
8108 set newid [$patchtop.tosha1 get]
8109 set fname [$patchtop.fname get]
8110 set cmd [diffcmd [list $oldid $newid] -p]
8111 # trim off the initial "|"
8112 set cmd [lrange $cmd 1 end]
8113 lappend cmd >$fname &
8114 if {[catch {eval exec $cmd} err]} {
8115 error_popup "[mc "Error creating patch:"] $err" $patchtop
8117 catch {destroy $patchtop}
8118 unset patchtop
8121 proc mkpatchcan {} {
8122 global patchtop
8124 catch {destroy $patchtop}
8125 unset patchtop
8128 proc mktag {} {
8129 global rowmenuid mktagtop commitinfo
8131 set top .maketag
8132 set mktagtop $top
8133 catch {destroy $top}
8134 toplevel $top
8135 make_transient $top .
8136 label $top.title -text [mc "Create tag"]
8137 grid $top.title - -pady 10
8138 label $top.id -text [mc "ID:"]
8139 entry $top.sha1 -width 40 -relief flat
8140 $top.sha1 insert 0 $rowmenuid
8141 $top.sha1 conf -state readonly
8142 grid $top.id $top.sha1 -sticky w
8143 entry $top.head -width 60 -relief flat
8144 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8145 $top.head conf -state readonly
8146 grid x $top.head -sticky w
8147 label $top.tlab -text [mc "Tag name:"]
8148 entry $top.tag -width 60
8149 grid $top.tlab $top.tag -sticky w
8150 frame $top.buts
8151 button $top.buts.gen -text [mc "Create"] -command mktaggo
8152 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8153 bind $top <Key-Return> mktaggo
8154 bind $top <Key-Escape> mktagcan
8155 grid $top.buts.gen $top.buts.can
8156 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8157 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8158 grid $top.buts - -pady 10 -sticky ew
8159 focus $top.tag
8162 proc domktag {} {
8163 global mktagtop env tagids idtags
8165 set id [$mktagtop.sha1 get]
8166 set tag [$mktagtop.tag get]
8167 if {$tag == {}} {
8168 error_popup [mc "No tag name specified"] $mktagtop
8169 return 0
8171 if {[info exists tagids($tag)]} {
8172 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8173 return 0
8175 if {[catch {
8176 exec git tag $tag $id
8177 } err]} {
8178 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8179 return 0
8182 set tagids($tag) $id
8183 lappend idtags($id) $tag
8184 redrawtags $id
8185 addedtag $id
8186 dispneartags 0
8187 run refill_reflist
8188 return 1
8191 proc redrawtags {id} {
8192 global canv linehtag idpos currentid curview cmitlisted
8193 global canvxmax iddrawn circleitem mainheadid circlecolors
8195 if {![commitinview $id $curview]} return
8196 if {![info exists iddrawn($id)]} return
8197 set row [rowofcommit $id]
8198 if {$id eq $mainheadid} {
8199 set ofill yellow
8200 } else {
8201 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8203 $canv itemconf $circleitem($row) -fill $ofill
8204 $canv delete tag.$id
8205 set xt [eval drawtags $id $idpos($id)]
8206 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8207 set text [$canv itemcget $linehtag($id) -text]
8208 set font [$canv itemcget $linehtag($id) -font]
8209 set xr [expr {$xt + [font measure $font $text]}]
8210 if {$xr > $canvxmax} {
8211 set canvxmax $xr
8212 setcanvscroll
8214 if {[info exists currentid] && $currentid == $id} {
8215 make_secsel $id
8219 proc mktagcan {} {
8220 global mktagtop
8222 catch {destroy $mktagtop}
8223 unset mktagtop
8226 proc mktaggo {} {
8227 if {![domktag]} return
8228 mktagcan
8231 proc writecommit {} {
8232 global rowmenuid wrcomtop commitinfo wrcomcmd
8234 set top .writecommit
8235 set wrcomtop $top
8236 catch {destroy $top}
8237 toplevel $top
8238 make_transient $top .
8239 label $top.title -text [mc "Write commit to file"]
8240 grid $top.title - -pady 10
8241 label $top.id -text [mc "ID:"]
8242 entry $top.sha1 -width 40 -relief flat
8243 $top.sha1 insert 0 $rowmenuid
8244 $top.sha1 conf -state readonly
8245 grid $top.id $top.sha1 -sticky w
8246 entry $top.head -width 60 -relief flat
8247 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8248 $top.head conf -state readonly
8249 grid x $top.head -sticky w
8250 label $top.clab -text [mc "Command:"]
8251 entry $top.cmd -width 60 -textvariable wrcomcmd
8252 grid $top.clab $top.cmd -sticky w -pady 10
8253 label $top.flab -text [mc "Output file:"]
8254 entry $top.fname -width 60
8255 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8256 grid $top.flab $top.fname -sticky w
8257 frame $top.buts
8258 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8259 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8260 bind $top <Key-Return> wrcomgo
8261 bind $top <Key-Escape> wrcomcan
8262 grid $top.buts.gen $top.buts.can
8263 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8264 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8265 grid $top.buts - -pady 10 -sticky ew
8266 focus $top.fname
8269 proc wrcomgo {} {
8270 global wrcomtop
8272 set id [$wrcomtop.sha1 get]
8273 set cmd "echo $id | [$wrcomtop.cmd get]"
8274 set fname [$wrcomtop.fname get]
8275 if {[catch {exec sh -c $cmd >$fname &} err]} {
8276 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8278 catch {destroy $wrcomtop}
8279 unset wrcomtop
8282 proc wrcomcan {} {
8283 global wrcomtop
8285 catch {destroy $wrcomtop}
8286 unset wrcomtop
8289 proc mkbranch {} {
8290 global rowmenuid mkbrtop
8292 set top .makebranch
8293 catch {destroy $top}
8294 toplevel $top
8295 make_transient $top .
8296 label $top.title -text [mc "Create new branch"]
8297 grid $top.title - -pady 10
8298 label $top.id -text [mc "ID:"]
8299 entry $top.sha1 -width 40 -relief flat
8300 $top.sha1 insert 0 $rowmenuid
8301 $top.sha1 conf -state readonly
8302 grid $top.id $top.sha1 -sticky w
8303 label $top.nlab -text [mc "Name:"]
8304 entry $top.name -width 40
8305 grid $top.nlab $top.name -sticky w
8306 frame $top.buts
8307 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8308 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8309 bind $top <Key-Return> [list mkbrgo $top]
8310 bind $top <Key-Escape> "catch {destroy $top}"
8311 grid $top.buts.go $top.buts.can
8312 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8313 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8314 grid $top.buts - -pady 10 -sticky ew
8315 focus $top.name
8318 proc mkbrgo {top} {
8319 global headids idheads
8321 set name [$top.name get]
8322 set id [$top.sha1 get]
8323 set cmdargs {}
8324 set old_id {}
8325 if {$name eq {}} {
8326 error_popup [mc "Please specify a name for the new branch"] $top
8327 return
8329 if {[info exists headids($name)]} {
8330 if {![confirm_popup [mc \
8331 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8332 return
8334 set old_id $headids($name)
8335 lappend cmdargs -f
8337 catch {destroy $top}
8338 lappend cmdargs $name $id
8339 nowbusy newbranch
8340 update
8341 if {[catch {
8342 eval exec git branch $cmdargs
8343 } err]} {
8344 notbusy newbranch
8345 error_popup $err
8346 } else {
8347 notbusy newbranch
8348 if {$old_id ne {}} {
8349 movehead $id $name
8350 movedhead $id $name
8351 redrawtags $old_id
8352 redrawtags $id
8353 } else {
8354 set headids($name) $id
8355 lappend idheads($id) $name
8356 addedhead $id $name
8357 redrawtags $id
8359 dispneartags 0
8360 run refill_reflist
8364 proc exec_citool {tool_args {baseid {}}} {
8365 global commitinfo env
8367 set save_env [array get env GIT_AUTHOR_*]
8369 if {$baseid ne {}} {
8370 if {![info exists commitinfo($baseid)]} {
8371 getcommit $baseid
8373 set author [lindex $commitinfo($baseid) 1]
8374 set date [lindex $commitinfo($baseid) 2]
8375 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8376 $author author name email]
8377 && $date ne {}} {
8378 set env(GIT_AUTHOR_NAME) $name
8379 set env(GIT_AUTHOR_EMAIL) $email
8380 set env(GIT_AUTHOR_DATE) $date
8384 eval exec git citool $tool_args &
8386 array unset env GIT_AUTHOR_*
8387 array set env $save_env
8390 proc cherrypick {} {
8391 global rowmenuid curview
8392 global mainhead mainheadid
8394 set oldhead [exec git rev-parse HEAD]
8395 set dheads [descheads $rowmenuid]
8396 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8397 set ok [confirm_popup [mc "Commit %s is already\
8398 included in branch %s -- really re-apply it?" \
8399 [string range $rowmenuid 0 7] $mainhead]]
8400 if {!$ok} return
8402 nowbusy cherrypick [mc "Cherry-picking"]
8403 update
8404 # Unfortunately git-cherry-pick writes stuff to stderr even when
8405 # no error occurs, and exec takes that as an indication of error...
8406 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8407 notbusy cherrypick
8408 if {[regexp -line \
8409 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8410 $err msg fname]} {
8411 error_popup [mc "Cherry-pick failed because of local changes\
8412 to file '%s'.\nPlease commit, reset or stash\
8413 your changes and try again." $fname]
8414 } elseif {[regexp -line \
8415 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8416 $err]} {
8417 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8418 conflict.\nDo you wish to run git citool to\
8419 resolve it?"]]} {
8420 # Force citool to read MERGE_MSG
8421 file delete [file join [gitdir] "GITGUI_MSG"]
8422 exec_citool {} $rowmenuid
8424 } else {
8425 error_popup $err
8427 run updatecommits
8428 return
8430 set newhead [exec git rev-parse HEAD]
8431 if {$newhead eq $oldhead} {
8432 notbusy cherrypick
8433 error_popup [mc "No changes committed"]
8434 return
8436 addnewchild $newhead $oldhead
8437 if {[commitinview $oldhead $curview]} {
8438 # XXX this isn't right if we have a path limit...
8439 insertrow $newhead $oldhead $curview
8440 if {$mainhead ne {}} {
8441 movehead $newhead $mainhead
8442 movedhead $newhead $mainhead
8444 set mainheadid $newhead
8445 redrawtags $oldhead
8446 redrawtags $newhead
8447 selbyid $newhead
8449 notbusy cherrypick
8452 proc resethead {} {
8453 global mainhead rowmenuid confirm_ok resettype
8455 set confirm_ok 0
8456 set w ".confirmreset"
8457 toplevel $w
8458 make_transient $w .
8459 wm title $w [mc "Confirm reset"]
8460 message $w.m -text \
8461 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8462 -justify center -aspect 1000
8463 pack $w.m -side top -fill x -padx 20 -pady 20
8464 frame $w.f -relief sunken -border 2
8465 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8466 grid $w.f.rt -sticky w
8467 set resettype mixed
8468 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8469 -text [mc "Soft: Leave working tree and index untouched"]
8470 grid $w.f.soft -sticky w
8471 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8472 -text [mc "Mixed: Leave working tree untouched, reset index"]
8473 grid $w.f.mixed -sticky w
8474 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8475 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8476 grid $w.f.hard -sticky w
8477 pack $w.f -side top -fill x
8478 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8479 pack $w.ok -side left -fill x -padx 20 -pady 20
8480 button $w.cancel -text [mc Cancel] -command "destroy $w"
8481 bind $w <Key-Escape> [list destroy $w]
8482 pack $w.cancel -side right -fill x -padx 20 -pady 20
8483 bind $w <Visibility> "grab $w; focus $w"
8484 tkwait window $w
8485 if {!$confirm_ok} return
8486 if {[catch {set fd [open \
8487 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8488 error_popup $err
8489 } else {
8490 dohidelocalchanges
8491 filerun $fd [list readresetstat $fd]
8492 nowbusy reset [mc "Resetting"]
8493 selbyid $rowmenuid
8497 proc readresetstat {fd} {
8498 global mainhead mainheadid showlocalchanges rprogcoord
8500 if {[gets $fd line] >= 0} {
8501 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8502 set rprogcoord [expr {1.0 * $m / $n}]
8503 adjustprogress
8505 return 1
8507 set rprogcoord 0
8508 adjustprogress
8509 notbusy reset
8510 if {[catch {close $fd} err]} {
8511 error_popup $err
8513 set oldhead $mainheadid
8514 set newhead [exec git rev-parse HEAD]
8515 if {$newhead ne $oldhead} {
8516 movehead $newhead $mainhead
8517 movedhead $newhead $mainhead
8518 set mainheadid $newhead
8519 redrawtags $oldhead
8520 redrawtags $newhead
8522 if {$showlocalchanges} {
8523 doshowlocalchanges
8525 return 0
8528 # context menu for a head
8529 proc headmenu {x y id head} {
8530 global headmenuid headmenuhead headctxmenu mainhead
8532 stopfinding
8533 set headmenuid $id
8534 set headmenuhead $head
8535 set state normal
8536 if {$head eq $mainhead} {
8537 set state disabled
8539 $headctxmenu entryconfigure 0 -state $state
8540 $headctxmenu entryconfigure 1 -state $state
8541 tk_popup $headctxmenu $x $y
8544 proc cobranch {} {
8545 global headmenuid headmenuhead headids
8546 global showlocalchanges
8548 # check the tree is clean first??
8549 nowbusy checkout [mc "Checking out"]
8550 update
8551 dohidelocalchanges
8552 if {[catch {
8553 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8554 } err]} {
8555 notbusy checkout
8556 error_popup $err
8557 if {$showlocalchanges} {
8558 dodiffindex
8560 } else {
8561 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8565 proc readcheckoutstat {fd newhead newheadid} {
8566 global mainhead mainheadid headids showlocalchanges progresscoords
8567 global viewmainheadid curview
8569 if {[gets $fd line] >= 0} {
8570 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8571 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8572 adjustprogress
8574 return 1
8576 set progresscoords {0 0}
8577 adjustprogress
8578 notbusy checkout
8579 if {[catch {close $fd} err]} {
8580 error_popup $err
8582 set oldmainid $mainheadid
8583 set mainhead $newhead
8584 set mainheadid $newheadid
8585 set viewmainheadid($curview) $newheadid
8586 redrawtags $oldmainid
8587 redrawtags $newheadid
8588 selbyid $newheadid
8589 if {$showlocalchanges} {
8590 dodiffindex
8594 proc rmbranch {} {
8595 global headmenuid headmenuhead mainhead
8596 global idheads
8598 set head $headmenuhead
8599 set id $headmenuid
8600 # this check shouldn't be needed any more...
8601 if {$head eq $mainhead} {
8602 error_popup [mc "Cannot delete the currently checked-out branch"]
8603 return
8605 set dheads [descheads $id]
8606 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8607 # the stuff on this branch isn't on any other branch
8608 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8609 branch.\nReally delete branch %s?" $head $head]]} return
8611 nowbusy rmbranch
8612 update
8613 if {[catch {exec git branch -D $head} err]} {
8614 notbusy rmbranch
8615 error_popup $err
8616 return
8618 removehead $id $head
8619 removedhead $id $head
8620 redrawtags $id
8621 notbusy rmbranch
8622 dispneartags 0
8623 run refill_reflist
8626 # Display a list of tags and heads
8627 proc showrefs {} {
8628 global showrefstop bgcolor fgcolor selectbgcolor
8629 global bglist fglist reflistfilter reflist maincursor
8631 set top .showrefs
8632 set showrefstop $top
8633 if {[winfo exists $top]} {
8634 raise $top
8635 refill_reflist
8636 return
8638 toplevel $top
8639 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8640 make_transient $top .
8641 text $top.list -background $bgcolor -foreground $fgcolor \
8642 -selectbackground $selectbgcolor -font mainfont \
8643 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8644 -width 30 -height 20 -cursor $maincursor \
8645 -spacing1 1 -spacing3 1 -state disabled
8646 $top.list tag configure highlight -background $selectbgcolor
8647 lappend bglist $top.list
8648 lappend fglist $top.list
8649 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8650 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8651 grid $top.list $top.ysb -sticky nsew
8652 grid $top.xsb x -sticky ew
8653 frame $top.f
8654 label $top.f.l -text "[mc "Filter"]: "
8655 entry $top.f.e -width 20 -textvariable reflistfilter
8656 set reflistfilter "*"
8657 trace add variable reflistfilter write reflistfilter_change
8658 pack $top.f.e -side right -fill x -expand 1
8659 pack $top.f.l -side left
8660 grid $top.f - -sticky ew -pady 2
8661 button $top.close -command [list destroy $top] -text [mc "Close"]
8662 bind $top <Key-Escape> [list destroy $top]
8663 grid $top.close -
8664 grid columnconfigure $top 0 -weight 1
8665 grid rowconfigure $top 0 -weight 1
8666 bind $top.list <1> {break}
8667 bind $top.list <B1-Motion> {break}
8668 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8669 set reflist {}
8670 refill_reflist
8673 proc sel_reflist {w x y} {
8674 global showrefstop reflist headids tagids otherrefids
8676 if {![winfo exists $showrefstop]} return
8677 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8678 set ref [lindex $reflist [expr {$l-1}]]
8679 set n [lindex $ref 0]
8680 switch -- [lindex $ref 1] {
8681 "H" {selbyid $headids($n)}
8682 "T" {selbyid $tagids($n)}
8683 "o" {selbyid $otherrefids($n)}
8685 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8688 proc unsel_reflist {} {
8689 global showrefstop
8691 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8692 $showrefstop.list tag remove highlight 0.0 end
8695 proc reflistfilter_change {n1 n2 op} {
8696 global reflistfilter
8698 after cancel refill_reflist
8699 after 200 refill_reflist
8702 proc refill_reflist {} {
8703 global reflist reflistfilter showrefstop headids tagids otherrefids
8704 global curview
8706 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8707 set refs {}
8708 foreach n [array names headids] {
8709 if {[string match $reflistfilter $n]} {
8710 if {[commitinview $headids($n) $curview]} {
8711 lappend refs [list $n H]
8712 } else {
8713 interestedin $headids($n) {run refill_reflist}
8717 foreach n [array names tagids] {
8718 if {[string match $reflistfilter $n]} {
8719 if {[commitinview $tagids($n) $curview]} {
8720 lappend refs [list $n T]
8721 } else {
8722 interestedin $tagids($n) {run refill_reflist}
8726 foreach n [array names otherrefids] {
8727 if {[string match $reflistfilter $n]} {
8728 if {[commitinview $otherrefids($n) $curview]} {
8729 lappend refs [list $n o]
8730 } else {
8731 interestedin $otherrefids($n) {run refill_reflist}
8735 set refs [lsort -index 0 $refs]
8736 if {$refs eq $reflist} return
8738 # Update the contents of $showrefstop.list according to the
8739 # differences between $reflist (old) and $refs (new)
8740 $showrefstop.list conf -state normal
8741 $showrefstop.list insert end "\n"
8742 set i 0
8743 set j 0
8744 while {$i < [llength $reflist] || $j < [llength $refs]} {
8745 if {$i < [llength $reflist]} {
8746 if {$j < [llength $refs]} {
8747 set cmp [string compare [lindex $reflist $i 0] \
8748 [lindex $refs $j 0]]
8749 if {$cmp == 0} {
8750 set cmp [string compare [lindex $reflist $i 1] \
8751 [lindex $refs $j 1]]
8753 } else {
8754 set cmp -1
8756 } else {
8757 set cmp 1
8759 switch -- $cmp {
8760 -1 {
8761 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8762 incr i
8765 incr i
8766 incr j
8769 set l [expr {$j + 1}]
8770 $showrefstop.list image create $l.0 -align baseline \
8771 -image reficon-[lindex $refs $j 1] -padx 2
8772 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8773 incr j
8777 set reflist $refs
8778 # delete last newline
8779 $showrefstop.list delete end-2c end-1c
8780 $showrefstop.list conf -state disabled
8783 # Stuff for finding nearby tags
8784 proc getallcommits {} {
8785 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8786 global idheads idtags idotherrefs allparents tagobjid
8788 if {![info exists allcommits]} {
8789 set nextarc 0
8790 set allcommits 0
8791 set seeds {}
8792 set allcwait 0
8793 set cachedarcs 0
8794 set allccache [file join [gitdir] "gitk.cache"]
8795 if {![catch {
8796 set f [open $allccache r]
8797 set allcwait 1
8798 getcache $f
8799 }]} return
8802 if {$allcwait} {
8803 return
8805 set cmd [list | git rev-list --parents]
8806 set allcupdate [expr {$seeds ne {}}]
8807 if {!$allcupdate} {
8808 set ids "--all"
8809 } else {
8810 set refs [concat [array names idheads] [array names idtags] \
8811 [array names idotherrefs]]
8812 set ids {}
8813 set tagobjs {}
8814 foreach name [array names tagobjid] {
8815 lappend tagobjs $tagobjid($name)
8817 foreach id [lsort -unique $refs] {
8818 if {![info exists allparents($id)] &&
8819 [lsearch -exact $tagobjs $id] < 0} {
8820 lappend ids $id
8823 if {$ids ne {}} {
8824 foreach id $seeds {
8825 lappend ids "^$id"
8829 if {$ids ne {}} {
8830 set fd [open [concat $cmd $ids] r]
8831 fconfigure $fd -blocking 0
8832 incr allcommits
8833 nowbusy allcommits
8834 filerun $fd [list getallclines $fd]
8835 } else {
8836 dispneartags 0
8840 # Since most commits have 1 parent and 1 child, we group strings of
8841 # such commits into "arcs" joining branch/merge points (BMPs), which
8842 # are commits that either don't have 1 parent or don't have 1 child.
8844 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8845 # arcout(id) - outgoing arcs for BMP
8846 # arcids(a) - list of IDs on arc including end but not start
8847 # arcstart(a) - BMP ID at start of arc
8848 # arcend(a) - BMP ID at end of arc
8849 # growing(a) - arc a is still growing
8850 # arctags(a) - IDs out of arcids (excluding end) that have tags
8851 # archeads(a) - IDs out of arcids (excluding end) that have heads
8852 # The start of an arc is at the descendent end, so "incoming" means
8853 # coming from descendents, and "outgoing" means going towards ancestors.
8855 proc getallclines {fd} {
8856 global allparents allchildren idtags idheads nextarc
8857 global arcnos arcids arctags arcout arcend arcstart archeads growing
8858 global seeds allcommits cachedarcs allcupdate
8860 set nid 0
8861 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8862 set id [lindex $line 0]
8863 if {[info exists allparents($id)]} {
8864 # seen it already
8865 continue
8867 set cachedarcs 0
8868 set olds [lrange $line 1 end]
8869 set allparents($id) $olds
8870 if {![info exists allchildren($id)]} {
8871 set allchildren($id) {}
8872 set arcnos($id) {}
8873 lappend seeds $id
8874 } else {
8875 set a $arcnos($id)
8876 if {[llength $olds] == 1 && [llength $a] == 1} {
8877 lappend arcids($a) $id
8878 if {[info exists idtags($id)]} {
8879 lappend arctags($a) $id
8881 if {[info exists idheads($id)]} {
8882 lappend archeads($a) $id
8884 if {[info exists allparents($olds)]} {
8885 # seen parent already
8886 if {![info exists arcout($olds)]} {
8887 splitarc $olds
8889 lappend arcids($a) $olds
8890 set arcend($a) $olds
8891 unset growing($a)
8893 lappend allchildren($olds) $id
8894 lappend arcnos($olds) $a
8895 continue
8898 foreach a $arcnos($id) {
8899 lappend arcids($a) $id
8900 set arcend($a) $id
8901 unset growing($a)
8904 set ao {}
8905 foreach p $olds {
8906 lappend allchildren($p) $id
8907 set a [incr nextarc]
8908 set arcstart($a) $id
8909 set archeads($a) {}
8910 set arctags($a) {}
8911 set archeads($a) {}
8912 set arcids($a) {}
8913 lappend ao $a
8914 set growing($a) 1
8915 if {[info exists allparents($p)]} {
8916 # seen it already, may need to make a new branch
8917 if {![info exists arcout($p)]} {
8918 splitarc $p
8920 lappend arcids($a) $p
8921 set arcend($a) $p
8922 unset growing($a)
8924 lappend arcnos($p) $a
8926 set arcout($id) $ao
8928 if {$nid > 0} {
8929 global cached_dheads cached_dtags cached_atags
8930 catch {unset cached_dheads}
8931 catch {unset cached_dtags}
8932 catch {unset cached_atags}
8934 if {![eof $fd]} {
8935 return [expr {$nid >= 1000? 2: 1}]
8937 set cacheok 1
8938 if {[catch {
8939 fconfigure $fd -blocking 1
8940 close $fd
8941 } err]} {
8942 # got an error reading the list of commits
8943 # if we were updating, try rereading the whole thing again
8944 if {$allcupdate} {
8945 incr allcommits -1
8946 dropcache $err
8947 return
8949 error_popup "[mc "Error reading commit topology information;\
8950 branch and preceding/following tag information\
8951 will be incomplete."]\n($err)"
8952 set cacheok 0
8954 if {[incr allcommits -1] == 0} {
8955 notbusy allcommits
8956 if {$cacheok} {
8957 run savecache
8960 dispneartags 0
8961 return 0
8964 proc recalcarc {a} {
8965 global arctags archeads arcids idtags idheads
8967 set at {}
8968 set ah {}
8969 foreach id [lrange $arcids($a) 0 end-1] {
8970 if {[info exists idtags($id)]} {
8971 lappend at $id
8973 if {[info exists idheads($id)]} {
8974 lappend ah $id
8977 set arctags($a) $at
8978 set archeads($a) $ah
8981 proc splitarc {p} {
8982 global arcnos arcids nextarc arctags archeads idtags idheads
8983 global arcstart arcend arcout allparents growing
8985 set a $arcnos($p)
8986 if {[llength $a] != 1} {
8987 puts "oops splitarc called but [llength $a] arcs already"
8988 return
8990 set a [lindex $a 0]
8991 set i [lsearch -exact $arcids($a) $p]
8992 if {$i < 0} {
8993 puts "oops splitarc $p not in arc $a"
8994 return
8996 set na [incr nextarc]
8997 if {[info exists arcend($a)]} {
8998 set arcend($na) $arcend($a)
8999 } else {
9000 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9001 set j [lsearch -exact $arcnos($l) $a]
9002 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9004 set tail [lrange $arcids($a) [expr {$i+1}] end]
9005 set arcids($a) [lrange $arcids($a) 0 $i]
9006 set arcend($a) $p
9007 set arcstart($na) $p
9008 set arcout($p) $na
9009 set arcids($na) $tail
9010 if {[info exists growing($a)]} {
9011 set growing($na) 1
9012 unset growing($a)
9015 foreach id $tail {
9016 if {[llength $arcnos($id)] == 1} {
9017 set arcnos($id) $na
9018 } else {
9019 set j [lsearch -exact $arcnos($id) $a]
9020 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9024 # reconstruct tags and heads lists
9025 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9026 recalcarc $a
9027 recalcarc $na
9028 } else {
9029 set arctags($na) {}
9030 set archeads($na) {}
9034 # Update things for a new commit added that is a child of one
9035 # existing commit. Used when cherry-picking.
9036 proc addnewchild {id p} {
9037 global allparents allchildren idtags nextarc
9038 global arcnos arcids arctags arcout arcend arcstart archeads growing
9039 global seeds allcommits
9041 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9042 set allparents($id) [list $p]
9043 set allchildren($id) {}
9044 set arcnos($id) {}
9045 lappend seeds $id
9046 lappend allchildren($p) $id
9047 set a [incr nextarc]
9048 set arcstart($a) $id
9049 set archeads($a) {}
9050 set arctags($a) {}
9051 set arcids($a) [list $p]
9052 set arcend($a) $p
9053 if {![info exists arcout($p)]} {
9054 splitarc $p
9056 lappend arcnos($p) $a
9057 set arcout($id) [list $a]
9060 # This implements a cache for the topology information.
9061 # The cache saves, for each arc, the start and end of the arc,
9062 # the ids on the arc, and the outgoing arcs from the end.
9063 proc readcache {f} {
9064 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9065 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9066 global allcwait
9068 set a $nextarc
9069 set lim $cachedarcs
9070 if {$lim - $a > 500} {
9071 set lim [expr {$a + 500}]
9073 if {[catch {
9074 if {$a == $lim} {
9075 # finish reading the cache and setting up arctags, etc.
9076 set line [gets $f]
9077 if {$line ne "1"} {error "bad final version"}
9078 close $f
9079 foreach id [array names idtags] {
9080 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9081 [llength $allparents($id)] == 1} {
9082 set a [lindex $arcnos($id) 0]
9083 if {$arctags($a) eq {}} {
9084 recalcarc $a
9088 foreach id [array names idheads] {
9089 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9090 [llength $allparents($id)] == 1} {
9091 set a [lindex $arcnos($id) 0]
9092 if {$archeads($a) eq {}} {
9093 recalcarc $a
9097 foreach id [lsort -unique $possible_seeds] {
9098 if {$arcnos($id) eq {}} {
9099 lappend seeds $id
9102 set allcwait 0
9103 } else {
9104 while {[incr a] <= $lim} {
9105 set line [gets $f]
9106 if {[llength $line] != 3} {error "bad line"}
9107 set s [lindex $line 0]
9108 set arcstart($a) $s
9109 lappend arcout($s) $a
9110 if {![info exists arcnos($s)]} {
9111 lappend possible_seeds $s
9112 set arcnos($s) {}
9114 set e [lindex $line 1]
9115 if {$e eq {}} {
9116 set growing($a) 1
9117 } else {
9118 set arcend($a) $e
9119 if {![info exists arcout($e)]} {
9120 set arcout($e) {}
9123 set arcids($a) [lindex $line 2]
9124 foreach id $arcids($a) {
9125 lappend allparents($s) $id
9126 set s $id
9127 lappend arcnos($id) $a
9129 if {![info exists allparents($s)]} {
9130 set allparents($s) {}
9132 set arctags($a) {}
9133 set archeads($a) {}
9135 set nextarc [expr {$a - 1}]
9137 } err]} {
9138 dropcache $err
9139 return 0
9141 if {!$allcwait} {
9142 getallcommits
9144 return $allcwait
9147 proc getcache {f} {
9148 global nextarc cachedarcs possible_seeds
9150 if {[catch {
9151 set line [gets $f]
9152 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9153 # make sure it's an integer
9154 set cachedarcs [expr {int([lindex $line 1])}]
9155 if {$cachedarcs < 0} {error "bad number of arcs"}
9156 set nextarc 0
9157 set possible_seeds {}
9158 run readcache $f
9159 } err]} {
9160 dropcache $err
9162 return 0
9165 proc dropcache {err} {
9166 global allcwait nextarc cachedarcs seeds
9168 #puts "dropping cache ($err)"
9169 foreach v {arcnos arcout arcids arcstart arcend growing \
9170 arctags archeads allparents allchildren} {
9171 global $v
9172 catch {unset $v}
9174 set allcwait 0
9175 set nextarc 0
9176 set cachedarcs 0
9177 set seeds {}
9178 getallcommits
9181 proc writecache {f} {
9182 global cachearc cachedarcs allccache
9183 global arcstart arcend arcnos arcids arcout
9185 set a $cachearc
9186 set lim $cachedarcs
9187 if {$lim - $a > 1000} {
9188 set lim [expr {$a + 1000}]
9190 if {[catch {
9191 while {[incr a] <= $lim} {
9192 if {[info exists arcend($a)]} {
9193 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9194 } else {
9195 puts $f [list $arcstart($a) {} $arcids($a)]
9198 } err]} {
9199 catch {close $f}
9200 catch {file delete $allccache}
9201 #puts "writing cache failed ($err)"
9202 return 0
9204 set cachearc [expr {$a - 1}]
9205 if {$a > $cachedarcs} {
9206 puts $f "1"
9207 close $f
9208 return 0
9210 return 1
9213 proc savecache {} {
9214 global nextarc cachedarcs cachearc allccache
9216 if {$nextarc == $cachedarcs} return
9217 set cachearc 0
9218 set cachedarcs $nextarc
9219 catch {
9220 set f [open $allccache w]
9221 puts $f [list 1 $cachedarcs]
9222 run writecache $f
9226 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9227 # or 0 if neither is true.
9228 proc anc_or_desc {a b} {
9229 global arcout arcstart arcend arcnos cached_isanc
9231 if {$arcnos($a) eq $arcnos($b)} {
9232 # Both are on the same arc(s); either both are the same BMP,
9233 # or if one is not a BMP, the other is also not a BMP or is
9234 # the BMP at end of the arc (and it only has 1 incoming arc).
9235 # Or both can be BMPs with no incoming arcs.
9236 if {$a eq $b || $arcnos($a) eq {}} {
9237 return 0
9239 # assert {[llength $arcnos($a)] == 1}
9240 set arc [lindex $arcnos($a) 0]
9241 set i [lsearch -exact $arcids($arc) $a]
9242 set j [lsearch -exact $arcids($arc) $b]
9243 if {$i < 0 || $i > $j} {
9244 return 1
9245 } else {
9246 return -1
9250 if {![info exists arcout($a)]} {
9251 set arc [lindex $arcnos($a) 0]
9252 if {[info exists arcend($arc)]} {
9253 set aend $arcend($arc)
9254 } else {
9255 set aend {}
9257 set a $arcstart($arc)
9258 } else {
9259 set aend $a
9261 if {![info exists arcout($b)]} {
9262 set arc [lindex $arcnos($b) 0]
9263 if {[info exists arcend($arc)]} {
9264 set bend $arcend($arc)
9265 } else {
9266 set bend {}
9268 set b $arcstart($arc)
9269 } else {
9270 set bend $b
9272 if {$a eq $bend} {
9273 return 1
9275 if {$b eq $aend} {
9276 return -1
9278 if {[info exists cached_isanc($a,$bend)]} {
9279 if {$cached_isanc($a,$bend)} {
9280 return 1
9283 if {[info exists cached_isanc($b,$aend)]} {
9284 if {$cached_isanc($b,$aend)} {
9285 return -1
9287 if {[info exists cached_isanc($a,$bend)]} {
9288 return 0
9292 set todo [list $a $b]
9293 set anc($a) a
9294 set anc($b) b
9295 for {set i 0} {$i < [llength $todo]} {incr i} {
9296 set x [lindex $todo $i]
9297 if {$anc($x) eq {}} {
9298 continue
9300 foreach arc $arcnos($x) {
9301 set xd $arcstart($arc)
9302 if {$xd eq $bend} {
9303 set cached_isanc($a,$bend) 1
9304 set cached_isanc($b,$aend) 0
9305 return 1
9306 } elseif {$xd eq $aend} {
9307 set cached_isanc($b,$aend) 1
9308 set cached_isanc($a,$bend) 0
9309 return -1
9311 if {![info exists anc($xd)]} {
9312 set anc($xd) $anc($x)
9313 lappend todo $xd
9314 } elseif {$anc($xd) ne $anc($x)} {
9315 set anc($xd) {}
9319 set cached_isanc($a,$bend) 0
9320 set cached_isanc($b,$aend) 0
9321 return 0
9324 # This identifies whether $desc has an ancestor that is
9325 # a growing tip of the graph and which is not an ancestor of $anc
9326 # and returns 0 if so and 1 if not.
9327 # If we subsequently discover a tag on such a growing tip, and that
9328 # turns out to be a descendent of $anc (which it could, since we
9329 # don't necessarily see children before parents), then $desc
9330 # isn't a good choice to display as a descendent tag of
9331 # $anc (since it is the descendent of another tag which is
9332 # a descendent of $anc). Similarly, $anc isn't a good choice to
9333 # display as a ancestor tag of $desc.
9335 proc is_certain {desc anc} {
9336 global arcnos arcout arcstart arcend growing problems
9338 set certain {}
9339 if {[llength $arcnos($anc)] == 1} {
9340 # tags on the same arc are certain
9341 if {$arcnos($desc) eq $arcnos($anc)} {
9342 return 1
9344 if {![info exists arcout($anc)]} {
9345 # if $anc is partway along an arc, use the start of the arc instead
9346 set a [lindex $arcnos($anc) 0]
9347 set anc $arcstart($a)
9350 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9351 set x $desc
9352 } else {
9353 set a [lindex $arcnos($desc) 0]
9354 set x $arcend($a)
9356 if {$x == $anc} {
9357 return 1
9359 set anclist [list $x]
9360 set dl($x) 1
9361 set nnh 1
9362 set ngrowanc 0
9363 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9364 set x [lindex $anclist $i]
9365 if {$dl($x)} {
9366 incr nnh -1
9368 set done($x) 1
9369 foreach a $arcout($x) {
9370 if {[info exists growing($a)]} {
9371 if {![info exists growanc($x)] && $dl($x)} {
9372 set growanc($x) 1
9373 incr ngrowanc
9375 } else {
9376 set y $arcend($a)
9377 if {[info exists dl($y)]} {
9378 if {$dl($y)} {
9379 if {!$dl($x)} {
9380 set dl($y) 0
9381 if {![info exists done($y)]} {
9382 incr nnh -1
9384 if {[info exists growanc($x)]} {
9385 incr ngrowanc -1
9387 set xl [list $y]
9388 for {set k 0} {$k < [llength $xl]} {incr k} {
9389 set z [lindex $xl $k]
9390 foreach c $arcout($z) {
9391 if {[info exists arcend($c)]} {
9392 set v $arcend($c)
9393 if {[info exists dl($v)] && $dl($v)} {
9394 set dl($v) 0
9395 if {![info exists done($v)]} {
9396 incr nnh -1
9398 if {[info exists growanc($v)]} {
9399 incr ngrowanc -1
9401 lappend xl $v
9408 } elseif {$y eq $anc || !$dl($x)} {
9409 set dl($y) 0
9410 lappend anclist $y
9411 } else {
9412 set dl($y) 1
9413 lappend anclist $y
9414 incr nnh
9419 foreach x [array names growanc] {
9420 if {$dl($x)} {
9421 return 0
9423 return 0
9425 return 1
9428 proc validate_arctags {a} {
9429 global arctags idtags
9431 set i -1
9432 set na $arctags($a)
9433 foreach id $arctags($a) {
9434 incr i
9435 if {![info exists idtags($id)]} {
9436 set na [lreplace $na $i $i]
9437 incr i -1
9440 set arctags($a) $na
9443 proc validate_archeads {a} {
9444 global archeads idheads
9446 set i -1
9447 set na $archeads($a)
9448 foreach id $archeads($a) {
9449 incr i
9450 if {![info exists idheads($id)]} {
9451 set na [lreplace $na $i $i]
9452 incr i -1
9455 set archeads($a) $na
9458 # Return the list of IDs that have tags that are descendents of id,
9459 # ignoring IDs that are descendents of IDs already reported.
9460 proc desctags {id} {
9461 global arcnos arcstart arcids arctags idtags allparents
9462 global growing cached_dtags
9464 if {![info exists allparents($id)]} {
9465 return {}
9467 set t1 [clock clicks -milliseconds]
9468 set argid $id
9469 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9470 # part-way along an arc; check that arc first
9471 set a [lindex $arcnos($id) 0]
9472 if {$arctags($a) ne {}} {
9473 validate_arctags $a
9474 set i [lsearch -exact $arcids($a) $id]
9475 set tid {}
9476 foreach t $arctags($a) {
9477 set j [lsearch -exact $arcids($a) $t]
9478 if {$j >= $i} break
9479 set tid $t
9481 if {$tid ne {}} {
9482 return $tid
9485 set id $arcstart($a)
9486 if {[info exists idtags($id)]} {
9487 return $id
9490 if {[info exists cached_dtags($id)]} {
9491 return $cached_dtags($id)
9494 set origid $id
9495 set todo [list $id]
9496 set queued($id) 1
9497 set nc 1
9498 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9499 set id [lindex $todo $i]
9500 set done($id) 1
9501 set ta [info exists hastaggedancestor($id)]
9502 if {!$ta} {
9503 incr nc -1
9505 # ignore tags on starting node
9506 if {!$ta && $i > 0} {
9507 if {[info exists idtags($id)]} {
9508 set tagloc($id) $id
9509 set ta 1
9510 } elseif {[info exists cached_dtags($id)]} {
9511 set tagloc($id) $cached_dtags($id)
9512 set ta 1
9515 foreach a $arcnos($id) {
9516 set d $arcstart($a)
9517 if {!$ta && $arctags($a) ne {}} {
9518 validate_arctags $a
9519 if {$arctags($a) ne {}} {
9520 lappend tagloc($id) [lindex $arctags($a) end]
9523 if {$ta || $arctags($a) ne {}} {
9524 set tomark [list $d]
9525 for {set j 0} {$j < [llength $tomark]} {incr j} {
9526 set dd [lindex $tomark $j]
9527 if {![info exists hastaggedancestor($dd)]} {
9528 if {[info exists done($dd)]} {
9529 foreach b $arcnos($dd) {
9530 lappend tomark $arcstart($b)
9532 if {[info exists tagloc($dd)]} {
9533 unset tagloc($dd)
9535 } elseif {[info exists queued($dd)]} {
9536 incr nc -1
9538 set hastaggedancestor($dd) 1
9542 if {![info exists queued($d)]} {
9543 lappend todo $d
9544 set queued($d) 1
9545 if {![info exists hastaggedancestor($d)]} {
9546 incr nc
9551 set tags {}
9552 foreach id [array names tagloc] {
9553 if {![info exists hastaggedancestor($id)]} {
9554 foreach t $tagloc($id) {
9555 if {[lsearch -exact $tags $t] < 0} {
9556 lappend tags $t
9561 set t2 [clock clicks -milliseconds]
9562 set loopix $i
9564 # remove tags that are descendents of other tags
9565 for {set i 0} {$i < [llength $tags]} {incr i} {
9566 set a [lindex $tags $i]
9567 for {set j 0} {$j < $i} {incr j} {
9568 set b [lindex $tags $j]
9569 set r [anc_or_desc $a $b]
9570 if {$r == 1} {
9571 set tags [lreplace $tags $j $j]
9572 incr j -1
9573 incr i -1
9574 } elseif {$r == -1} {
9575 set tags [lreplace $tags $i $i]
9576 incr i -1
9577 break
9582 if {[array names growing] ne {}} {
9583 # graph isn't finished, need to check if any tag could get
9584 # eclipsed by another tag coming later. Simply ignore any
9585 # tags that could later get eclipsed.
9586 set ctags {}
9587 foreach t $tags {
9588 if {[is_certain $t $origid]} {
9589 lappend ctags $t
9592 if {$tags eq $ctags} {
9593 set cached_dtags($origid) $tags
9594 } else {
9595 set tags $ctags
9597 } else {
9598 set cached_dtags($origid) $tags
9600 set t3 [clock clicks -milliseconds]
9601 if {0 && $t3 - $t1 >= 100} {
9602 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9603 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9605 return $tags
9608 proc anctags {id} {
9609 global arcnos arcids arcout arcend arctags idtags allparents
9610 global growing cached_atags
9612 if {![info exists allparents($id)]} {
9613 return {}
9615 set t1 [clock clicks -milliseconds]
9616 set argid $id
9617 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9618 # part-way along an arc; check that arc first
9619 set a [lindex $arcnos($id) 0]
9620 if {$arctags($a) ne {}} {
9621 validate_arctags $a
9622 set i [lsearch -exact $arcids($a) $id]
9623 foreach t $arctags($a) {
9624 set j [lsearch -exact $arcids($a) $t]
9625 if {$j > $i} {
9626 return $t
9630 if {![info exists arcend($a)]} {
9631 return {}
9633 set id $arcend($a)
9634 if {[info exists idtags($id)]} {
9635 return $id
9638 if {[info exists cached_atags($id)]} {
9639 return $cached_atags($id)
9642 set origid $id
9643 set todo [list $id]
9644 set queued($id) 1
9645 set taglist {}
9646 set nc 1
9647 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9648 set id [lindex $todo $i]
9649 set done($id) 1
9650 set td [info exists hastaggeddescendent($id)]
9651 if {!$td} {
9652 incr nc -1
9654 # ignore tags on starting node
9655 if {!$td && $i > 0} {
9656 if {[info exists idtags($id)]} {
9657 set tagloc($id) $id
9658 set td 1
9659 } elseif {[info exists cached_atags($id)]} {
9660 set tagloc($id) $cached_atags($id)
9661 set td 1
9664 foreach a $arcout($id) {
9665 if {!$td && $arctags($a) ne {}} {
9666 validate_arctags $a
9667 if {$arctags($a) ne {}} {
9668 lappend tagloc($id) [lindex $arctags($a) 0]
9671 if {![info exists arcend($a)]} continue
9672 set d $arcend($a)
9673 if {$td || $arctags($a) ne {}} {
9674 set tomark [list $d]
9675 for {set j 0} {$j < [llength $tomark]} {incr j} {
9676 set dd [lindex $tomark $j]
9677 if {![info exists hastaggeddescendent($dd)]} {
9678 if {[info exists done($dd)]} {
9679 foreach b $arcout($dd) {
9680 if {[info exists arcend($b)]} {
9681 lappend tomark $arcend($b)
9684 if {[info exists tagloc($dd)]} {
9685 unset tagloc($dd)
9687 } elseif {[info exists queued($dd)]} {
9688 incr nc -1
9690 set hastaggeddescendent($dd) 1
9694 if {![info exists queued($d)]} {
9695 lappend todo $d
9696 set queued($d) 1
9697 if {![info exists hastaggeddescendent($d)]} {
9698 incr nc
9703 set t2 [clock clicks -milliseconds]
9704 set loopix $i
9705 set tags {}
9706 foreach id [array names tagloc] {
9707 if {![info exists hastaggeddescendent($id)]} {
9708 foreach t $tagloc($id) {
9709 if {[lsearch -exact $tags $t] < 0} {
9710 lappend tags $t
9716 # remove tags that are ancestors of other tags
9717 for {set i 0} {$i < [llength $tags]} {incr i} {
9718 set a [lindex $tags $i]
9719 for {set j 0} {$j < $i} {incr j} {
9720 set b [lindex $tags $j]
9721 set r [anc_or_desc $a $b]
9722 if {$r == -1} {
9723 set tags [lreplace $tags $j $j]
9724 incr j -1
9725 incr i -1
9726 } elseif {$r == 1} {
9727 set tags [lreplace $tags $i $i]
9728 incr i -1
9729 break
9734 if {[array names growing] ne {}} {
9735 # graph isn't finished, need to check if any tag could get
9736 # eclipsed by another tag coming later. Simply ignore any
9737 # tags that could later get eclipsed.
9738 set ctags {}
9739 foreach t $tags {
9740 if {[is_certain $origid $t]} {
9741 lappend ctags $t
9744 if {$tags eq $ctags} {
9745 set cached_atags($origid) $tags
9746 } else {
9747 set tags $ctags
9749 } else {
9750 set cached_atags($origid) $tags
9752 set t3 [clock clicks -milliseconds]
9753 if {0 && $t3 - $t1 >= 100} {
9754 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9755 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9757 return $tags
9760 # Return the list of IDs that have heads that are descendents of id,
9761 # including id itself if it has a head.
9762 proc descheads {id} {
9763 global arcnos arcstart arcids archeads idheads cached_dheads
9764 global allparents
9766 if {![info exists allparents($id)]} {
9767 return {}
9769 set aret {}
9770 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9771 # part-way along an arc; check it first
9772 set a [lindex $arcnos($id) 0]
9773 if {$archeads($a) ne {}} {
9774 validate_archeads $a
9775 set i [lsearch -exact $arcids($a) $id]
9776 foreach t $archeads($a) {
9777 set j [lsearch -exact $arcids($a) $t]
9778 if {$j > $i} break
9779 lappend aret $t
9782 set id $arcstart($a)
9784 set origid $id
9785 set todo [list $id]
9786 set seen($id) 1
9787 set ret {}
9788 for {set i 0} {$i < [llength $todo]} {incr i} {
9789 set id [lindex $todo $i]
9790 if {[info exists cached_dheads($id)]} {
9791 set ret [concat $ret $cached_dheads($id)]
9792 } else {
9793 if {[info exists idheads($id)]} {
9794 lappend ret $id
9796 foreach a $arcnos($id) {
9797 if {$archeads($a) ne {}} {
9798 validate_archeads $a
9799 if {$archeads($a) ne {}} {
9800 set ret [concat $ret $archeads($a)]
9803 set d $arcstart($a)
9804 if {![info exists seen($d)]} {
9805 lappend todo $d
9806 set seen($d) 1
9811 set ret [lsort -unique $ret]
9812 set cached_dheads($origid) $ret
9813 return [concat $ret $aret]
9816 proc addedtag {id} {
9817 global arcnos arcout cached_dtags cached_atags
9819 if {![info exists arcnos($id)]} return
9820 if {![info exists arcout($id)]} {
9821 recalcarc [lindex $arcnos($id) 0]
9823 catch {unset cached_dtags}
9824 catch {unset cached_atags}
9827 proc addedhead {hid head} {
9828 global arcnos arcout cached_dheads
9830 if {![info exists arcnos($hid)]} return
9831 if {![info exists arcout($hid)]} {
9832 recalcarc [lindex $arcnos($hid) 0]
9834 catch {unset cached_dheads}
9837 proc removedhead {hid head} {
9838 global cached_dheads
9840 catch {unset cached_dheads}
9843 proc movedhead {hid head} {
9844 global arcnos arcout cached_dheads
9846 if {![info exists arcnos($hid)]} return
9847 if {![info exists arcout($hid)]} {
9848 recalcarc [lindex $arcnos($hid) 0]
9850 catch {unset cached_dheads}
9853 proc changedrefs {} {
9854 global cached_dheads cached_dtags cached_atags
9855 global arctags archeads arcnos arcout idheads idtags
9857 foreach id [concat [array names idheads] [array names idtags]] {
9858 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9859 set a [lindex $arcnos($id) 0]
9860 if {![info exists donearc($a)]} {
9861 recalcarc $a
9862 set donearc($a) 1
9866 catch {unset cached_dtags}
9867 catch {unset cached_atags}
9868 catch {unset cached_dheads}
9871 proc rereadrefs {} {
9872 global idtags idheads idotherrefs mainheadid
9874 set refids [concat [array names idtags] \
9875 [array names idheads] [array names idotherrefs]]
9876 foreach id $refids {
9877 if {![info exists ref($id)]} {
9878 set ref($id) [listrefs $id]
9881 set oldmainhead $mainheadid
9882 readrefs
9883 changedrefs
9884 set refids [lsort -unique [concat $refids [array names idtags] \
9885 [array names idheads] [array names idotherrefs]]]
9886 foreach id $refids {
9887 set v [listrefs $id]
9888 if {![info exists ref($id)] || $ref($id) != $v} {
9889 redrawtags $id
9892 if {$oldmainhead ne $mainheadid} {
9893 redrawtags $oldmainhead
9894 redrawtags $mainheadid
9896 run refill_reflist
9899 proc listrefs {id} {
9900 global idtags idheads idotherrefs
9902 set x {}
9903 if {[info exists idtags($id)]} {
9904 set x $idtags($id)
9906 set y {}
9907 if {[info exists idheads($id)]} {
9908 set y $idheads($id)
9910 set z {}
9911 if {[info exists idotherrefs($id)]} {
9912 set z $idotherrefs($id)
9914 return [list $x $y $z]
9917 proc showtag {tag isnew} {
9918 global ctext tagcontents tagids linknum tagobjid
9920 if {$isnew} {
9921 addtohistory [list showtag $tag 0]
9923 $ctext conf -state normal
9924 clear_ctext
9925 settabs 0
9926 set linknum 0
9927 if {![info exists tagcontents($tag)]} {
9928 catch {
9929 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9932 if {[info exists tagcontents($tag)]} {
9933 set text $tagcontents($tag)
9934 } else {
9935 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9937 appendwithlinks $text {}
9938 $ctext conf -state disabled
9939 init_flist {}
9942 proc doquit {} {
9943 global stopped
9944 global gitktmpdir
9946 set stopped 100
9947 savestuff .
9948 destroy .
9950 if {[info exists gitktmpdir]} {
9951 catch {file delete -force $gitktmpdir}
9955 proc mkfontdisp {font top which} {
9956 global fontattr fontpref $font
9958 set fontpref($font) [set $font]
9959 button $top.${font}but -text $which -font optionfont \
9960 -command [list choosefont $font $which]
9961 label $top.$font -relief flat -font $font \
9962 -text $fontattr($font,family) -justify left
9963 grid x $top.${font}but $top.$font -sticky w
9966 proc choosefont {font which} {
9967 global fontparam fontlist fonttop fontattr
9968 global prefstop
9970 set fontparam(which) $which
9971 set fontparam(font) $font
9972 set fontparam(family) [font actual $font -family]
9973 set fontparam(size) $fontattr($font,size)
9974 set fontparam(weight) $fontattr($font,weight)
9975 set fontparam(slant) $fontattr($font,slant)
9976 set top .gitkfont
9977 set fonttop $top
9978 if {![winfo exists $top]} {
9979 font create sample
9980 eval font config sample [font actual $font]
9981 toplevel $top
9982 make_transient $top $prefstop
9983 wm title $top [mc "Gitk font chooser"]
9984 label $top.l -textvariable fontparam(which)
9985 pack $top.l -side top
9986 set fontlist [lsort [font families]]
9987 frame $top.f
9988 listbox $top.f.fam -listvariable fontlist \
9989 -yscrollcommand [list $top.f.sb set]
9990 bind $top.f.fam <<ListboxSelect>> selfontfam
9991 scrollbar $top.f.sb -command [list $top.f.fam yview]
9992 pack $top.f.sb -side right -fill y
9993 pack $top.f.fam -side left -fill both -expand 1
9994 pack $top.f -side top -fill both -expand 1
9995 frame $top.g
9996 spinbox $top.g.size -from 4 -to 40 -width 4 \
9997 -textvariable fontparam(size) \
9998 -validatecommand {string is integer -strict %s}
9999 checkbutton $top.g.bold -padx 5 \
10000 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10001 -variable fontparam(weight) -onvalue bold -offvalue normal
10002 checkbutton $top.g.ital -padx 5 \
10003 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10004 -variable fontparam(slant) -onvalue italic -offvalue roman
10005 pack $top.g.size $top.g.bold $top.g.ital -side left
10006 pack $top.g -side top
10007 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10008 -background white
10009 $top.c create text 100 25 -anchor center -text $which -font sample \
10010 -fill black -tags text
10011 bind $top.c <Configure> [list centertext $top.c]
10012 pack $top.c -side top -fill x
10013 frame $top.buts
10014 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10015 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10016 bind $top <Key-Return> fontok
10017 bind $top <Key-Escape> fontcan
10018 grid $top.buts.ok $top.buts.can
10019 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10020 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10021 pack $top.buts -side bottom -fill x
10022 trace add variable fontparam write chg_fontparam
10023 } else {
10024 raise $top
10025 $top.c itemconf text -text $which
10027 set i [lsearch -exact $fontlist $fontparam(family)]
10028 if {$i >= 0} {
10029 $top.f.fam selection set $i
10030 $top.f.fam see $i
10034 proc centertext {w} {
10035 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10038 proc fontok {} {
10039 global fontparam fontpref prefstop
10041 set f $fontparam(font)
10042 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10043 if {$fontparam(weight) eq "bold"} {
10044 lappend fontpref($f) "bold"
10046 if {$fontparam(slant) eq "italic"} {
10047 lappend fontpref($f) "italic"
10049 set w $prefstop.$f
10050 $w conf -text $fontparam(family) -font $fontpref($f)
10052 fontcan
10055 proc fontcan {} {
10056 global fonttop fontparam
10058 if {[info exists fonttop]} {
10059 catch {destroy $fonttop}
10060 catch {font delete sample}
10061 unset fonttop
10062 unset fontparam
10066 proc selfontfam {} {
10067 global fonttop fontparam
10069 set i [$fonttop.f.fam curselection]
10070 if {$i ne {}} {
10071 set fontparam(family) [$fonttop.f.fam get $i]
10075 proc chg_fontparam {v sub op} {
10076 global fontparam
10078 font config sample -$sub $fontparam($sub)
10081 proc doprefs {} {
10082 global maxwidth maxgraphpct
10083 global oldprefs prefstop showneartags showlocalchanges
10084 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10085 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10087 set top .gitkprefs
10088 set prefstop $top
10089 if {[winfo exists $top]} {
10090 raise $top
10091 return
10093 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10094 limitdiffs tabstop perfile_attrs} {
10095 set oldprefs($v) [set $v]
10097 toplevel $top
10098 wm title $top [mc "Gitk preferences"]
10099 make_transient $top .
10100 label $top.ldisp -text [mc "Commit list display options"]
10101 grid $top.ldisp - -sticky w -pady 10
10102 label $top.spacer -text " "
10103 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10104 -font optionfont
10105 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10106 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10107 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10108 -font optionfont
10109 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10110 grid x $top.maxpctl $top.maxpct -sticky w
10111 checkbutton $top.showlocal -text [mc "Show local changes"] \
10112 -font optionfont -variable showlocalchanges
10113 grid x $top.showlocal -sticky w
10114 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10115 -font optionfont -variable autoselect
10116 grid x $top.autoselect -sticky w
10118 label $top.ddisp -text [mc "Diff display options"]
10119 grid $top.ddisp - -sticky w -pady 10
10120 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10121 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10122 grid x $top.tabstopl $top.tabstop -sticky w
10123 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10124 -font optionfont -variable showneartags
10125 grid x $top.ntag -sticky w
10126 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10127 -font optionfont -variable limitdiffs
10128 grid x $top.ldiff -sticky w
10129 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10130 -font optionfont -variable perfile_attrs
10131 grid x $top.lattr -sticky w
10133 entry $top.extdifft -textvariable extdifftool
10134 frame $top.extdifff
10135 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10136 -padx 10
10137 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10138 -command choose_extdiff
10139 pack $top.extdifff.l $top.extdifff.b -side left
10140 grid x $top.extdifff $top.extdifft -sticky w
10142 label $top.cdisp -text [mc "Colors: press to choose"]
10143 grid $top.cdisp - -sticky w -pady 10
10144 label $top.bg -padx 40 -relief sunk -background $bgcolor
10145 button $top.bgbut -text [mc "Background"] -font optionfont \
10146 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10147 grid x $top.bgbut $top.bg -sticky w
10148 label $top.fg -padx 40 -relief sunk -background $fgcolor
10149 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10150 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10151 grid x $top.fgbut $top.fg -sticky w
10152 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10153 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10154 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10155 [list $ctext tag conf d0 -foreground]]
10156 grid x $top.diffoldbut $top.diffold -sticky w
10157 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10158 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10159 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10160 [list $ctext tag conf dresult -foreground]]
10161 grid x $top.diffnewbut $top.diffnew -sticky w
10162 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10163 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10164 -command [list choosecolor diffcolors 2 $top.hunksep \
10165 [mc "diff hunk header"] \
10166 [list $ctext tag conf hunksep -foreground]]
10167 grid x $top.hunksepbut $top.hunksep -sticky w
10168 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10169 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10170 -command [list choosecolor markbgcolor {} $top.markbgsep \
10171 [mc "marked line background"] \
10172 [list $ctext tag conf omark -background]]
10173 grid x $top.markbgbut $top.markbgsep -sticky w
10174 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10175 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10176 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10177 grid x $top.selbgbut $top.selbgsep -sticky w
10179 label $top.cfont -text [mc "Fonts: press to choose"]
10180 grid $top.cfont - -sticky w -pady 10
10181 mkfontdisp mainfont $top [mc "Main font"]
10182 mkfontdisp textfont $top [mc "Diff display font"]
10183 mkfontdisp uifont $top [mc "User interface font"]
10185 frame $top.buts
10186 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10187 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10188 bind $top <Key-Return> prefsok
10189 bind $top <Key-Escape> prefscan
10190 grid $top.buts.ok $top.buts.can
10191 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10192 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10193 grid $top.buts - - -pady 10 -sticky ew
10194 bind $top <Visibility> "focus $top.buts.ok"
10197 proc choose_extdiff {} {
10198 global extdifftool
10200 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10201 if {$prog ne {}} {
10202 set extdifftool $prog
10206 proc choosecolor {v vi w x cmd} {
10207 global $v
10209 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10210 -title [mc "Gitk: choose color for %s" $x]]
10211 if {$c eq {}} return
10212 $w conf -background $c
10213 lset $v $vi $c
10214 eval $cmd $c
10217 proc setselbg {c} {
10218 global bglist cflist
10219 foreach w $bglist {
10220 $w configure -selectbackground $c
10222 $cflist tag configure highlight \
10223 -background [$cflist cget -selectbackground]
10224 allcanvs itemconf secsel -fill $c
10227 proc setbg {c} {
10228 global bglist
10230 foreach w $bglist {
10231 $w conf -background $c
10235 proc setfg {c} {
10236 global fglist canv
10238 foreach w $fglist {
10239 $w conf -foreground $c
10241 allcanvs itemconf text -fill $c
10242 $canv itemconf circle -outline $c
10245 proc prefscan {} {
10246 global oldprefs prefstop
10248 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10249 limitdiffs tabstop perfile_attrs} {
10250 global $v
10251 set $v $oldprefs($v)
10253 catch {destroy $prefstop}
10254 unset prefstop
10255 fontcan
10258 proc prefsok {} {
10259 global maxwidth maxgraphpct
10260 global oldprefs prefstop showneartags showlocalchanges
10261 global fontpref mainfont textfont uifont
10262 global limitdiffs treediffs perfile_attrs
10264 catch {destroy $prefstop}
10265 unset prefstop
10266 fontcan
10267 set fontchanged 0
10268 if {$mainfont ne $fontpref(mainfont)} {
10269 set mainfont $fontpref(mainfont)
10270 parsefont mainfont $mainfont
10271 eval font configure mainfont [fontflags mainfont]
10272 eval font configure mainfontbold [fontflags mainfont 1]
10273 setcoords
10274 set fontchanged 1
10276 if {$textfont ne $fontpref(textfont)} {
10277 set textfont $fontpref(textfont)
10278 parsefont textfont $textfont
10279 eval font configure textfont [fontflags textfont]
10280 eval font configure textfontbold [fontflags textfont 1]
10282 if {$uifont ne $fontpref(uifont)} {
10283 set uifont $fontpref(uifont)
10284 parsefont uifont $uifont
10285 eval font configure uifont [fontflags uifont]
10287 settabs
10288 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10289 if {$showlocalchanges} {
10290 doshowlocalchanges
10291 } else {
10292 dohidelocalchanges
10295 if {$limitdiffs != $oldprefs(limitdiffs) ||
10296 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10297 # treediffs elements are limited by path;
10298 # won't have encodings cached if perfile_attrs was just turned on
10299 catch {unset treediffs}
10301 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10302 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10303 redisplay
10304 } elseif {$showneartags != $oldprefs(showneartags) ||
10305 $limitdiffs != $oldprefs(limitdiffs)} {
10306 reselectline
10310 proc formatdate {d} {
10311 global datetimeformat
10312 if {$d ne {}} {
10313 set d [clock format $d -format $datetimeformat]
10315 return $d
10318 # This list of encoding names and aliases is distilled from
10319 # http://www.iana.org/assignments/character-sets.
10320 # Not all of them are supported by Tcl.
10321 set encoding_aliases {
10322 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10323 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10324 { ISO-10646-UTF-1 csISO10646UTF1 }
10325 { ISO_646.basic:1983 ref csISO646basic1983 }
10326 { INVARIANT csINVARIANT }
10327 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10328 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10329 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10330 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10331 { NATS-DANO iso-ir-9-1 csNATSDANO }
10332 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10333 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10334 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10335 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10336 { ISO-2022-KR csISO2022KR }
10337 { EUC-KR csEUCKR }
10338 { ISO-2022-JP csISO2022JP }
10339 { ISO-2022-JP-2 csISO2022JP2 }
10340 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10341 csISO13JISC6220jp }
10342 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10343 { IT iso-ir-15 ISO646-IT csISO15Italian }
10344 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10345 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10346 { greek7-old iso-ir-18 csISO18Greek7Old }
10347 { latin-greek iso-ir-19 csISO19LatinGreek }
10348 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10349 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10350 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10351 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10352 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10353 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10354 { INIS iso-ir-49 csISO49INIS }
10355 { INIS-8 iso-ir-50 csISO50INIS8 }
10356 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10357 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10358 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10359 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10360 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10361 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10362 csISO60Norwegian1 }
10363 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10364 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10365 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10366 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10367 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10368 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10369 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10370 { greek7 iso-ir-88 csISO88Greek7 }
10371 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10372 { iso-ir-90 csISO90 }
10373 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10374 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10375 csISO92JISC62991984b }
10376 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10377 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10378 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10379 csISO95JIS62291984handadd }
10380 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10381 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10382 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10383 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10384 CP819 csISOLatin1 }
10385 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10386 { T.61-7bit iso-ir-102 csISO102T617bit }
10387 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10388 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10389 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10390 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10391 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10392 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10393 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10394 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10395 arabic csISOLatinArabic }
10396 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10397 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10398 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10399 greek greek8 csISOLatinGreek }
10400 { T.101-G2 iso-ir-128 csISO128T101G2 }
10401 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10402 csISOLatinHebrew }
10403 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10404 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10405 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10406 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10407 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10408 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10409 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10410 csISOLatinCyrillic }
10411 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10412 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10413 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10414 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10415 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10416 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10417 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10418 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10419 { ISO_10367-box iso-ir-155 csISO10367Box }
10420 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10421 { latin-lap lap iso-ir-158 csISO158Lap }
10422 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10423 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10424 { us-dk csUSDK }
10425 { dk-us csDKUS }
10426 { JIS_X0201 X0201 csHalfWidthKatakana }
10427 { KSC5636 ISO646-KR csKSC5636 }
10428 { ISO-10646-UCS-2 csUnicode }
10429 { ISO-10646-UCS-4 csUCS4 }
10430 { DEC-MCS dec csDECMCS }
10431 { hp-roman8 roman8 r8 csHPRoman8 }
10432 { macintosh mac csMacintosh }
10433 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10434 csIBM037 }
10435 { IBM038 EBCDIC-INT cp038 csIBM038 }
10436 { IBM273 CP273 csIBM273 }
10437 { IBM274 EBCDIC-BE CP274 csIBM274 }
10438 { IBM275 EBCDIC-BR cp275 csIBM275 }
10439 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10440 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10441 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10442 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10443 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10444 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10445 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10446 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10447 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10448 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10449 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10450 { IBM437 cp437 437 csPC8CodePage437 }
10451 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10452 { IBM775 cp775 csPC775Baltic }
10453 { IBM850 cp850 850 csPC850Multilingual }
10454 { IBM851 cp851 851 csIBM851 }
10455 { IBM852 cp852 852 csPCp852 }
10456 { IBM855 cp855 855 csIBM855 }
10457 { IBM857 cp857 857 csIBM857 }
10458 { IBM860 cp860 860 csIBM860 }
10459 { IBM861 cp861 861 cp-is csIBM861 }
10460 { IBM862 cp862 862 csPC862LatinHebrew }
10461 { IBM863 cp863 863 csIBM863 }
10462 { IBM864 cp864 csIBM864 }
10463 { IBM865 cp865 865 csIBM865 }
10464 { IBM866 cp866 866 csIBM866 }
10465 { IBM868 CP868 cp-ar csIBM868 }
10466 { IBM869 cp869 869 cp-gr csIBM869 }
10467 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10468 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10469 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10470 { IBM891 cp891 csIBM891 }
10471 { IBM903 cp903 csIBM903 }
10472 { IBM904 cp904 904 csIBBM904 }
10473 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10474 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10475 { IBM1026 CP1026 csIBM1026 }
10476 { EBCDIC-AT-DE csIBMEBCDICATDE }
10477 { EBCDIC-AT-DE-A csEBCDICATDEA }
10478 { EBCDIC-CA-FR csEBCDICCAFR }
10479 { EBCDIC-DK-NO csEBCDICDKNO }
10480 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10481 { EBCDIC-FI-SE csEBCDICFISE }
10482 { EBCDIC-FI-SE-A csEBCDICFISEA }
10483 { EBCDIC-FR csEBCDICFR }
10484 { EBCDIC-IT csEBCDICIT }
10485 { EBCDIC-PT csEBCDICPT }
10486 { EBCDIC-ES csEBCDICES }
10487 { EBCDIC-ES-A csEBCDICESA }
10488 { EBCDIC-ES-S csEBCDICESS }
10489 { EBCDIC-UK csEBCDICUK }
10490 { EBCDIC-US csEBCDICUS }
10491 { UNKNOWN-8BIT csUnknown8BiT }
10492 { MNEMONIC csMnemonic }
10493 { MNEM csMnem }
10494 { VISCII csVISCII }
10495 { VIQR csVIQR }
10496 { KOI8-R csKOI8R }
10497 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10498 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10499 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10500 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10501 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10502 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10503 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10504 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10505 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10506 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10507 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10508 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10509 { IBM1047 IBM-1047 }
10510 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10511 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10512 { UNICODE-1-1 csUnicode11 }
10513 { CESU-8 csCESU-8 }
10514 { BOCU-1 csBOCU-1 }
10515 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10516 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10517 l8 }
10518 { ISO-8859-15 ISO_8859-15 Latin-9 }
10519 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10520 { GBK CP936 MS936 windows-936 }
10521 { JIS_Encoding csJISEncoding }
10522 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10523 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10524 EUC-JP }
10525 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10526 { ISO-10646-UCS-Basic csUnicodeASCII }
10527 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10528 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10529 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10530 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10531 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10532 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10533 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10534 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10535 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10536 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10537 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10538 { Ventura-US csVenturaUS }
10539 { Ventura-International csVenturaInternational }
10540 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10541 { PC8-Turkish csPC8Turkish }
10542 { IBM-Symbols csIBMSymbols }
10543 { IBM-Thai csIBMThai }
10544 { HP-Legal csHPLegal }
10545 { HP-Pi-font csHPPiFont }
10546 { HP-Math8 csHPMath8 }
10547 { Adobe-Symbol-Encoding csHPPSMath }
10548 { HP-DeskTop csHPDesktop }
10549 { Ventura-Math csVenturaMath }
10550 { Microsoft-Publishing csMicrosoftPublishing }
10551 { Windows-31J csWindows31J }
10552 { GB2312 csGB2312 }
10553 { Big5 csBig5 }
10556 proc tcl_encoding {enc} {
10557 global encoding_aliases tcl_encoding_cache
10558 if {[info exists tcl_encoding_cache($enc)]} {
10559 return $tcl_encoding_cache($enc)
10561 set names [encoding names]
10562 set lcnames [string tolower $names]
10563 set enc [string tolower $enc]
10564 set i [lsearch -exact $lcnames $enc]
10565 if {$i < 0} {
10566 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10567 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10568 set i [lsearch -exact $lcnames $encx]
10571 if {$i < 0} {
10572 foreach l $encoding_aliases {
10573 set ll [string tolower $l]
10574 if {[lsearch -exact $ll $enc] < 0} continue
10575 # look through the aliases for one that tcl knows about
10576 foreach e $ll {
10577 set i [lsearch -exact $lcnames $e]
10578 if {$i < 0} {
10579 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10580 set i [lsearch -exact $lcnames $ex]
10583 if {$i >= 0} break
10585 break
10588 set tclenc {}
10589 if {$i >= 0} {
10590 set tclenc [lindex $names $i]
10592 set tcl_encoding_cache($enc) $tclenc
10593 return $tclenc
10596 proc gitattr {path attr default} {
10597 global path_attr_cache
10598 if {[info exists path_attr_cache($attr,$path)]} {
10599 set r $path_attr_cache($attr,$path)
10600 } else {
10601 set r "unspecified"
10602 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10603 regexp "(.*): encoding: (.*)" $line m f r
10605 set path_attr_cache($attr,$path) $r
10607 if {$r eq "unspecified"} {
10608 return $default
10610 return $r
10613 proc cache_gitattr {attr pathlist} {
10614 global path_attr_cache
10615 set newlist {}
10616 foreach path $pathlist {
10617 if {![info exists path_attr_cache($attr,$path)]} {
10618 lappend newlist $path
10621 set lim 1000
10622 if {[tk windowingsystem] == "win32"} {
10623 # windows has a 32k limit on the arguments to a command...
10624 set lim 30
10626 while {$newlist ne {}} {
10627 set head [lrange $newlist 0 [expr {$lim - 1}]]
10628 set newlist [lrange $newlist $lim end]
10629 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10630 foreach row [split $rlist "\n"] {
10631 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10632 if {[string index $path 0] eq "\""} {
10633 set path [encoding convertfrom [lindex $path 0]]
10635 set path_attr_cache($attr,$path) $value
10642 proc get_path_encoding {path} {
10643 global gui_encoding perfile_attrs
10644 set tcl_enc $gui_encoding
10645 if {$path ne {} && $perfile_attrs} {
10646 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10647 if {$enc2 ne {}} {
10648 set tcl_enc $enc2
10651 return $tcl_enc
10654 # First check that Tcl/Tk is recent enough
10655 if {[catch {package require Tk 8.4} err]} {
10656 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10657 Gitk requires at least Tcl/Tk 8.4."]
10658 exit 1
10661 # defaults...
10662 set wrcomcmd "git diff-tree --stdin -p --pretty"
10664 set gitencoding {}
10665 catch {
10666 set gitencoding [exec git config --get i18n.commitencoding]
10668 catch {
10669 set gitencoding [exec git config --get i18n.logoutputencoding]
10671 if {$gitencoding == ""} {
10672 set gitencoding "utf-8"
10674 set tclencoding [tcl_encoding $gitencoding]
10675 if {$tclencoding == {}} {
10676 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10679 set gui_encoding [encoding system]
10680 catch {
10681 set enc [exec git config --get gui.encoding]
10682 if {$enc ne {}} {
10683 set tclenc [tcl_encoding $enc]
10684 if {$tclenc ne {}} {
10685 set gui_encoding $tclenc
10686 } else {
10687 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10692 set mainfont {Helvetica 9}
10693 set textfont {Courier 9}
10694 set uifont {Helvetica 9 bold}
10695 set tabstop 8
10696 set findmergefiles 0
10697 set maxgraphpct 50
10698 set maxwidth 16
10699 set revlistorder 0
10700 set fastdate 0
10701 set uparrowlen 5
10702 set downarrowlen 5
10703 set mingaplen 100
10704 set cmitmode "patch"
10705 set wrapcomment "none"
10706 set showneartags 1
10707 set maxrefs 20
10708 set maxlinelen 200
10709 set showlocalchanges 1
10710 set limitdiffs 1
10711 set datetimeformat "%Y-%m-%d %H:%M:%S"
10712 set autoselect 1
10713 set perfile_attrs 0
10715 set extdifftool "meld"
10717 set colors {green red blue magenta darkgrey brown orange}
10718 set bgcolor white
10719 set fgcolor black
10720 set diffcolors {red "#00a000" blue}
10721 set diffcontext 3
10722 set ignorespace 0
10723 set selectbgcolor gray85
10724 set markbgcolor "#e0e0ff"
10726 set circlecolors {white blue gray blue blue}
10728 # button for popping up context menus
10729 if {[tk windowingsystem] eq "aqua"} {
10730 set ctxbut <Button-2>
10731 } else {
10732 set ctxbut <Button-3>
10735 ## For msgcat loading, first locate the installation location.
10736 if { [info exists ::env(GITK_MSGSDIR)] } {
10737 ## Msgsdir was manually set in the environment.
10738 set gitk_msgsdir $::env(GITK_MSGSDIR)
10739 } else {
10740 ## Let's guess the prefix from argv0.
10741 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10742 set gitk_libdir [file join $gitk_prefix share gitk lib]
10743 set gitk_msgsdir [file join $gitk_libdir msgs]
10744 unset gitk_prefix
10747 ## Internationalization (i18n) through msgcat and gettext. See
10748 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10749 package require msgcat
10750 namespace import ::msgcat::mc
10751 ## And eventually load the actual message catalog
10752 ::msgcat::mcload $gitk_msgsdir
10754 catch {source ~/.gitk}
10756 font create optionfont -family sans-serif -size -12
10758 parsefont mainfont $mainfont
10759 eval font create mainfont [fontflags mainfont]
10760 eval font create mainfontbold [fontflags mainfont 1]
10762 parsefont textfont $textfont
10763 eval font create textfont [fontflags textfont]
10764 eval font create textfontbold [fontflags textfont 1]
10766 parsefont uifont $uifont
10767 eval font create uifont [fontflags uifont]
10769 setoptions
10771 # check that we can find a .git directory somewhere...
10772 if {[catch {set gitdir [gitdir]}]} {
10773 show_error {} . [mc "Cannot find a git repository here."]
10774 exit 1
10776 if {![file isdirectory $gitdir]} {
10777 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10778 exit 1
10781 set selecthead {}
10782 set selectheadid {}
10784 set revtreeargs {}
10785 set cmdline_files {}
10786 set i 0
10787 set revtreeargscmd {}
10788 foreach arg $argv {
10789 switch -glob -- $arg {
10790 "" { }
10791 "--" {
10792 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10793 break
10795 "--select-commit=*" {
10796 set selecthead [string range $arg 16 end]
10798 "--argscmd=*" {
10799 set revtreeargscmd [string range $arg 10 end]
10801 default {
10802 lappend revtreeargs $arg
10805 incr i
10808 if {$selecthead eq "HEAD"} {
10809 set selecthead {}
10812 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10813 # no -- on command line, but some arguments (other than --argscmd)
10814 if {[catch {
10815 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10816 set cmdline_files [split $f "\n"]
10817 set n [llength $cmdline_files]
10818 set revtreeargs [lrange $revtreeargs 0 end-$n]
10819 # Unfortunately git rev-parse doesn't produce an error when
10820 # something is both a revision and a filename. To be consistent
10821 # with git log and git rev-list, check revtreeargs for filenames.
10822 foreach arg $revtreeargs {
10823 if {[file exists $arg]} {
10824 show_error {} . [mc "Ambiguous argument '%s': both revision\
10825 and filename" $arg]
10826 exit 1
10829 } err]} {
10830 # unfortunately we get both stdout and stderr in $err,
10831 # so look for "fatal:".
10832 set i [string first "fatal:" $err]
10833 if {$i > 0} {
10834 set err [string range $err [expr {$i + 6}] end]
10836 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10837 exit 1
10841 set nullid "0000000000000000000000000000000000000000"
10842 set nullid2 "0000000000000000000000000000000000000001"
10843 set nullfile "/dev/null"
10845 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10847 set runq {}
10848 set history {}
10849 set historyindex 0
10850 set fh_serial 0
10851 set nhl_names {}
10852 set highlight_paths {}
10853 set findpattern {}
10854 set searchdirn -forwards
10855 set boldids {}
10856 set boldnameids {}
10857 set diffelide {0 0}
10858 set markingmatches 0
10859 set linkentercount 0
10860 set need_redisplay 0
10861 set nrows_drawn 0
10862 set firsttabstop 0
10864 set nextviewnum 1
10865 set curview 0
10866 set selectedview 0
10867 set selectedhlview [mc "None"]
10868 set highlight_related [mc "None"]
10869 set highlight_files {}
10870 set viewfiles(0) {}
10871 set viewperm(0) 0
10872 set viewargs(0) {}
10873 set viewargscmd(0) {}
10875 set selectedline {}
10876 set numcommits 0
10877 set loginstance 0
10878 set cmdlineok 0
10879 set stopped 0
10880 set stuffsaved 0
10881 set patchnum 0
10882 set lserial 0
10883 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10884 setcoords
10885 makewindow
10886 # wait for the window to become visible
10887 tkwait visibility .
10888 wm title . "[file tail $argv0]: [file tail [pwd]]"
10889 readrefs
10891 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10892 # create a view for the files/dirs specified on the command line
10893 set curview 1
10894 set selectedview 1
10895 set nextviewnum 2
10896 set viewname(1) [mc "Command line"]
10897 set viewfiles(1) $cmdline_files
10898 set viewargs(1) $revtreeargs
10899 set viewargscmd(1) $revtreeargscmd
10900 set viewperm(1) 0
10901 set vdatemode(1) 0
10902 addviewmenu 1
10903 .bar.view entryconf [mca "Edit view..."] -state normal
10904 .bar.view entryconf [mca "Delete view"] -state normal
10907 if {[info exists permviews]} {
10908 foreach v $permviews {
10909 set n $nextviewnum
10910 incr nextviewnum
10911 set viewname($n) [lindex $v 0]
10912 set viewfiles($n) [lindex $v 1]
10913 set viewargs($n) [lindex $v 2]
10914 set viewargscmd($n) [lindex $v 3]
10915 set viewperm($n) 1
10916 addviewmenu $n
10920 if {[tk windowingsystem] eq "win32"} {
10921 focus -force .
10924 getcommits {}