test-lib.sh: optionally output to test-results/$TEST.out, too
[alt-git.git] / gitk-git / gitk
blobdc2a439618ffd92a92d9ca954a8597ba31875dab
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
705 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707 set oa $varcid($v,$p)
708 set ac $varccommits($v,$oa)
709 set i [lsearch -exact $varccommits($v,$oa) $p]
710 if {$i <= 0} return
711 set na [llength $varctok($v)]
712 # "%" sorts before "0"...
713 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
714 lappend varctok($v) $tok
715 lappend varcrow($v) {}
716 lappend varcix($v) {}
717 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
718 set varccommits($v,$na) [lrange $ac $i end]
719 lappend varcstart($v) $p
720 foreach id $varccommits($v,$na) {
721 set varcid($v,$id) $na
723 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
724 lappend vlastins($v) [lindex $vlastins($v) $oa]
725 lset vdownptr($v) $oa $na
726 lset vlastins($v) $oa 0
727 lappend vupptr($v) $oa
728 lappend vleftptr($v) 0
729 lappend vbackptr($v) 0
730 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
731 lset vupptr($v) $b $na
735 proc renumbervarc {a v} {
736 global parents children varctok varcstart varccommits
737 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
739 set t1 [clock clicks -milliseconds]
740 set todo {}
741 set isrelated($a) 1
742 set kidchanged($a) 1
743 set ntot 0
744 while {$a != 0} {
745 if {[info exists isrelated($a)]} {
746 lappend todo $a
747 set id [lindex $varccommits($v,$a) end]
748 foreach p $parents($v,$id) {
749 if {[info exists varcid($v,$p)]} {
750 set isrelated($varcid($v,$p)) 1
754 incr ntot
755 set b [lindex $vdownptr($v) $a]
756 if {$b == 0} {
757 while {$a != 0} {
758 set b [lindex $vleftptr($v) $a]
759 if {$b != 0} break
760 set a [lindex $vupptr($v) $a]
763 set a $b
765 foreach a $todo {
766 if {![info exists kidchanged($a)]} continue
767 set id [lindex $varcstart($v) $a]
768 if {[llength $children($v,$id)] > 1} {
769 set children($v,$id) [lsort -command [list vtokcmp $v] \
770 $children($v,$id)]
772 set oldtok [lindex $varctok($v) $a]
773 if {!$vdatemode($v)} {
774 set tok {}
775 } else {
776 set tok $oldtok
778 set ka 0
779 set kid [last_real_child $v,$id]
780 if {$kid ne {}} {
781 set k $varcid($v,$kid)
782 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
783 set ki $kid
784 set ka $k
785 set tok [lindex $varctok($v) $k]
788 if {$ka != 0} {
789 set i [lsearch -exact $parents($v,$ki) $id]
790 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
791 append tok [strrep $j]
793 if {$tok eq $oldtok} {
794 continue
796 set id [lindex $varccommits($v,$a) end]
797 foreach p $parents($v,$id) {
798 if {[info exists varcid($v,$p)]} {
799 set kidchanged($varcid($v,$p)) 1
800 } else {
801 set sortkids($p) 1
804 lset varctok($v) $a $tok
805 set b [lindex $vupptr($v) $a]
806 if {$b != $ka} {
807 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
808 modify_arc $v $ka
810 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
811 modify_arc $v $b
813 set c [lindex $vbackptr($v) $a]
814 set d [lindex $vleftptr($v) $a]
815 if {$c == 0} {
816 lset vdownptr($v) $b $d
817 } else {
818 lset vleftptr($v) $c $d
820 if {$d != 0} {
821 lset vbackptr($v) $d $c
823 if {[lindex $vlastins($v) $b] == $a} {
824 lset vlastins($v) $b $c
826 lset vupptr($v) $a $ka
827 set c [lindex $vlastins($v) $ka]
828 if {$c == 0 || \
829 [string compare $tok [lindex $varctok($v) $c]] < 0} {
830 set c $ka
831 set b [lindex $vdownptr($v) $ka]
832 } else {
833 set b [lindex $vleftptr($v) $c]
835 while {$b != 0 && \
836 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
837 set c $b
838 set b [lindex $vleftptr($v) $c]
840 if {$c == $ka} {
841 lset vdownptr($v) $ka $a
842 lset vbackptr($v) $a 0
843 } else {
844 lset vleftptr($v) $c $a
845 lset vbackptr($v) $a $c
847 lset vleftptr($v) $a $b
848 if {$b != 0} {
849 lset vbackptr($v) $b $a
851 lset vlastins($v) $ka $a
854 foreach id [array names sortkids] {
855 if {[llength $children($v,$id)] > 1} {
856 set children($v,$id) [lsort -command [list vtokcmp $v] \
857 $children($v,$id)]
860 set t2 [clock clicks -milliseconds]
861 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
864 # Fix up the graph after we have found out that in view $v,
865 # $p (a commit that we have already seen) is actually the parent
866 # of the last commit in arc $a.
867 proc fix_reversal {p a v} {
868 global varcid varcstart varctok vupptr
870 set pa $varcid($v,$p)
871 if {$p ne [lindex $varcstart($v) $pa]} {
872 splitvarc $p $v
873 set pa $varcid($v,$p)
875 # seeds always need to be renumbered
876 if {[lindex $vupptr($v) $pa] == 0 ||
877 [string compare [lindex $varctok($v) $a] \
878 [lindex $varctok($v) $pa]] > 0} {
879 renumbervarc $pa $v
883 proc insertrow {id p v} {
884 global cmitlisted children parents varcid varctok vtokmod
885 global varccommits ordertok commitidx numcommits curview
886 global targetid targetrow
888 readcommit $id
889 set vid $v,$id
890 set cmitlisted($vid) 1
891 set children($vid) {}
892 set parents($vid) [list $p]
893 set a [newvarc $v $id]
894 set varcid($vid) $a
895 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
896 modify_arc $v $a
898 lappend varccommits($v,$a) $id
899 set vp $v,$p
900 if {[llength [lappend children($vp) $id]] > 1} {
901 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
902 catch {unset ordertok}
904 fix_reversal $p $a $v
905 incr commitidx($v)
906 if {$v == $curview} {
907 set numcommits $commitidx($v)
908 setcanvscroll
909 if {[info exists targetid]} {
910 if {![comes_before $targetid $p]} {
911 incr targetrow
917 proc insertfakerow {id p} {
918 global varcid varccommits parents children cmitlisted
919 global commitidx varctok vtokmod targetid targetrow curview numcommits
921 set v $curview
922 set a $varcid($v,$p)
923 set i [lsearch -exact $varccommits($v,$a) $p]
924 if {$i < 0} {
925 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
926 return
928 set children($v,$id) {}
929 set parents($v,$id) [list $p]
930 set varcid($v,$id) $a
931 lappend children($v,$p) $id
932 set cmitlisted($v,$id) 1
933 set numcommits [incr commitidx($v)]
934 # note we deliberately don't update varcstart($v) even if $i == 0
935 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
936 modify_arc $v $a $i
937 if {[info exists targetid]} {
938 if {![comes_before $targetid $p]} {
939 incr targetrow
942 setcanvscroll
943 drawvisible
946 proc removefakerow {id} {
947 global varcid varccommits parents children commitidx
948 global varctok vtokmod cmitlisted currentid selectedline
949 global targetid curview numcommits
951 set v $curview
952 if {[llength $parents($v,$id)] != 1} {
953 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
954 return
956 set p [lindex $parents($v,$id) 0]
957 set a $varcid($v,$id)
958 set i [lsearch -exact $varccommits($v,$a) $id]
959 if {$i < 0} {
960 puts "oops: removefakerow can't find [shortids $id] on arc $a"
961 return
963 unset varcid($v,$id)
964 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
965 unset parents($v,$id)
966 unset children($v,$id)
967 unset cmitlisted($v,$id)
968 set numcommits [incr commitidx($v) -1]
969 set j [lsearch -exact $children($v,$p) $id]
970 if {$j >= 0} {
971 set children($v,$p) [lreplace $children($v,$p) $j $j]
973 modify_arc $v $a $i
974 if {[info exist currentid] && $id eq $currentid} {
975 unset currentid
976 set selectedline {}
978 if {[info exists targetid] && $targetid eq $id} {
979 set targetid $p
981 setcanvscroll
982 drawvisible
985 proc first_real_child {vp} {
986 global children nullid nullid2
988 foreach id $children($vp) {
989 if {$id ne $nullid && $id ne $nullid2} {
990 return $id
993 return {}
996 proc last_real_child {vp} {
997 global children nullid nullid2
999 set kids $children($vp)
1000 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1001 set id [lindex $kids $i]
1002 if {$id ne $nullid && $id ne $nullid2} {
1003 return $id
1006 return {}
1009 proc vtokcmp {v a b} {
1010 global varctok varcid
1012 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1013 [lindex $varctok($v) $varcid($v,$b)]]
1016 # This assumes that if lim is not given, the caller has checked that
1017 # arc a's token is less than $vtokmod($v)
1018 proc modify_arc {v a {lim {}}} {
1019 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1021 if {$lim ne {}} {
1022 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1023 if {$c > 0} return
1024 if {$c == 0} {
1025 set r [lindex $varcrow($v) $a]
1026 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1029 set vtokmod($v) [lindex $varctok($v) $a]
1030 set varcmod($v) $a
1031 if {$v == $curview} {
1032 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1033 set a [lindex $vupptr($v) $a]
1034 set lim {}
1036 set r 0
1037 if {$a != 0} {
1038 if {$lim eq {}} {
1039 set lim [llength $varccommits($v,$a)]
1041 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1043 set vrowmod($v) $r
1044 undolayout $r
1048 proc update_arcrows {v} {
1049 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1050 global varcid vrownum varcorder varcix varccommits
1051 global vupptr vdownptr vleftptr varctok
1052 global displayorder parentlist curview cached_commitrow
1054 if {$vrowmod($v) == $commitidx($v)} return
1055 if {$v == $curview} {
1056 if {[llength $displayorder] > $vrowmod($v)} {
1057 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1058 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1060 catch {unset cached_commitrow}
1062 set narctot [expr {[llength $varctok($v)] - 1}]
1063 set a $varcmod($v)
1064 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1065 # go up the tree until we find something that has a row number,
1066 # or we get to a seed
1067 set a [lindex $vupptr($v) $a]
1069 if {$a == 0} {
1070 set a [lindex $vdownptr($v) 0]
1071 if {$a == 0} return
1072 set vrownum($v) {0}
1073 set varcorder($v) [list $a]
1074 lset varcix($v) $a 0
1075 lset varcrow($v) $a 0
1076 set arcn 0
1077 set row 0
1078 } else {
1079 set arcn [lindex $varcix($v) $a]
1080 if {[llength $vrownum($v)] > $arcn + 1} {
1081 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1082 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1084 set row [lindex $varcrow($v) $a]
1086 while {1} {
1087 set p $a
1088 incr row [llength $varccommits($v,$a)]
1089 # go down if possible
1090 set b [lindex $vdownptr($v) $a]
1091 if {$b == 0} {
1092 # if not, go left, or go up until we can go left
1093 while {$a != 0} {
1094 set b [lindex $vleftptr($v) $a]
1095 if {$b != 0} break
1096 set a [lindex $vupptr($v) $a]
1098 if {$a == 0} break
1100 set a $b
1101 incr arcn
1102 lappend vrownum($v) $row
1103 lappend varcorder($v) $a
1104 lset varcix($v) $a $arcn
1105 lset varcrow($v) $a $row
1107 set vtokmod($v) [lindex $varctok($v) $p]
1108 set varcmod($v) $p
1109 set vrowmod($v) $row
1110 if {[info exists currentid]} {
1111 set selectedline [rowofcommit $currentid]
1115 # Test whether view $v contains commit $id
1116 proc commitinview {id v} {
1117 global varcid
1119 return [info exists varcid($v,$id)]
1122 # Return the row number for commit $id in the current view
1123 proc rowofcommit {id} {
1124 global varcid varccommits varcrow curview cached_commitrow
1125 global varctok vtokmod
1127 set v $curview
1128 if {![info exists varcid($v,$id)]} {
1129 puts "oops rowofcommit no arc for [shortids $id]"
1130 return {}
1132 set a $varcid($v,$id)
1133 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1134 update_arcrows $v
1136 if {[info exists cached_commitrow($id)]} {
1137 return $cached_commitrow($id)
1139 set i [lsearch -exact $varccommits($v,$a) $id]
1140 if {$i < 0} {
1141 puts "oops didn't find commit [shortids $id] in arc $a"
1142 return {}
1144 incr i [lindex $varcrow($v) $a]
1145 set cached_commitrow($id) $i
1146 return $i
1149 # Returns 1 if a is on an earlier row than b, otherwise 0
1150 proc comes_before {a b} {
1151 global varcid varctok curview
1153 set v $curview
1154 if {$a eq $b || ![info exists varcid($v,$a)] || \
1155 ![info exists varcid($v,$b)]} {
1156 return 0
1158 if {$varcid($v,$a) != $varcid($v,$b)} {
1159 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1160 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1162 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1165 proc bsearch {l elt} {
1166 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1167 return 0
1169 set lo 0
1170 set hi [llength $l]
1171 while {$hi - $lo > 1} {
1172 set mid [expr {int(($lo + $hi) / 2)}]
1173 set t [lindex $l $mid]
1174 if {$elt < $t} {
1175 set hi $mid
1176 } elseif {$elt > $t} {
1177 set lo $mid
1178 } else {
1179 return $mid
1182 return $lo
1185 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1186 proc make_disporder {start end} {
1187 global vrownum curview commitidx displayorder parentlist
1188 global varccommits varcorder parents vrowmod varcrow
1189 global d_valid_start d_valid_end
1191 if {$end > $vrowmod($curview)} {
1192 update_arcrows $curview
1194 set ai [bsearch $vrownum($curview) $start]
1195 set start [lindex $vrownum($curview) $ai]
1196 set narc [llength $vrownum($curview)]
1197 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1198 set a [lindex $varcorder($curview) $ai]
1199 set l [llength $displayorder]
1200 set al [llength $varccommits($curview,$a)]
1201 if {$l < $r + $al} {
1202 if {$l < $r} {
1203 set pad [ntimes [expr {$r - $l}] {}]
1204 set displayorder [concat $displayorder $pad]
1205 set parentlist [concat $parentlist $pad]
1206 } elseif {$l > $r} {
1207 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1208 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1210 foreach id $varccommits($curview,$a) {
1211 lappend displayorder $id
1212 lappend parentlist $parents($curview,$id)
1214 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1215 set i $r
1216 foreach id $varccommits($curview,$a) {
1217 lset displayorder $i $id
1218 lset parentlist $i $parents($curview,$id)
1219 incr i
1222 incr r $al
1226 proc commitonrow {row} {
1227 global displayorder
1229 set id [lindex $displayorder $row]
1230 if {$id eq {}} {
1231 make_disporder $row [expr {$row + 1}]
1232 set id [lindex $displayorder $row]
1234 return $id
1237 proc closevarcs {v} {
1238 global varctok varccommits varcid parents children
1239 global cmitlisted commitidx vtokmod
1241 set missing_parents 0
1242 set scripts {}
1243 set narcs [llength $varctok($v)]
1244 for {set a 1} {$a < $narcs} {incr a} {
1245 set id [lindex $varccommits($v,$a) end]
1246 foreach p $parents($v,$id) {
1247 if {[info exists varcid($v,$p)]} continue
1248 # add p as a new commit
1249 incr missing_parents
1250 set cmitlisted($v,$p) 0
1251 set parents($v,$p) {}
1252 if {[llength $children($v,$p)] == 1 &&
1253 [llength $parents($v,$id)] == 1} {
1254 set b $a
1255 } else {
1256 set b [newvarc $v $p]
1258 set varcid($v,$p) $b
1259 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1260 modify_arc $v $b
1262 lappend varccommits($v,$b) $p
1263 incr commitidx($v)
1264 set scripts [check_interest $p $scripts]
1267 if {$missing_parents > 0} {
1268 foreach s $scripts {
1269 eval $s
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch $children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i [lsearch -exact $parents($v,$ch) $id]
1282 if {$i < 0} {
1283 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a $varcid($v,$ch)
1293 fix_reversal $rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1300 # Mechanism for registering a command to be executed when we come
1301 # across a particular commit. To handle the case when only the
1302 # prefix of the commit is known, the commitinterest array is now
1303 # indexed by the first 4 characters of the ID. Each element is a
1304 # list of id, cmd pairs.
1305 proc interestedin {id cmd} {
1306 global commitinterest
1308 lappend commitinterest([string range $id 0 3]) $id $cmd
1311 proc check_interest {id scripts} {
1312 global commitinterest
1314 set prefix [string range $id 0 3]
1315 if {[info exists commitinterest($prefix)]} {
1316 set newlist {}
1317 foreach {i script} $commitinterest($prefix) {
1318 if {[string match "$i*" $id]} {
1319 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1320 } else {
1321 lappend newlist $i $script
1324 if {$newlist ne {}} {
1325 set commitinterest($prefix) $newlist
1326 } else {
1327 unset commitinterest($prefix)
1330 return $scripts
1333 proc getcommitlines {fd inst view updating} {
1334 global cmitlisted leftover
1335 global commitidx commitdata vdatemode
1336 global parents children curview hlview
1337 global idpending ordertok
1338 global varccommits varcid varctok vtokmod vfilelimit
1340 set stuff [read $fd 500000]
1341 # git log doesn't terminate the last commit with a null...
1342 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1343 set stuff "\0"
1345 if {$stuff == {}} {
1346 if {![eof $fd]} {
1347 return 1
1349 global commfd viewcomplete viewactive viewname
1350 global viewinstances
1351 unset commfd($inst)
1352 set i [lsearch -exact $viewinstances($view) $inst]
1353 if {$i >= 0} {
1354 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1356 # set it blocking so we wait for the process to terminate
1357 fconfigure $fd -blocking 1
1358 if {[catch {close $fd} err]} {
1359 set fv {}
1360 if {$view != $curview} {
1361 set fv " for the \"$viewname($view)\" view"
1363 if {[string range $err 0 4] == "usage"} {
1364 set err "Gitk: error reading commits$fv:\
1365 bad arguments to git log."
1366 if {$viewname($view) eq "Command line"} {
1367 append err \
1368 " (Note: arguments to gitk are passed to git log\
1369 to allow selection of commits to be displayed.)"
1371 } else {
1372 set err "Error reading commits$fv: $err"
1374 error_popup $err
1376 if {[incr viewactive($view) -1] <= 0} {
1377 set viewcomplete($view) 1
1378 # Check if we have seen any ids listed as parents that haven't
1379 # appeared in the list
1380 closevarcs $view
1381 notbusy $view
1383 if {$view == $curview} {
1384 run chewcommits
1386 return 0
1388 set start 0
1389 set gotsome 0
1390 set scripts {}
1391 while 1 {
1392 set i [string first "\0" $stuff $start]
1393 if {$i < 0} {
1394 append leftover($inst) [string range $stuff $start end]
1395 break
1397 if {$start == 0} {
1398 set cmit $leftover($inst)
1399 append cmit [string range $stuff 0 [expr {$i - 1}]]
1400 set leftover($inst) {}
1401 } else {
1402 set cmit [string range $stuff $start [expr {$i - 1}]]
1404 set start [expr {$i + 1}]
1405 set j [string first "\n" $cmit]
1406 set ok 0
1407 set listed 1
1408 if {$j >= 0 && [string match "commit *" $cmit]} {
1409 set ids [string range $cmit 7 [expr {$j - 1}]]
1410 if {[string match {[-^<>]*} $ids]} {
1411 switch -- [string index $ids 0] {
1412 "-" {set listed 0}
1413 "^" {set listed 2}
1414 "<" {set listed 3}
1415 ">" {set listed 4}
1417 set ids [string range $ids 1 end]
1419 set ok 1
1420 foreach id $ids {
1421 if {[string length $id] != 40} {
1422 set ok 0
1423 break
1427 if {!$ok} {
1428 set shortcmit $cmit
1429 if {[string length $shortcmit] > 80} {
1430 set shortcmit "[string range $shortcmit 0 80]..."
1432 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1433 exit 1
1435 set id [lindex $ids 0]
1436 set vid $view,$id
1438 if {!$listed && $updating && ![info exists varcid($vid)] &&
1439 $vfilelimit($view) ne {}} {
1440 # git log doesn't rewrite parents for unlisted commits
1441 # when doing path limiting, so work around that here
1442 # by working out the rewritten parent with git rev-list
1443 # and if we already know about it, using the rewritten
1444 # parent as a substitute parent for $id's children.
1445 if {![catch {
1446 set rwid [exec git rev-list --first-parent --max-count=1 \
1447 $id -- $vfilelimit($view)]
1448 }]} {
1449 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1450 # use $rwid in place of $id
1451 rewrite_commit $view $id $rwid
1452 continue
1457 set a 0
1458 if {[info exists varcid($vid)]} {
1459 if {$cmitlisted($vid) || !$listed} continue
1460 set a $varcid($vid)
1462 if {$listed} {
1463 set olds [lrange $ids 1 end]
1464 } else {
1465 set olds {}
1467 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1468 set cmitlisted($vid) $listed
1469 set parents($vid) $olds
1470 if {![info exists children($vid)]} {
1471 set children($vid) {}
1472 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1473 set k [lindex $children($vid) 0]
1474 if {[llength $parents($view,$k)] == 1 &&
1475 (!$vdatemode($view) ||
1476 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1477 set a $varcid($view,$k)
1480 if {$a == 0} {
1481 # new arc
1482 set a [newvarc $view $id]
1484 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1485 modify_arc $view $a
1487 if {![info exists varcid($vid)]} {
1488 set varcid($vid) $a
1489 lappend varccommits($view,$a) $id
1490 incr commitidx($view)
1493 set i 0
1494 foreach p $olds {
1495 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1496 set vp $view,$p
1497 if {[llength [lappend children($vp) $id]] > 1 &&
1498 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1499 set children($vp) [lsort -command [list vtokcmp $view] \
1500 $children($vp)]
1501 catch {unset ordertok}
1503 if {[info exists varcid($view,$p)]} {
1504 fix_reversal $p $a $view
1507 incr i
1510 set scripts [check_interest $id $scripts]
1511 set gotsome 1
1513 if {$gotsome} {
1514 global numcommits hlview
1516 if {$view == $curview} {
1517 set numcommits $commitidx($view)
1518 run chewcommits
1520 if {[info exists hlview] && $view == $hlview} {
1521 # we never actually get here...
1522 run vhighlightmore
1524 foreach s $scripts {
1525 eval $s
1528 return 2
1531 proc chewcommits {} {
1532 global curview hlview viewcomplete
1533 global pending_select
1535 layoutmore
1536 if {$viewcomplete($curview)} {
1537 global commitidx varctok
1538 global numcommits startmsecs
1540 if {[info exists pending_select]} {
1541 update
1542 reset_pending_select {}
1544 if {[commitinview $pending_select $curview]} {
1545 selectline [rowofcommit $pending_select] 1
1546 } else {
1547 set row [first_real_row]
1548 selectline $row 1
1551 if {$commitidx($curview) > 0} {
1552 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1553 #puts "overall $ms ms for $numcommits commits"
1554 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1555 } else {
1556 show_status [mc "No commits selected"]
1558 notbusy layout
1560 return 0
1563 proc do_readcommit {id} {
1564 global tclencoding
1566 # Invoke git-log to handle automatic encoding conversion
1567 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1568 # Read the results using i18n.logoutputencoding
1569 fconfigure $fd -translation lf -eofchar {}
1570 if {$tclencoding != {}} {
1571 fconfigure $fd -encoding $tclencoding
1573 set contents [read $fd]
1574 close $fd
1575 # Remove the heading line
1576 regsub {^commit [0-9a-f]+\n} $contents {} contents
1578 return $contents
1581 proc readcommit {id} {
1582 if {[catch {set contents [do_readcommit $id]}]} return
1583 parsecommit $id $contents 1
1586 proc parsecommit {id contents listed} {
1587 global commitinfo cdate
1589 set inhdr 1
1590 set comment {}
1591 set headline {}
1592 set auname {}
1593 set audate {}
1594 set comname {}
1595 set comdate {}
1596 set hdrend [string first "\n\n" $contents]
1597 if {$hdrend < 0} {
1598 # should never happen...
1599 set hdrend [string length $contents]
1601 set header [string range $contents 0 [expr {$hdrend - 1}]]
1602 set comment [string range $contents [expr {$hdrend + 2}] end]
1603 foreach line [split $header "\n"] {
1604 set line [split $line " "]
1605 set tag [lindex $line 0]
1606 if {$tag == "author"} {
1607 set audate [lindex $line end-1]
1608 set auname [join [lrange $line 1 end-2] " "]
1609 } elseif {$tag == "committer"} {
1610 set comdate [lindex $line end-1]
1611 set comname [join [lrange $line 1 end-2] " "]
1614 set headline {}
1615 # take the first non-blank line of the comment as the headline
1616 set headline [string trimleft $comment]
1617 set i [string first "\n" $headline]
1618 if {$i >= 0} {
1619 set headline [string range $headline 0 $i]
1621 set headline [string trimright $headline]
1622 set i [string first "\r" $headline]
1623 if {$i >= 0} {
1624 set headline [string trimright [string range $headline 0 $i]]
1626 if {!$listed} {
1627 # git log indents the comment by 4 spaces;
1628 # if we got this via git cat-file, add the indentation
1629 set newcomment {}
1630 foreach line [split $comment "\n"] {
1631 append newcomment " "
1632 append newcomment $line
1633 append newcomment "\n"
1635 set comment $newcomment
1637 if {$comdate != {}} {
1638 set cdate($id) $comdate
1640 set commitinfo($id) [list $headline $auname $audate \
1641 $comname $comdate $comment]
1644 proc getcommit {id} {
1645 global commitdata commitinfo
1647 if {[info exists commitdata($id)]} {
1648 parsecommit $id $commitdata($id) 1
1649 } else {
1650 readcommit $id
1651 if {![info exists commitinfo($id)]} {
1652 set commitinfo($id) [list [mc "No commit information available"]]
1655 return 1
1658 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1659 # and are present in the current view.
1660 # This is fairly slow...
1661 proc longid {prefix} {
1662 global varcid curview
1664 set ids {}
1665 foreach match [array names varcid "$curview,$prefix*"] {
1666 lappend ids [lindex [split $match ","] 1]
1668 return $ids
1671 proc readrefs {} {
1672 global tagids idtags headids idheads tagobjid
1673 global otherrefids idotherrefs mainhead mainheadid
1674 global selecthead selectheadid
1676 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1677 catch {unset $v}
1679 set refd [open [list | git show-ref -d] r]
1680 while {[gets $refd line] >= 0} {
1681 if {[string index $line 40] ne " "} continue
1682 set id [string range $line 0 39]
1683 set ref [string range $line 41 end]
1684 if {![string match "refs/*" $ref]} continue
1685 set name [string range $ref 5 end]
1686 if {[string match "remotes/*" $name]} {
1687 if {![string match "*/HEAD" $name]} {
1688 set headids($name) $id
1689 lappend idheads($id) $name
1691 } elseif {[string match "heads/*" $name]} {
1692 set name [string range $name 6 end]
1693 set headids($name) $id
1694 lappend idheads($id) $name
1695 } elseif {[string match "tags/*" $name]} {
1696 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1697 # which is what we want since the former is the commit ID
1698 set name [string range $name 5 end]
1699 if {[string match "*^{}" $name]} {
1700 set name [string range $name 0 end-3]
1701 } else {
1702 set tagobjid($name) $id
1704 set tagids($name) $id
1705 lappend idtags($id) $name
1706 } else {
1707 set otherrefids($name) $id
1708 lappend idotherrefs($id) $name
1711 catch {close $refd}
1712 set mainhead {}
1713 set mainheadid {}
1714 catch {
1715 set mainheadid [exec git rev-parse HEAD]
1716 set thehead [exec git symbolic-ref HEAD]
1717 if {[string match "refs/heads/*" $thehead]} {
1718 set mainhead [string range $thehead 11 end]
1721 set selectheadid {}
1722 if {$selecthead ne {}} {
1723 catch {
1724 set selectheadid [exec git rev-parse --verify $selecthead]
1729 # skip over fake commits
1730 proc first_real_row {} {
1731 global nullid nullid2 numcommits
1733 for {set row 0} {$row < $numcommits} {incr row} {
1734 set id [commitonrow $row]
1735 if {$id ne $nullid && $id ne $nullid2} {
1736 break
1739 return $row
1742 # update things for a head moved to a child of its previous location
1743 proc movehead {id name} {
1744 global headids idheads
1746 removehead $headids($name) $name
1747 set headids($name) $id
1748 lappend idheads($id) $name
1751 # update things when a head has been removed
1752 proc removehead {id name} {
1753 global headids idheads
1755 if {$idheads($id) eq $name} {
1756 unset idheads($id)
1757 } else {
1758 set i [lsearch -exact $idheads($id) $name]
1759 if {$i >= 0} {
1760 set idheads($id) [lreplace $idheads($id) $i $i]
1763 unset headids($name)
1766 proc make_transient {window origin} {
1767 global have_tk85
1769 # In MacOS Tk 8.4 transient appears to work by setting
1770 # overrideredirect, which is utterly useless, since the
1771 # windows get no border, and are not even kept above
1772 # the parent.
1773 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1775 wm transient $window $origin
1777 # Windows fails to place transient windows normally, so
1778 # schedule a callback to center them on the parent.
1779 if {[tk windowingsystem] eq {win32}} {
1780 after idle [list tk::PlaceWindow $window widget $origin]
1784 proc show_error {w top msg} {
1785 message $w.m -text $msg -justify center -aspect 400
1786 pack $w.m -side top -fill x -padx 20 -pady 20
1787 button $w.ok -text [mc OK] -command "destroy $top"
1788 pack $w.ok -side bottom -fill x
1789 bind $top <Visibility> "grab $top; focus $top"
1790 bind $top <Key-Return> "destroy $top"
1791 bind $top <Key-space> "destroy $top"
1792 bind $top <Key-Escape> "destroy $top"
1793 tkwait window $top
1796 proc error_popup {msg {owner .}} {
1797 set w .error
1798 toplevel $w
1799 make_transient $w $owner
1800 show_error $w $w $msg
1803 proc confirm_popup {msg {owner .}} {
1804 global confirm_ok
1805 set confirm_ok 0
1806 set w .confirm
1807 toplevel $w
1808 make_transient $w $owner
1809 message $w.m -text $msg -justify center -aspect 400
1810 pack $w.m -side top -fill x -padx 20 -pady 20
1811 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1812 pack $w.ok -side left -fill x
1813 button $w.cancel -text [mc Cancel] -command "destroy $w"
1814 pack $w.cancel -side right -fill x
1815 bind $w <Visibility> "grab $w; focus $w"
1816 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1817 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1818 bind $w <Key-Escape> "destroy $w"
1819 tkwait window $w
1820 return $confirm_ok
1823 proc setoptions {} {
1824 option add *Panedwindow.showHandle 1 startupFile
1825 option add *Panedwindow.sashRelief raised startupFile
1826 option add *Button.font uifont startupFile
1827 option add *Checkbutton.font uifont startupFile
1828 option add *Radiobutton.font uifont startupFile
1829 option add *Menu.font uifont startupFile
1830 option add *Menubutton.font uifont startupFile
1831 option add *Label.font uifont startupFile
1832 option add *Message.font uifont startupFile
1833 option add *Entry.font uifont startupFile
1836 # Make a menu and submenus.
1837 # m is the window name for the menu, items is the list of menu items to add.
1838 # Each item is a list {mc label type description options...}
1839 # mc is ignored; it's so we can put mc there to alert xgettext
1840 # label is the string that appears in the menu
1841 # type is cascade, command or radiobutton (should add checkbutton)
1842 # description depends on type; it's the sublist for cascade, the
1843 # command to invoke for command, or {variable value} for radiobutton
1844 proc makemenu {m items} {
1845 menu $m
1846 if {[tk windowingsystem] eq {aqua}} {
1847 set Meta1 Cmd
1848 } else {
1849 set Meta1 Ctrl
1851 foreach i $items {
1852 set name [mc [lindex $i 1]]
1853 set type [lindex $i 2]
1854 set thing [lindex $i 3]
1855 set params [list $type]
1856 if {$name ne {}} {
1857 set u [string first "&" [string map {&& x} $name]]
1858 lappend params -label [string map {&& & & {}} $name]
1859 if {$u >= 0} {
1860 lappend params -underline $u
1863 switch -- $type {
1864 "cascade" {
1865 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1866 lappend params -menu $m.$submenu
1868 "command" {
1869 lappend params -command $thing
1871 "radiobutton" {
1872 lappend params -variable [lindex $thing 0] \
1873 -value [lindex $thing 1]
1876 set tail [lrange $i 4 end]
1877 regsub -all {\yMeta1\y} $tail $Meta1 tail
1878 eval $m add $params $tail
1879 if {$type eq "cascade"} {
1880 makemenu $m.$submenu $thing
1885 # translate string and remove ampersands
1886 proc mca {str} {
1887 return [string map {&& & & {}} [mc $str]]
1890 proc makewindow {} {
1891 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1892 global tabstop
1893 global findtype findtypemenu findloc findstring fstring geometry
1894 global entries sha1entry sha1string sha1but
1895 global diffcontextstring diffcontext
1896 global ignorespace
1897 global maincursor textcursor curtextcursor
1898 global rowctxmenu fakerowmenu mergemax wrapcomment
1899 global highlight_files gdttype
1900 global searchstring sstring
1901 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1902 global headctxmenu progresscanv progressitem progresscoords statusw
1903 global fprogitem fprogcoord lastprogupdate progupdatepending
1904 global rprogitem rprogcoord rownumsel numcommits
1905 global have_tk85
1907 # The "mc" arguments here are purely so that xgettext
1908 # sees the following string as needing to be translated
1909 makemenu .bar {
1910 {mc "File" cascade {
1911 {mc "Update" command updatecommits -accelerator F5}
1912 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1913 {mc "Reread references" command rereadrefs}
1914 {mc "List references" command showrefs -accelerator F2}
1915 {xx "" separator}
1916 {mc "Start git gui" command {exec git gui &}}
1917 {xx "" separator}
1918 {mc "Quit" command doquit -accelerator Meta1-Q}
1920 {mc "Edit" cascade {
1921 {mc "Preferences" command doprefs}
1923 {mc "View" cascade {
1924 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1925 {mc "Edit view..." command editview -state disabled -accelerator F4}
1926 {mc "Delete view" command delview -state disabled}
1927 {xx "" separator}
1928 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1930 {mc "Help" cascade {
1931 {mc "About gitk" command about}
1932 {mc "Key bindings" command keys}
1935 . configure -menu .bar
1937 # the gui has upper and lower half, parts of a paned window.
1938 panedwindow .ctop -orient vertical
1940 # possibly use assumed geometry
1941 if {![info exists geometry(pwsash0)]} {
1942 set geometry(topheight) [expr {15 * $linespc}]
1943 set geometry(topwidth) [expr {80 * $charspc}]
1944 set geometry(botheight) [expr {15 * $linespc}]
1945 set geometry(botwidth) [expr {50 * $charspc}]
1946 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1947 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1950 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1951 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1952 frame .tf.histframe
1953 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1955 # create three canvases
1956 set cscroll .tf.histframe.csb
1957 set canv .tf.histframe.pwclist.canv
1958 canvas $canv \
1959 -selectbackground $selectbgcolor \
1960 -background $bgcolor -bd 0 \
1961 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1962 .tf.histframe.pwclist add $canv
1963 set canv2 .tf.histframe.pwclist.canv2
1964 canvas $canv2 \
1965 -selectbackground $selectbgcolor \
1966 -background $bgcolor -bd 0 -yscrollincr $linespc
1967 .tf.histframe.pwclist add $canv2
1968 set canv3 .tf.histframe.pwclist.canv3
1969 canvas $canv3 \
1970 -selectbackground $selectbgcolor \
1971 -background $bgcolor -bd 0 -yscrollincr $linespc
1972 .tf.histframe.pwclist add $canv3
1973 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1974 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1976 # a scroll bar to rule them
1977 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1978 pack $cscroll -side right -fill y
1979 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1980 lappend bglist $canv $canv2 $canv3
1981 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1983 # we have two button bars at bottom of top frame. Bar 1
1984 frame .tf.bar
1985 frame .tf.lbar -height 15
1987 set sha1entry .tf.bar.sha1
1988 set entries $sha1entry
1989 set sha1but .tf.bar.sha1label
1990 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1991 -command gotocommit -width 8
1992 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1993 pack .tf.bar.sha1label -side left
1994 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1995 trace add variable sha1string write sha1change
1996 pack $sha1entry -side left -pady 2
1998 image create bitmap bm-left -data {
1999 #define left_width 16
2000 #define left_height 16
2001 static unsigned char left_bits[] = {
2002 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2003 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2004 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2006 image create bitmap bm-right -data {
2007 #define right_width 16
2008 #define right_height 16
2009 static unsigned char right_bits[] = {
2010 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2011 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2012 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2014 button .tf.bar.leftbut -image bm-left -command goback \
2015 -state disabled -width 26
2016 pack .tf.bar.leftbut -side left -fill y
2017 button .tf.bar.rightbut -image bm-right -command goforw \
2018 -state disabled -width 26
2019 pack .tf.bar.rightbut -side left -fill y
2021 label .tf.bar.rowlabel -text [mc "Row"]
2022 set rownumsel {}
2023 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2024 -relief sunken -anchor e
2025 label .tf.bar.rowlabel2 -text "/"
2026 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2027 -relief sunken -anchor e
2028 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2029 -side left
2030 global selectedline
2031 trace add variable selectedline write selectedline_change
2033 # Status label and progress bar
2034 set statusw .tf.bar.status
2035 label $statusw -width 15 -relief sunken
2036 pack $statusw -side left -padx 5
2037 set h [expr {[font metrics uifont -linespace] + 2}]
2038 set progresscanv .tf.bar.progress
2039 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2040 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2041 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2042 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2043 pack $progresscanv -side right -expand 1 -fill x
2044 set progresscoords {0 0}
2045 set fprogcoord 0
2046 set rprogcoord 0
2047 bind $progresscanv <Configure> adjustprogress
2048 set lastprogupdate [clock clicks -milliseconds]
2049 set progupdatepending 0
2051 # build up the bottom bar of upper window
2052 label .tf.lbar.flabel -text "[mc "Find"] "
2053 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2054 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2055 label .tf.lbar.flab2 -text " [mc "commit"] "
2056 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2057 -side left -fill y
2058 set gdttype [mc "containing:"]
2059 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2060 [mc "containing:"] \
2061 [mc "touching paths:"] \
2062 [mc "adding/removing string:"]]
2063 trace add variable gdttype write gdttype_change
2064 pack .tf.lbar.gdttype -side left -fill y
2066 set findstring {}
2067 set fstring .tf.lbar.findstring
2068 lappend entries $fstring
2069 entry $fstring -width 30 -font textfont -textvariable findstring
2070 trace add variable findstring write find_change
2071 set findtype [mc "Exact"]
2072 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2073 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2074 trace add variable findtype write findcom_change
2075 set findloc [mc "All fields"]
2076 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2077 [mc "Comments"] [mc "Author"] [mc "Committer"]
2078 trace add variable findloc write find_change
2079 pack .tf.lbar.findloc -side right
2080 pack .tf.lbar.findtype -side right
2081 pack $fstring -side left -expand 1 -fill x
2083 # Finish putting the upper half of the viewer together
2084 pack .tf.lbar -in .tf -side bottom -fill x
2085 pack .tf.bar -in .tf -side bottom -fill x
2086 pack .tf.histframe -fill both -side top -expand 1
2087 .ctop add .tf
2088 .ctop paneconfigure .tf -height $geometry(topheight)
2089 .ctop paneconfigure .tf -width $geometry(topwidth)
2091 # now build up the bottom
2092 panedwindow .pwbottom -orient horizontal
2094 # lower left, a text box over search bar, scroll bar to the right
2095 # if we know window height, then that will set the lower text height, otherwise
2096 # we set lower text height which will drive window height
2097 if {[info exists geometry(main)]} {
2098 frame .bleft -width $geometry(botwidth)
2099 } else {
2100 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2102 frame .bleft.top
2103 frame .bleft.mid
2104 frame .bleft.bottom
2106 button .bleft.top.search -text [mc "Search"] -command dosearch
2107 pack .bleft.top.search -side left -padx 5
2108 set sstring .bleft.top.sstring
2109 entry $sstring -width 20 -font textfont -textvariable searchstring
2110 lappend entries $sstring
2111 trace add variable searchstring write incrsearch
2112 pack $sstring -side left -expand 1 -fill x
2113 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2114 -command changediffdisp -variable diffelide -value {0 0}
2115 radiobutton .bleft.mid.old -text [mc "Old version"] \
2116 -command changediffdisp -variable diffelide -value {0 1}
2117 radiobutton .bleft.mid.new -text [mc "New version"] \
2118 -command changediffdisp -variable diffelide -value {1 0}
2119 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2120 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2121 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2122 -from 1 -increment 1 -to 10000000 \
2123 -validate all -validatecommand "diffcontextvalidate %P" \
2124 -textvariable diffcontextstring
2125 .bleft.mid.diffcontext set $diffcontext
2126 trace add variable diffcontextstring write diffcontextchange
2127 lappend entries .bleft.mid.diffcontext
2128 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2129 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2130 -command changeignorespace -variable ignorespace
2131 pack .bleft.mid.ignspace -side left -padx 5
2132 set ctext .bleft.bottom.ctext
2133 text $ctext -background $bgcolor -foreground $fgcolor \
2134 -state disabled -font textfont \
2135 -yscrollcommand scrolltext -wrap none \
2136 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2137 if {$have_tk85} {
2138 $ctext conf -tabstyle wordprocessor
2140 scrollbar .bleft.bottom.sb -command "$ctext yview"
2141 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2142 -width 10
2143 pack .bleft.top -side top -fill x
2144 pack .bleft.mid -side top -fill x
2145 grid $ctext .bleft.bottom.sb -sticky nsew
2146 grid .bleft.bottom.sbhorizontal -sticky ew
2147 grid columnconfigure .bleft.bottom 0 -weight 1
2148 grid rowconfigure .bleft.bottom 0 -weight 1
2149 grid rowconfigure .bleft.bottom 1 -weight 0
2150 pack .bleft.bottom -side top -fill both -expand 1
2151 lappend bglist $ctext
2152 lappend fglist $ctext
2154 $ctext tag conf comment -wrap $wrapcomment
2155 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2156 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2157 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2158 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2159 $ctext tag conf m0 -fore red
2160 $ctext tag conf m1 -fore blue
2161 $ctext tag conf m2 -fore green
2162 $ctext tag conf m3 -fore purple
2163 $ctext tag conf m4 -fore brown
2164 $ctext tag conf m5 -fore "#009090"
2165 $ctext tag conf m6 -fore magenta
2166 $ctext tag conf m7 -fore "#808000"
2167 $ctext tag conf m8 -fore "#009000"
2168 $ctext tag conf m9 -fore "#ff0080"
2169 $ctext tag conf m10 -fore cyan
2170 $ctext tag conf m11 -fore "#b07070"
2171 $ctext tag conf m12 -fore "#70b0f0"
2172 $ctext tag conf m13 -fore "#70f0b0"
2173 $ctext tag conf m14 -fore "#f0b070"
2174 $ctext tag conf m15 -fore "#ff70b0"
2175 $ctext tag conf mmax -fore darkgrey
2176 set mergemax 16
2177 $ctext tag conf mresult -font textfontbold
2178 $ctext tag conf msep -font textfontbold
2179 $ctext tag conf found -back yellow
2181 .pwbottom add .bleft
2182 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2184 # lower right
2185 frame .bright
2186 frame .bright.mode
2187 radiobutton .bright.mode.patch -text [mc "Patch"] \
2188 -command reselectline -variable cmitmode -value "patch"
2189 radiobutton .bright.mode.tree -text [mc "Tree"] \
2190 -command reselectline -variable cmitmode -value "tree"
2191 grid .bright.mode.patch .bright.mode.tree -sticky ew
2192 pack .bright.mode -side top -fill x
2193 set cflist .bright.cfiles
2194 set indent [font measure mainfont "nn"]
2195 text $cflist \
2196 -selectbackground $selectbgcolor \
2197 -background $bgcolor -foreground $fgcolor \
2198 -font mainfont \
2199 -tabs [list $indent [expr {2 * $indent}]] \
2200 -yscrollcommand ".bright.sb set" \
2201 -cursor [. cget -cursor] \
2202 -spacing1 1 -spacing3 1
2203 lappend bglist $cflist
2204 lappend fglist $cflist
2205 scrollbar .bright.sb -command "$cflist yview"
2206 pack .bright.sb -side right -fill y
2207 pack $cflist -side left -fill both -expand 1
2208 $cflist tag configure highlight \
2209 -background [$cflist cget -selectbackground]
2210 $cflist tag configure bold -font mainfontbold
2212 .pwbottom add .bright
2213 .ctop add .pwbottom
2215 # restore window width & height if known
2216 if {[info exists geometry(main)]} {
2217 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2218 if {$w > [winfo screenwidth .]} {
2219 set w [winfo screenwidth .]
2221 if {$h > [winfo screenheight .]} {
2222 set h [winfo screenheight .]
2224 wm geometry . "${w}x$h"
2228 if {[tk windowingsystem] eq {aqua}} {
2229 set M1B M1
2230 } else {
2231 set M1B Control
2234 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2235 pack .ctop -fill both -expand 1
2236 bindall <1> {selcanvline %W %x %y}
2237 #bindall <B1-Motion> {selcanvline %W %x %y}
2238 if {[tk windowingsystem] == "win32"} {
2239 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2240 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2241 } else {
2242 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2243 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2244 if {[tk windowingsystem] eq "aqua"} {
2245 bindall <MouseWheel> {
2246 set delta [expr {- (%D)}]
2247 allcanvs yview scroll $delta units
2251 bindall <2> "canvscan mark %W %x %y"
2252 bindall <B2-Motion> "canvscan dragto %W %x %y"
2253 bindkey <Home> selfirstline
2254 bindkey <End> sellastline
2255 bind . <Key-Up> "selnextline -1"
2256 bind . <Key-Down> "selnextline 1"
2257 bind . <Shift-Key-Up> "dofind -1 0"
2258 bind . <Shift-Key-Down> "dofind 1 0"
2259 bindkey <Key-Right> "goforw"
2260 bindkey <Key-Left> "goback"
2261 bind . <Key-Prior> "selnextpage -1"
2262 bind . <Key-Next> "selnextpage 1"
2263 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2264 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2265 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2266 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2267 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2268 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2269 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2270 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2271 bindkey <Key-space> "$ctext yview scroll 1 pages"
2272 bindkey p "selnextline -1"
2273 bindkey n "selnextline 1"
2274 bindkey z "goback"
2275 bindkey x "goforw"
2276 bindkey i "selnextline -1"
2277 bindkey k "selnextline 1"
2278 bindkey j "goback"
2279 bindkey l "goforw"
2280 bindkey b prevfile
2281 bindkey d "$ctext yview scroll 18 units"
2282 bindkey u "$ctext yview scroll -18 units"
2283 bindkey / {focus $fstring}
2284 bindkey <Key-Return> {dofind 1 1}
2285 bindkey ? {dofind -1 1}
2286 bindkey f nextfile
2287 bind . <F5> updatecommits
2288 bind . <$M1B-F5> reloadcommits
2289 bind . <F2> showrefs
2290 bind . <Shift-F4> {newview 0}
2291 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2292 bind . <F4> edit_or_newview
2293 bind . <$M1B-q> doquit
2294 bind . <$M1B-f> {dofind 1 1}
2295 bind . <$M1B-g> {dofind 1 0}
2296 bind . <$M1B-r> dosearchback
2297 bind . <$M1B-s> dosearch
2298 bind . <$M1B-equal> {incrfont 1}
2299 bind . <$M1B-plus> {incrfont 1}
2300 bind . <$M1B-KP_Add> {incrfont 1}
2301 bind . <$M1B-minus> {incrfont -1}
2302 bind . <$M1B-KP_Subtract> {incrfont -1}
2303 wm protocol . WM_DELETE_WINDOW doquit
2304 bind . <Destroy> {stop_backends}
2305 bind . <Button-1> "click %W"
2306 bind $fstring <Key-Return> {dofind 1 1}
2307 bind $sha1entry <Key-Return> {gotocommit; break}
2308 bind $sha1entry <<PasteSelection>> clearsha1
2309 bind $cflist <1> {sel_flist %W %x %y; break}
2310 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2311 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2312 global ctxbut
2313 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2314 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2316 set maincursor [. cget -cursor]
2317 set textcursor [$ctext cget -cursor]
2318 set curtextcursor $textcursor
2320 set rowctxmenu .rowctxmenu
2321 makemenu $rowctxmenu {
2322 {mc "Diff this -> selected" command {diffvssel 0}}
2323 {mc "Diff selected -> this" command {diffvssel 1}}
2324 {mc "Make patch" command mkpatch}
2325 {mc "Create tag" command mktag}
2326 {mc "Write commit to file" command writecommit}
2327 {mc "Create new branch" command mkbranch}
2328 {mc "Cherry-pick this commit" command cherrypick}
2329 {mc "Reset HEAD branch to here" command resethead}
2331 $rowctxmenu configure -tearoff 0
2333 set fakerowmenu .fakerowmenu
2334 makemenu $fakerowmenu {
2335 {mc "Diff this -> selected" command {diffvssel 0}}
2336 {mc "Diff selected -> this" command {diffvssel 1}}
2337 {mc "Make patch" command mkpatch}
2339 $fakerowmenu configure -tearoff 0
2341 set headctxmenu .headctxmenu
2342 makemenu $headctxmenu {
2343 {mc "Check out this branch" command cobranch}
2344 {mc "Remove this branch" command rmbranch}
2346 $headctxmenu configure -tearoff 0
2348 global flist_menu
2349 set flist_menu .flistctxmenu
2350 makemenu $flist_menu {
2351 {mc "Highlight this too" command {flist_hl 0}}
2352 {mc "Highlight this only" command {flist_hl 1}}
2353 {mc "External diff" command {external_diff}}
2354 {mc "Blame parent commit" command {external_blame 1}}
2356 $flist_menu configure -tearoff 0
2358 global diff_menu
2359 set diff_menu .diffctxmenu
2360 makemenu $diff_menu {
2361 {mc "Show origin of this line" command show_line_source}
2362 {mc "Run git gui blame on this line" command {external_blame_diff}}
2364 $diff_menu configure -tearoff 0
2367 # Windows sends all mouse wheel events to the current focused window, not
2368 # the one where the mouse hovers, so bind those events here and redirect
2369 # to the correct window
2370 proc windows_mousewheel_redirector {W X Y D} {
2371 global canv canv2 canv3
2372 set w [winfo containing -displayof $W $X $Y]
2373 if {$w ne ""} {
2374 set u [expr {$D < 0 ? 5 : -5}]
2375 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2376 allcanvs yview scroll $u units
2377 } else {
2378 catch {
2379 $w yview scroll $u units
2385 # Update row number label when selectedline changes
2386 proc selectedline_change {n1 n2 op} {
2387 global selectedline rownumsel
2389 if {$selectedline eq {}} {
2390 set rownumsel {}
2391 } else {
2392 set rownumsel [expr {$selectedline + 1}]
2396 # mouse-2 makes all windows scan vertically, but only the one
2397 # the cursor is in scans horizontally
2398 proc canvscan {op w x y} {
2399 global canv canv2 canv3
2400 foreach c [list $canv $canv2 $canv3] {
2401 if {$c == $w} {
2402 $c scan $op $x $y
2403 } else {
2404 $c scan $op 0 $y
2409 proc scrollcanv {cscroll f0 f1} {
2410 $cscroll set $f0 $f1
2411 drawvisible
2412 flushhighlights
2415 # when we make a key binding for the toplevel, make sure
2416 # it doesn't get triggered when that key is pressed in the
2417 # find string entry widget.
2418 proc bindkey {ev script} {
2419 global entries
2420 bind . $ev $script
2421 set escript [bind Entry $ev]
2422 if {$escript == {}} {
2423 set escript [bind Entry <Key>]
2425 foreach e $entries {
2426 bind $e $ev "$escript; break"
2430 # set the focus back to the toplevel for any click outside
2431 # the entry widgets
2432 proc click {w} {
2433 global ctext entries
2434 foreach e [concat $entries $ctext] {
2435 if {$w == $e} return
2437 focus .
2440 # Adjust the progress bar for a change in requested extent or canvas size
2441 proc adjustprogress {} {
2442 global progresscanv progressitem progresscoords
2443 global fprogitem fprogcoord lastprogupdate progupdatepending
2444 global rprogitem rprogcoord
2446 set w [expr {[winfo width $progresscanv] - 4}]
2447 set x0 [expr {$w * [lindex $progresscoords 0]}]
2448 set x1 [expr {$w * [lindex $progresscoords 1]}]
2449 set h [winfo height $progresscanv]
2450 $progresscanv coords $progressitem $x0 0 $x1 $h
2451 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2452 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2453 set now [clock clicks -milliseconds]
2454 if {$now >= $lastprogupdate + 100} {
2455 set progupdatepending 0
2456 update
2457 } elseif {!$progupdatepending} {
2458 set progupdatepending 1
2459 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2463 proc doprogupdate {} {
2464 global lastprogupdate progupdatepending
2466 if {$progupdatepending} {
2467 set progupdatepending 0
2468 set lastprogupdate [clock clicks -milliseconds]
2469 update
2473 proc savestuff {w} {
2474 global canv canv2 canv3 mainfont textfont uifont tabstop
2475 global stuffsaved findmergefiles maxgraphpct
2476 global maxwidth showneartags showlocalchanges
2477 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2478 global cmitmode wrapcomment datetimeformat limitdiffs
2479 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2480 global autoselect extdifftool perfile_attrs markbgcolor
2482 if {$stuffsaved} return
2483 if {![winfo viewable .]} return
2484 catch {
2485 set f [open "~/.gitk-new" w]
2486 puts $f [list set mainfont $mainfont]
2487 puts $f [list set textfont $textfont]
2488 puts $f [list set uifont $uifont]
2489 puts $f [list set tabstop $tabstop]
2490 puts $f [list set findmergefiles $findmergefiles]
2491 puts $f [list set maxgraphpct $maxgraphpct]
2492 puts $f [list set maxwidth $maxwidth]
2493 puts $f [list set cmitmode $cmitmode]
2494 puts $f [list set wrapcomment $wrapcomment]
2495 puts $f [list set autoselect $autoselect]
2496 puts $f [list set showneartags $showneartags]
2497 puts $f [list set showlocalchanges $showlocalchanges]
2498 puts $f [list set datetimeformat $datetimeformat]
2499 puts $f [list set limitdiffs $limitdiffs]
2500 puts $f [list set bgcolor $bgcolor]
2501 puts $f [list set fgcolor $fgcolor]
2502 puts $f [list set colors $colors]
2503 puts $f [list set diffcolors $diffcolors]
2504 puts $f [list set markbgcolor $markbgcolor]
2505 puts $f [list set diffcontext $diffcontext]
2506 puts $f [list set selectbgcolor $selectbgcolor]
2507 puts $f [list set extdifftool $extdifftool]
2508 puts $f [list set perfile_attrs $perfile_attrs]
2510 puts $f "set geometry(main) [wm geometry .]"
2511 puts $f "set geometry(topwidth) [winfo width .tf]"
2512 puts $f "set geometry(topheight) [winfo height .tf]"
2513 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2514 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2515 puts $f "set geometry(botwidth) [winfo width .bleft]"
2516 puts $f "set geometry(botheight) [winfo height .bleft]"
2518 puts -nonewline $f "set permviews {"
2519 for {set v 0} {$v < $nextviewnum} {incr v} {
2520 if {$viewperm($v)} {
2521 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2524 puts $f "}"
2525 close $f
2526 file rename -force "~/.gitk-new" "~/.gitk"
2528 set stuffsaved 1
2531 proc resizeclistpanes {win w} {
2532 global oldwidth
2533 if {[info exists oldwidth($win)]} {
2534 set s0 [$win sash coord 0]
2535 set s1 [$win sash coord 1]
2536 if {$w < 60} {
2537 set sash0 [expr {int($w/2 - 2)}]
2538 set sash1 [expr {int($w*5/6 - 2)}]
2539 } else {
2540 set factor [expr {1.0 * $w / $oldwidth($win)}]
2541 set sash0 [expr {int($factor * [lindex $s0 0])}]
2542 set sash1 [expr {int($factor * [lindex $s1 0])}]
2543 if {$sash0 < 30} {
2544 set sash0 30
2546 if {$sash1 < $sash0 + 20} {
2547 set sash1 [expr {$sash0 + 20}]
2549 if {$sash1 > $w - 10} {
2550 set sash1 [expr {$w - 10}]
2551 if {$sash0 > $sash1 - 20} {
2552 set sash0 [expr {$sash1 - 20}]
2556 $win sash place 0 $sash0 [lindex $s0 1]
2557 $win sash place 1 $sash1 [lindex $s1 1]
2559 set oldwidth($win) $w
2562 proc resizecdetpanes {win w} {
2563 global oldwidth
2564 if {[info exists oldwidth($win)]} {
2565 set s0 [$win sash coord 0]
2566 if {$w < 60} {
2567 set sash0 [expr {int($w*3/4 - 2)}]
2568 } else {
2569 set factor [expr {1.0 * $w / $oldwidth($win)}]
2570 set sash0 [expr {int($factor * [lindex $s0 0])}]
2571 if {$sash0 < 45} {
2572 set sash0 45
2574 if {$sash0 > $w - 15} {
2575 set sash0 [expr {$w - 15}]
2578 $win sash place 0 $sash0 [lindex $s0 1]
2580 set oldwidth($win) $w
2583 proc allcanvs args {
2584 global canv canv2 canv3
2585 eval $canv $args
2586 eval $canv2 $args
2587 eval $canv3 $args
2590 proc bindall {event action} {
2591 global canv canv2 canv3
2592 bind $canv $event $action
2593 bind $canv2 $event $action
2594 bind $canv3 $event $action
2597 proc about {} {
2598 global uifont
2599 set w .about
2600 if {[winfo exists $w]} {
2601 raise $w
2602 return
2604 toplevel $w
2605 wm title $w [mc "About gitk"]
2606 make_transient $w .
2607 message $w.m -text [mc "
2608 Gitk - a commit viewer for git
2610 Copyright © 2005-2008 Paul Mackerras
2612 Use and redistribute under the terms of the GNU General Public License"] \
2613 -justify center -aspect 400 -border 2 -bg white -relief groove
2614 pack $w.m -side top -fill x -padx 2 -pady 2
2615 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2616 pack $w.ok -side bottom
2617 bind $w <Visibility> "focus $w.ok"
2618 bind $w <Key-Escape> "destroy $w"
2619 bind $w <Key-Return> "destroy $w"
2622 proc keys {} {
2623 set w .keys
2624 if {[winfo exists $w]} {
2625 raise $w
2626 return
2628 if {[tk windowingsystem] eq {aqua}} {
2629 set M1T Cmd
2630 } else {
2631 set M1T Ctrl
2633 toplevel $w
2634 wm title $w [mc "Gitk key bindings"]
2635 make_transient $w .
2636 message $w.m -text "
2637 [mc "Gitk key bindings:"]
2639 [mc "<%s-Q> Quit" $M1T]
2640 [mc "<Home> Move to first commit"]
2641 [mc "<End> Move to last commit"]
2642 [mc "<Up>, p, i Move up one commit"]
2643 [mc "<Down>, n, k Move down one commit"]
2644 [mc "<Left>, z, j Go back in history list"]
2645 [mc "<Right>, x, l Go forward in history list"]
2646 [mc "<PageUp> Move up one page in commit list"]
2647 [mc "<PageDown> Move down one page in commit list"]
2648 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2649 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2650 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2651 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2652 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2653 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2654 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2655 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2656 [mc "<Delete>, b Scroll diff view up one page"]
2657 [mc "<Backspace> Scroll diff view up one page"]
2658 [mc "<Space> Scroll diff view down one page"]
2659 [mc "u Scroll diff view up 18 lines"]
2660 [mc "d Scroll diff view down 18 lines"]
2661 [mc "<%s-F> Find" $M1T]
2662 [mc "<%s-G> Move to next find hit" $M1T]
2663 [mc "<Return> Move to next find hit"]
2664 [mc "/ Focus the search box"]
2665 [mc "? Move to previous find hit"]
2666 [mc "f Scroll diff view to next file"]
2667 [mc "<%s-S> Search for next hit in diff view" $M1T]
2668 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2669 [mc "<%s-KP+> Increase font size" $M1T]
2670 [mc "<%s-plus> Increase font size" $M1T]
2671 [mc "<%s-KP-> Decrease font size" $M1T]
2672 [mc "<%s-minus> Decrease font size" $M1T]
2673 [mc "<F5> Update"]
2675 -justify left -bg white -border 2 -relief groove
2676 pack $w.m -side top -fill both -padx 2 -pady 2
2677 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2678 bind $w <Key-Escape> [list destroy $w]
2679 pack $w.ok -side bottom
2680 bind $w <Visibility> "focus $w.ok"
2681 bind $w <Key-Escape> "destroy $w"
2682 bind $w <Key-Return> "destroy $w"
2685 # Procedures for manipulating the file list window at the
2686 # bottom right of the overall window.
2688 proc treeview {w l openlevs} {
2689 global treecontents treediropen treeheight treeparent treeindex
2691 set ix 0
2692 set treeindex() 0
2693 set lev 0
2694 set prefix {}
2695 set prefixend -1
2696 set prefendstack {}
2697 set htstack {}
2698 set ht 0
2699 set treecontents() {}
2700 $w conf -state normal
2701 foreach f $l {
2702 while {[string range $f 0 $prefixend] ne $prefix} {
2703 if {$lev <= $openlevs} {
2704 $w mark set e:$treeindex($prefix) "end -1c"
2705 $w mark gravity e:$treeindex($prefix) left
2707 set treeheight($prefix) $ht
2708 incr ht [lindex $htstack end]
2709 set htstack [lreplace $htstack end end]
2710 set prefixend [lindex $prefendstack end]
2711 set prefendstack [lreplace $prefendstack end end]
2712 set prefix [string range $prefix 0 $prefixend]
2713 incr lev -1
2715 set tail [string range $f [expr {$prefixend+1}] end]
2716 while {[set slash [string first "/" $tail]] >= 0} {
2717 lappend htstack $ht
2718 set ht 0
2719 lappend prefendstack $prefixend
2720 incr prefixend [expr {$slash + 1}]
2721 set d [string range $tail 0 $slash]
2722 lappend treecontents($prefix) $d
2723 set oldprefix $prefix
2724 append prefix $d
2725 set treecontents($prefix) {}
2726 set treeindex($prefix) [incr ix]
2727 set treeparent($prefix) $oldprefix
2728 set tail [string range $tail [expr {$slash+1}] end]
2729 if {$lev <= $openlevs} {
2730 set ht 1
2731 set treediropen($prefix) [expr {$lev < $openlevs}]
2732 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2733 $w mark set d:$ix "end -1c"
2734 $w mark gravity d:$ix left
2735 set str "\n"
2736 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2737 $w insert end $str
2738 $w image create end -align center -image $bm -padx 1 \
2739 -name a:$ix
2740 $w insert end $d [highlight_tag $prefix]
2741 $w mark set s:$ix "end -1c"
2742 $w mark gravity s:$ix left
2744 incr lev
2746 if {$tail ne {}} {
2747 if {$lev <= $openlevs} {
2748 incr ht
2749 set str "\n"
2750 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2751 $w insert end $str
2752 $w insert end $tail [highlight_tag $f]
2754 lappend treecontents($prefix) $tail
2757 while {$htstack ne {}} {
2758 set treeheight($prefix) $ht
2759 incr ht [lindex $htstack end]
2760 set htstack [lreplace $htstack end end]
2761 set prefixend [lindex $prefendstack end]
2762 set prefendstack [lreplace $prefendstack end end]
2763 set prefix [string range $prefix 0 $prefixend]
2765 $w conf -state disabled
2768 proc linetoelt {l} {
2769 global treeheight treecontents
2771 set y 2
2772 set prefix {}
2773 while {1} {
2774 foreach e $treecontents($prefix) {
2775 if {$y == $l} {
2776 return "$prefix$e"
2778 set n 1
2779 if {[string index $e end] eq "/"} {
2780 set n $treeheight($prefix$e)
2781 if {$y + $n > $l} {
2782 append prefix $e
2783 incr y
2784 break
2787 incr y $n
2792 proc highlight_tree {y prefix} {
2793 global treeheight treecontents cflist
2795 foreach e $treecontents($prefix) {
2796 set path $prefix$e
2797 if {[highlight_tag $path] ne {}} {
2798 $cflist tag add bold $y.0 "$y.0 lineend"
2800 incr y
2801 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2802 set y [highlight_tree $y $path]
2805 return $y
2808 proc treeclosedir {w dir} {
2809 global treediropen treeheight treeparent treeindex
2811 set ix $treeindex($dir)
2812 $w conf -state normal
2813 $w delete s:$ix e:$ix
2814 set treediropen($dir) 0
2815 $w image configure a:$ix -image tri-rt
2816 $w conf -state disabled
2817 set n [expr {1 - $treeheight($dir)}]
2818 while {$dir ne {}} {
2819 incr treeheight($dir) $n
2820 set dir $treeparent($dir)
2824 proc treeopendir {w dir} {
2825 global treediropen treeheight treeparent treecontents treeindex
2827 set ix $treeindex($dir)
2828 $w conf -state normal
2829 $w image configure a:$ix -image tri-dn
2830 $w mark set e:$ix s:$ix
2831 $w mark gravity e:$ix right
2832 set lev 0
2833 set str "\n"
2834 set n [llength $treecontents($dir)]
2835 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2836 incr lev
2837 append str "\t"
2838 incr treeheight($x) $n
2840 foreach e $treecontents($dir) {
2841 set de $dir$e
2842 if {[string index $e end] eq "/"} {
2843 set iy $treeindex($de)
2844 $w mark set d:$iy e:$ix
2845 $w mark gravity d:$iy left
2846 $w insert e:$ix $str
2847 set treediropen($de) 0
2848 $w image create e:$ix -align center -image tri-rt -padx 1 \
2849 -name a:$iy
2850 $w insert e:$ix $e [highlight_tag $de]
2851 $w mark set s:$iy e:$ix
2852 $w mark gravity s:$iy left
2853 set treeheight($de) 1
2854 } else {
2855 $w insert e:$ix $str
2856 $w insert e:$ix $e [highlight_tag $de]
2859 $w mark gravity e:$ix right
2860 $w conf -state disabled
2861 set treediropen($dir) 1
2862 set top [lindex [split [$w index @0,0] .] 0]
2863 set ht [$w cget -height]
2864 set l [lindex [split [$w index s:$ix] .] 0]
2865 if {$l < $top} {
2866 $w yview $l.0
2867 } elseif {$l + $n + 1 > $top + $ht} {
2868 set top [expr {$l + $n + 2 - $ht}]
2869 if {$l < $top} {
2870 set top $l
2872 $w yview $top.0
2876 proc treeclick {w x y} {
2877 global treediropen cmitmode ctext cflist cflist_top
2879 if {$cmitmode ne "tree"} return
2880 if {![info exists cflist_top]} return
2881 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2882 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2883 $cflist tag add highlight $l.0 "$l.0 lineend"
2884 set cflist_top $l
2885 if {$l == 1} {
2886 $ctext yview 1.0
2887 return
2889 set e [linetoelt $l]
2890 if {[string index $e end] ne "/"} {
2891 showfile $e
2892 } elseif {$treediropen($e)} {
2893 treeclosedir $w $e
2894 } else {
2895 treeopendir $w $e
2899 proc setfilelist {id} {
2900 global treefilelist cflist jump_to_here
2902 treeview $cflist $treefilelist($id) 0
2903 if {$jump_to_here ne {}} {
2904 set f [lindex $jump_to_here 0]
2905 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2906 showfile $f
2911 image create bitmap tri-rt -background black -foreground blue -data {
2912 #define tri-rt_width 13
2913 #define tri-rt_height 13
2914 static unsigned char tri-rt_bits[] = {
2915 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2916 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2917 0x00, 0x00};
2918 } -maskdata {
2919 #define tri-rt-mask_width 13
2920 #define tri-rt-mask_height 13
2921 static unsigned char tri-rt-mask_bits[] = {
2922 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2923 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2924 0x08, 0x00};
2926 image create bitmap tri-dn -background black -foreground blue -data {
2927 #define tri-dn_width 13
2928 #define tri-dn_height 13
2929 static unsigned char tri-dn_bits[] = {
2930 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2931 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2932 0x00, 0x00};
2933 } -maskdata {
2934 #define tri-dn-mask_width 13
2935 #define tri-dn-mask_height 13
2936 static unsigned char tri-dn-mask_bits[] = {
2937 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2938 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2939 0x00, 0x00};
2942 image create bitmap reficon-T -background black -foreground yellow -data {
2943 #define tagicon_width 13
2944 #define tagicon_height 9
2945 static unsigned char tagicon_bits[] = {
2946 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2947 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2948 } -maskdata {
2949 #define tagicon-mask_width 13
2950 #define tagicon-mask_height 9
2951 static unsigned char tagicon-mask_bits[] = {
2952 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2953 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2955 set rectdata {
2956 #define headicon_width 13
2957 #define headicon_height 9
2958 static unsigned char headicon_bits[] = {
2959 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2960 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2962 set rectmask {
2963 #define headicon-mask_width 13
2964 #define headicon-mask_height 9
2965 static unsigned char headicon-mask_bits[] = {
2966 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2967 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2969 image create bitmap reficon-H -background black -foreground green \
2970 -data $rectdata -maskdata $rectmask
2971 image create bitmap reficon-o -background black -foreground "#ddddff" \
2972 -data $rectdata -maskdata $rectmask
2974 proc init_flist {first} {
2975 global cflist cflist_top difffilestart
2977 $cflist conf -state normal
2978 $cflist delete 0.0 end
2979 if {$first ne {}} {
2980 $cflist insert end $first
2981 set cflist_top 1
2982 $cflist tag add highlight 1.0 "1.0 lineend"
2983 } else {
2984 catch {unset cflist_top}
2986 $cflist conf -state disabled
2987 set difffilestart {}
2990 proc highlight_tag {f} {
2991 global highlight_paths
2993 foreach p $highlight_paths {
2994 if {[string match $p $f]} {
2995 return "bold"
2998 return {}
3001 proc highlight_filelist {} {
3002 global cmitmode cflist
3004 $cflist conf -state normal
3005 if {$cmitmode ne "tree"} {
3006 set end [lindex [split [$cflist index end] .] 0]
3007 for {set l 2} {$l < $end} {incr l} {
3008 set line [$cflist get $l.0 "$l.0 lineend"]
3009 if {[highlight_tag $line] ne {}} {
3010 $cflist tag add bold $l.0 "$l.0 lineend"
3013 } else {
3014 highlight_tree 2 {}
3016 $cflist conf -state disabled
3019 proc unhighlight_filelist {} {
3020 global cflist
3022 $cflist conf -state normal
3023 $cflist tag remove bold 1.0 end
3024 $cflist conf -state disabled
3027 proc add_flist {fl} {
3028 global cflist
3030 $cflist conf -state normal
3031 foreach f $fl {
3032 $cflist insert end "\n"
3033 $cflist insert end $f [highlight_tag $f]
3035 $cflist conf -state disabled
3038 proc sel_flist {w x y} {
3039 global ctext difffilestart cflist cflist_top cmitmode
3041 if {$cmitmode eq "tree"} return
3042 if {![info exists cflist_top]} return
3043 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3044 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3045 $cflist tag add highlight $l.0 "$l.0 lineend"
3046 set cflist_top $l
3047 if {$l == 1} {
3048 $ctext yview 1.0
3049 } else {
3050 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3054 proc pop_flist_menu {w X Y x y} {
3055 global ctext cflist cmitmode flist_menu flist_menu_file
3056 global treediffs diffids
3058 stopfinding
3059 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3060 if {$l <= 1} return
3061 if {$cmitmode eq "tree"} {
3062 set e [linetoelt $l]
3063 if {[string index $e end] eq "/"} return
3064 } else {
3065 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3067 set flist_menu_file $e
3068 set xdiffstate "normal"
3069 if {$cmitmode eq "tree"} {
3070 set xdiffstate "disabled"
3072 # Disable "External diff" item in tree mode
3073 $flist_menu entryconf 2 -state $xdiffstate
3074 tk_popup $flist_menu $X $Y
3077 proc find_ctext_fileinfo {line} {
3078 global ctext_file_names ctext_file_lines
3080 set ok [bsearch $ctext_file_lines $line]
3081 set tline [lindex $ctext_file_lines $ok]
3083 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3084 return {}
3085 } else {
3086 return [list [lindex $ctext_file_names $ok] $tline]
3090 proc pop_diff_menu {w X Y x y} {
3091 global ctext diff_menu flist_menu_file
3092 global diff_menu_txtpos diff_menu_line
3093 global diff_menu_filebase
3095 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3096 set diff_menu_line [lindex $diff_menu_txtpos 0]
3097 # don't pop up the menu on hunk-separator or file-separator lines
3098 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3099 return
3101 stopfinding
3102 set f [find_ctext_fileinfo $diff_menu_line]
3103 if {$f eq {}} return
3104 set flist_menu_file [lindex $f 0]
3105 set diff_menu_filebase [lindex $f 1]
3106 tk_popup $diff_menu $X $Y
3109 proc flist_hl {only} {
3110 global flist_menu_file findstring gdttype
3112 set x [shellquote $flist_menu_file]
3113 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3114 set findstring $x
3115 } else {
3116 append findstring " " $x
3118 set gdttype [mc "touching paths:"]
3121 proc save_file_from_commit {filename output what} {
3122 global nullfile
3124 if {[catch {exec git show $filename -- > $output} err]} {
3125 if {[string match "fatal: bad revision *" $err]} {
3126 return $nullfile
3128 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3129 return {}
3131 return $output
3134 proc external_diff_get_one_file {diffid filename diffdir} {
3135 global nullid nullid2 nullfile
3136 global gitdir
3138 if {$diffid == $nullid} {
3139 set difffile [file join [file dirname $gitdir] $filename]
3140 if {[file exists $difffile]} {
3141 return $difffile
3143 return $nullfile
3145 if {$diffid == $nullid2} {
3146 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3147 return [save_file_from_commit :$filename $difffile index]
3149 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3150 return [save_file_from_commit $diffid:$filename $difffile \
3151 "revision $diffid"]
3154 proc external_diff {} {
3155 global gitktmpdir nullid nullid2
3156 global flist_menu_file
3157 global diffids
3158 global diffnum
3159 global gitdir extdifftool
3161 if {[llength $diffids] == 1} {
3162 # no reference commit given
3163 set diffidto [lindex $diffids 0]
3164 if {$diffidto eq $nullid} {
3165 # diffing working copy with index
3166 set diffidfrom $nullid2
3167 } elseif {$diffidto eq $nullid2} {
3168 # diffing index with HEAD
3169 set diffidfrom "HEAD"
3170 } else {
3171 # use first parent commit
3172 global parentlist selectedline
3173 set diffidfrom [lindex $parentlist $selectedline 0]
3175 } else {
3176 set diffidfrom [lindex $diffids 0]
3177 set diffidto [lindex $diffids 1]
3180 # make sure that several diffs wont collide
3181 if {![info exists gitktmpdir]} {
3182 set gitktmpdir [file join [file dirname $gitdir] \
3183 [format ".gitk-tmp.%s" [pid]]]
3184 if {[catch {file mkdir $gitktmpdir} err]} {
3185 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3186 unset gitktmpdir
3187 return
3189 set diffnum 0
3191 incr diffnum
3192 set diffdir [file join $gitktmpdir $diffnum]
3193 if {[catch {file mkdir $diffdir} err]} {
3194 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3195 return
3198 # gather files to diff
3199 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3200 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3202 if {$difffromfile ne {} && $difftofile ne {}} {
3203 set cmd [concat | [shellsplit $extdifftool] \
3204 [list $difffromfile $difftofile]]
3205 if {[catch {set fl [open $cmd r]} err]} {
3206 file delete -force $diffdir
3207 error_popup "$extdifftool: [mc "command failed:"] $err"
3208 } else {
3209 fconfigure $fl -blocking 0
3210 filerun $fl [list delete_at_eof $fl $diffdir]
3215 proc find_hunk_blamespec {base line} {
3216 global ctext
3218 # Find and parse the hunk header
3219 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3220 if {$s_lix eq {}} return
3222 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3223 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3224 s_line old_specs osz osz1 new_line nsz]} {
3225 return
3228 # base lines for the parents
3229 set base_lines [list $new_line]
3230 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3231 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3232 old_spec old_line osz]} {
3233 return
3235 lappend base_lines $old_line
3238 # Now scan the lines to determine offset within the hunk
3239 set max_parent [expr {[llength $base_lines]-2}]
3240 set dline 0
3241 set s_lno [lindex [split $s_lix "."] 0]
3243 # Determine if the line is removed
3244 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3245 if {[string match {[-+ ]*} $chunk]} {
3246 set removed_idx [string first "-" $chunk]
3247 # Choose a parent index
3248 if {$removed_idx >= 0} {
3249 set parent $removed_idx
3250 } else {
3251 set unchanged_idx [string first " " $chunk]
3252 if {$unchanged_idx >= 0} {
3253 set parent $unchanged_idx
3254 } else {
3255 # blame the current commit
3256 set parent -1
3259 # then count other lines that belong to it
3260 for {set i $line} {[incr i -1] > $s_lno} {} {
3261 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3262 # Determine if the line is removed
3263 set removed_idx [string first "-" $chunk]
3264 if {$parent >= 0} {
3265 set code [string index $chunk $parent]
3266 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3267 incr dline
3269 } else {
3270 if {$removed_idx < 0} {
3271 incr dline
3275 incr parent
3276 } else {
3277 set parent 0
3280 incr dline [lindex $base_lines $parent]
3281 return [list $parent $dline]
3284 proc external_blame_diff {} {
3285 global currentid cmitmode
3286 global diff_menu_txtpos diff_menu_line
3287 global diff_menu_filebase flist_menu_file
3289 if {$cmitmode eq "tree"} {
3290 set parent_idx 0
3291 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3292 } else {
3293 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3294 if {$hinfo ne {}} {
3295 set parent_idx [lindex $hinfo 0]
3296 set line [lindex $hinfo 1]
3297 } else {
3298 set parent_idx 0
3299 set line 0
3303 external_blame $parent_idx $line
3306 # Find the SHA1 ID of the blob for file $fname in the index
3307 # at stage 0 or 2
3308 proc index_sha1 {fname} {
3309 set f [open [list | git ls-files -s $fname] r]
3310 while {[gets $f line] >= 0} {
3311 set info [lindex [split $line "\t"] 0]
3312 set stage [lindex $info 2]
3313 if {$stage eq "0" || $stage eq "2"} {
3314 close $f
3315 return [lindex $info 1]
3318 close $f
3319 return {}
3322 # Turn an absolute path into one relative to the current directory
3323 proc make_relative {f} {
3324 set elts [file split $f]
3325 set here [file split [pwd]]
3326 set ei 0
3327 set hi 0
3328 set res {}
3329 foreach d $here {
3330 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3331 lappend res ".."
3332 } else {
3333 incr ei
3335 incr hi
3337 set elts [concat $res [lrange $elts $ei end]]
3338 return [eval file join $elts]
3341 proc external_blame {parent_idx {line {}}} {
3342 global flist_menu_file gitdir
3343 global nullid nullid2
3344 global parentlist selectedline currentid
3346 if {$parent_idx > 0} {
3347 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3348 } else {
3349 set base_commit $currentid
3352 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3353 error_popup [mc "No such commit"]
3354 return
3357 set cmdline [list git gui blame]
3358 if {$line ne {} && $line > 1} {
3359 lappend cmdline "--line=$line"
3361 set f [file join [file dirname $gitdir] $flist_menu_file]
3362 # Unfortunately it seems git gui blame doesn't like
3363 # being given an absolute path...
3364 set f [make_relative $f]
3365 lappend cmdline $base_commit $f
3366 puts "cmdline={$cmdline}"
3367 if {[catch {eval exec $cmdline &} err]} {
3368 error_popup "[mc "git gui blame: command failed:"] $err"
3372 proc show_line_source {} {
3373 global cmitmode currentid parents curview blamestuff blameinst
3374 global diff_menu_line diff_menu_filebase flist_menu_file
3375 global nullid nullid2 gitdir
3377 set from_index {}
3378 if {$cmitmode eq "tree"} {
3379 set id $currentid
3380 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3381 } else {
3382 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3383 if {$h eq {}} return
3384 set pi [lindex $h 0]
3385 if {$pi == 0} {
3386 mark_ctext_line $diff_menu_line
3387 return
3389 incr pi -1
3390 if {$currentid eq $nullid} {
3391 if {$pi > 0} {
3392 # must be a merge in progress...
3393 if {[catch {
3394 # get the last line from .git/MERGE_HEAD
3395 set f [open [file join $gitdir MERGE_HEAD] r]
3396 set id [lindex [split [read $f] "\n"] end-1]
3397 close $f
3398 } err]} {
3399 error_popup [mc "Couldn't read merge head: %s" $err]
3400 return
3402 } elseif {$parents($curview,$currentid) eq $nullid2} {
3403 # need to do the blame from the index
3404 if {[catch {
3405 set from_index [index_sha1 $flist_menu_file]
3406 } err]} {
3407 error_popup [mc "Error reading index: %s" $err]
3408 return
3410 } else {
3411 set id $parents($curview,$currentid)
3413 } else {
3414 set id [lindex $parents($curview,$currentid) $pi]
3416 set line [lindex $h 1]
3418 set blameargs {}
3419 if {$from_index ne {}} {
3420 lappend blameargs | git cat-file blob $from_index
3422 lappend blameargs | git blame -p -L$line,+1
3423 if {$from_index ne {}} {
3424 lappend blameargs --contents -
3425 } else {
3426 lappend blameargs $id
3428 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3429 if {[catch {
3430 set f [open $blameargs r]
3431 } err]} {
3432 error_popup [mc "Couldn't start git blame: %s" $err]
3433 return
3435 nowbusy blaming [mc "Searching"]
3436 fconfigure $f -blocking 0
3437 set i [reg_instance $f]
3438 set blamestuff($i) {}
3439 set blameinst $i
3440 filerun $f [list read_line_source $f $i]
3443 proc stopblaming {} {
3444 global blameinst
3446 if {[info exists blameinst]} {
3447 stop_instance $blameinst
3448 unset blameinst
3449 notbusy blaming
3453 proc read_line_source {fd inst} {
3454 global blamestuff curview commfd blameinst nullid nullid2
3456 while {[gets $fd line] >= 0} {
3457 lappend blamestuff($inst) $line
3459 if {![eof $fd]} {
3460 return 1
3462 unset commfd($inst)
3463 unset blameinst
3464 notbusy blaming
3465 fconfigure $fd -blocking 1
3466 if {[catch {close $fd} err]} {
3467 error_popup [mc "Error running git blame: %s" $err]
3468 return 0
3471 set fname {}
3472 set line [split [lindex $blamestuff($inst) 0] " "]
3473 set id [lindex $line 0]
3474 set lnum [lindex $line 1]
3475 if {[string length $id] == 40 && [string is xdigit $id] &&
3476 [string is digit -strict $lnum]} {
3477 # look for "filename" line
3478 foreach l $blamestuff($inst) {
3479 if {[string match "filename *" $l]} {
3480 set fname [string range $l 9 end]
3481 break
3485 if {$fname ne {}} {
3486 # all looks good, select it
3487 if {$id eq $nullid} {
3488 # blame uses all-zeroes to mean not committed,
3489 # which would mean a change in the index
3490 set id $nullid2
3492 if {[commitinview $id $curview]} {
3493 selectline [rowofcommit $id] 1 [list $fname $lnum]
3494 } else {
3495 error_popup [mc "That line comes from commit %s, \
3496 which is not in this view" [shortids $id]]
3498 } else {
3499 puts "oops couldn't parse git blame output"
3501 return 0
3504 # delete $dir when we see eof on $f (presumably because the child has exited)
3505 proc delete_at_eof {f dir} {
3506 while {[gets $f line] >= 0} {}
3507 if {[eof $f]} {
3508 if {[catch {close $f} err]} {
3509 error_popup "[mc "External diff viewer failed:"] $err"
3511 file delete -force $dir
3512 return 0
3514 return 1
3517 # Functions for adding and removing shell-type quoting
3519 proc shellquote {str} {
3520 if {![string match "*\['\"\\ \t]*" $str]} {
3521 return $str
3523 if {![string match "*\['\"\\]*" $str]} {
3524 return "\"$str\""
3526 if {![string match "*'*" $str]} {
3527 return "'$str'"
3529 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3532 proc shellarglist {l} {
3533 set str {}
3534 foreach a $l {
3535 if {$str ne {}} {
3536 append str " "
3538 append str [shellquote $a]
3540 return $str
3543 proc shelldequote {str} {
3544 set ret {}
3545 set used -1
3546 while {1} {
3547 incr used
3548 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3549 append ret [string range $str $used end]
3550 set used [string length $str]
3551 break
3553 set first [lindex $first 0]
3554 set ch [string index $str $first]
3555 if {$first > $used} {
3556 append ret [string range $str $used [expr {$first - 1}]]
3557 set used $first
3559 if {$ch eq " " || $ch eq "\t"} break
3560 incr used
3561 if {$ch eq "'"} {
3562 set first [string first "'" $str $used]
3563 if {$first < 0} {
3564 error "unmatched single-quote"
3566 append ret [string range $str $used [expr {$first - 1}]]
3567 set used $first
3568 continue
3570 if {$ch eq "\\"} {
3571 if {$used >= [string length $str]} {
3572 error "trailing backslash"
3574 append ret [string index $str $used]
3575 continue
3577 # here ch == "\""
3578 while {1} {
3579 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3580 error "unmatched double-quote"
3582 set first [lindex $first 0]
3583 set ch [string index $str $first]
3584 if {$first > $used} {
3585 append ret [string range $str $used [expr {$first - 1}]]
3586 set used $first
3588 if {$ch eq "\""} break
3589 incr used
3590 append ret [string index $str $used]
3591 incr used
3594 return [list $used $ret]
3597 proc shellsplit {str} {
3598 set l {}
3599 while {1} {
3600 set str [string trimleft $str]
3601 if {$str eq {}} break
3602 set dq [shelldequote $str]
3603 set n [lindex $dq 0]
3604 set word [lindex $dq 1]
3605 set str [string range $str $n end]
3606 lappend l $word
3608 return $l
3611 # Code to implement multiple views
3613 proc newview {ishighlight} {
3614 global nextviewnum newviewname newishighlight
3615 global revtreeargs viewargscmd newviewopts curview
3617 set newishighlight $ishighlight
3618 set top .gitkview
3619 if {[winfo exists $top]} {
3620 raise $top
3621 return
3623 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3624 set newviewopts($nextviewnum,perm) 0
3625 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3626 decode_view_opts $nextviewnum $revtreeargs
3627 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3630 set known_view_options {
3631 {perm b . {} {mc "Remember this view"}}
3632 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3633 {all b * "--all" {mc "Use all refs"}}
3634 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3635 {lright b . "--left-right" {mc "Mark branch sides"}}
3636 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3637 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3638 {limit t10 + "--max-count=*" {mc "Max count:"}}
3639 {skip t10 . "--skip=*" {mc "Skip:"}}
3640 {first b . "--first-parent" {mc "Limit to first parent"}}
3641 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3644 proc encode_view_opts {n} {
3645 global known_view_options newviewopts
3647 set rargs [list]
3648 foreach opt $known_view_options {
3649 set patterns [lindex $opt 3]
3650 if {$patterns eq {}} continue
3651 set pattern [lindex $patterns 0]
3653 set val $newviewopts($n,[lindex $opt 0])
3655 if {[lindex $opt 1] eq "b"} {
3656 if {$val} {
3657 lappend rargs $pattern
3659 } else {
3660 set val [string trim $val]
3661 if {$val ne {}} {
3662 set pfix [string range $pattern 0 end-1]
3663 lappend rargs $pfix$val
3667 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3670 proc decode_view_opts {n view_args} {
3671 global known_view_options newviewopts
3673 foreach opt $known_view_options {
3674 if {[lindex $opt 1] eq "b"} {
3675 set val 0
3676 } else {
3677 set val {}
3679 set newviewopts($n,[lindex $opt 0]) $val
3681 set oargs [list]
3682 foreach arg $view_args {
3683 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3684 && ![info exists found(limit)]} {
3685 set newviewopts($n,limit) $cnt
3686 set found(limit) 1
3687 continue
3689 catch { unset val }
3690 foreach opt $known_view_options {
3691 set id [lindex $opt 0]
3692 if {[info exists found($id)]} continue
3693 foreach pattern [lindex $opt 3] {
3694 if {![string match $pattern $arg]} continue
3695 if {[lindex $opt 1] ne "b"} {
3696 set size [string length $pattern]
3697 set val [string range $arg [expr {$size-1}] end]
3698 } else {
3699 set val 1
3701 set newviewopts($n,$id) $val
3702 set found($id) 1
3703 break
3705 if {[info exists val]} break
3707 if {[info exists val]} continue
3708 lappend oargs $arg
3710 set newviewopts($n,args) [shellarglist $oargs]
3713 proc edit_or_newview {} {
3714 global curview
3716 if {$curview > 0} {
3717 editview
3718 } else {
3719 newview 0
3723 proc editview {} {
3724 global curview
3725 global viewname viewperm newviewname newviewopts
3726 global viewargs viewargscmd
3728 set top .gitkvedit-$curview
3729 if {[winfo exists $top]} {
3730 raise $top
3731 return
3733 set newviewname($curview) $viewname($curview)
3734 set newviewopts($curview,perm) $viewperm($curview)
3735 set newviewopts($curview,cmd) $viewargscmd($curview)
3736 decode_view_opts $curview $viewargs($curview)
3737 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3740 proc vieweditor {top n title} {
3741 global newviewname newviewopts viewfiles bgcolor
3742 global known_view_options
3744 toplevel $top
3745 wm title $top $title
3746 make_transient $top .
3748 # View name
3749 frame $top.nfr
3750 label $top.nl -text [mc "Name"]
3751 entry $top.name -width 20 -textvariable newviewname($n)
3752 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3753 pack $top.nl -in $top.nfr -side left -padx {0 30}
3754 pack $top.name -in $top.nfr -side left
3756 # View options
3757 set cframe $top.nfr
3758 set cexpand 0
3759 set cnt 0
3760 foreach opt $known_view_options {
3761 set id [lindex $opt 0]
3762 set type [lindex $opt 1]
3763 set flags [lindex $opt 2]
3764 set title [eval [lindex $opt 4]]
3765 set lxpad 0
3767 if {$flags eq "+" || $flags eq "*"} {
3768 set cframe $top.fr$cnt
3769 incr cnt
3770 frame $cframe
3771 pack $cframe -in $top -fill x -pady 3 -padx 3
3772 set cexpand [expr {$flags eq "*"}]
3773 } else {
3774 set lxpad 5
3777 if {$type eq "b"} {
3778 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3779 pack $cframe.c_$id -in $cframe -side left \
3780 -padx [list $lxpad 0] -expand $cexpand -anchor w
3781 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3782 message $cframe.l_$id -aspect 1500 -text $title
3783 entry $cframe.e_$id -width $sz -background $bgcolor \
3784 -textvariable newviewopts($n,$id)
3785 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3786 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3787 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3788 message $cframe.l_$id -aspect 1500 -text $title
3789 entry $cframe.e_$id -width $sz -background $bgcolor \
3790 -textvariable newviewopts($n,$id)
3791 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3792 pack $cframe.e_$id -in $cframe -side top -fill x
3796 # Path list
3797 message $top.l -aspect 1500 \
3798 -text [mc "Enter files and directories to include, one per line:"]
3799 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3800 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3801 if {[info exists viewfiles($n)]} {
3802 foreach f $viewfiles($n) {
3803 $top.t insert end $f
3804 $top.t insert end "\n"
3806 $top.t delete {end - 1c} end
3807 $top.t mark set insert 0.0
3809 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3810 frame $top.buts
3811 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3812 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3813 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3814 bind $top <Control-Return> [list newviewok $top $n]
3815 bind $top <F5> [list newviewok $top $n 1]
3816 bind $top <Escape> [list destroy $top]
3817 grid $top.buts.ok $top.buts.apply $top.buts.can
3818 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3819 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3820 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3821 pack $top.buts -in $top -side top -fill x
3822 focus $top.t
3825 proc doviewmenu {m first cmd op argv} {
3826 set nmenu [$m index end]
3827 for {set i $first} {$i <= $nmenu} {incr i} {
3828 if {[$m entrycget $i -command] eq $cmd} {
3829 eval $m $op $i $argv
3830 break
3835 proc allviewmenus {n op args} {
3836 # global viewhlmenu
3838 doviewmenu .bar.view 5 [list showview $n] $op $args
3839 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3842 proc newviewok {top n {apply 0}} {
3843 global nextviewnum newviewperm newviewname newishighlight
3844 global viewname viewfiles viewperm selectedview curview
3845 global viewargs viewargscmd newviewopts viewhlmenu
3847 if {[catch {
3848 set newargs [encode_view_opts $n]
3849 } err]} {
3850 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3851 return
3853 set files {}
3854 foreach f [split [$top.t get 0.0 end] "\n"] {
3855 set ft [string trim $f]
3856 if {$ft ne {}} {
3857 lappend files $ft
3860 if {![info exists viewfiles($n)]} {
3861 # creating a new view
3862 incr nextviewnum
3863 set viewname($n) $newviewname($n)
3864 set viewperm($n) $newviewopts($n,perm)
3865 set viewfiles($n) $files
3866 set viewargs($n) $newargs
3867 set viewargscmd($n) $newviewopts($n,cmd)
3868 addviewmenu $n
3869 if {!$newishighlight} {
3870 run showview $n
3871 } else {
3872 run addvhighlight $n
3874 } else {
3875 # editing an existing view
3876 set viewperm($n) $newviewopts($n,perm)
3877 if {$newviewname($n) ne $viewname($n)} {
3878 set viewname($n) $newviewname($n)
3879 doviewmenu .bar.view 5 [list showview $n] \
3880 entryconf [list -label $viewname($n)]
3881 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3882 # entryconf [list -label $viewname($n) -value $viewname($n)]
3884 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3885 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3886 set viewfiles($n) $files
3887 set viewargs($n) $newargs
3888 set viewargscmd($n) $newviewopts($n,cmd)
3889 if {$curview == $n} {
3890 run reloadcommits
3894 if {$apply} return
3895 catch {destroy $top}
3898 proc delview {} {
3899 global curview viewperm hlview selectedhlview
3901 if {$curview == 0} return
3902 if {[info exists hlview] && $hlview == $curview} {
3903 set selectedhlview [mc "None"]
3904 unset hlview
3906 allviewmenus $curview delete
3907 set viewperm($curview) 0
3908 showview 0
3911 proc addviewmenu {n} {
3912 global viewname viewhlmenu
3914 .bar.view add radiobutton -label $viewname($n) \
3915 -command [list showview $n] -variable selectedview -value $n
3916 #$viewhlmenu add radiobutton -label $viewname($n) \
3917 # -command [list addvhighlight $n] -variable selectedhlview
3920 proc showview {n} {
3921 global curview cached_commitrow ordertok
3922 global displayorder parentlist rowidlist rowisopt rowfinal
3923 global colormap rowtextx nextcolor canvxmax
3924 global numcommits viewcomplete
3925 global selectedline currentid canv canvy0
3926 global treediffs
3927 global pending_select mainheadid
3928 global commitidx
3929 global selectedview
3930 global hlview selectedhlview commitinterest
3932 if {$n == $curview} return
3933 set selid {}
3934 set ymax [lindex [$canv cget -scrollregion] 3]
3935 set span [$canv yview]
3936 set ytop [expr {[lindex $span 0] * $ymax}]
3937 set ybot [expr {[lindex $span 1] * $ymax}]
3938 set yscreen [expr {($ybot - $ytop) / 2}]
3939 if {$selectedline ne {}} {
3940 set selid $currentid
3941 set y [yc $selectedline]
3942 if {$ytop < $y && $y < $ybot} {
3943 set yscreen [expr {$y - $ytop}]
3945 } elseif {[info exists pending_select]} {
3946 set selid $pending_select
3947 unset pending_select
3949 unselectline
3950 normalline
3951 catch {unset treediffs}
3952 clear_display
3953 if {[info exists hlview] && $hlview == $n} {
3954 unset hlview
3955 set selectedhlview [mc "None"]
3957 catch {unset commitinterest}
3958 catch {unset cached_commitrow}
3959 catch {unset ordertok}
3961 set curview $n
3962 set selectedview $n
3963 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3964 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3966 run refill_reflist
3967 if {![info exists viewcomplete($n)]} {
3968 getcommits $selid
3969 return
3972 set displayorder {}
3973 set parentlist {}
3974 set rowidlist {}
3975 set rowisopt {}
3976 set rowfinal {}
3977 set numcommits $commitidx($n)
3979 catch {unset colormap}
3980 catch {unset rowtextx}
3981 set nextcolor 0
3982 set canvxmax [$canv cget -width]
3983 set curview $n
3984 set row 0
3985 setcanvscroll
3986 set yf 0
3987 set row {}
3988 if {$selid ne {} && [commitinview $selid $n]} {
3989 set row [rowofcommit $selid]
3990 # try to get the selected row in the same position on the screen
3991 set ymax [lindex [$canv cget -scrollregion] 3]
3992 set ytop [expr {[yc $row] - $yscreen}]
3993 if {$ytop < 0} {
3994 set ytop 0
3996 set yf [expr {$ytop * 1.0 / $ymax}]
3998 allcanvs yview moveto $yf
3999 drawvisible
4000 if {$row ne {}} {
4001 selectline $row 0
4002 } elseif {!$viewcomplete($n)} {
4003 reset_pending_select $selid
4004 } else {
4005 reset_pending_select {}
4007 if {[commitinview $pending_select $curview]} {
4008 selectline [rowofcommit $pending_select] 1
4009 } else {
4010 set row [first_real_row]
4011 if {$row < $numcommits} {
4012 selectline $row 0
4016 if {!$viewcomplete($n)} {
4017 if {$numcommits == 0} {
4018 show_status [mc "Reading commits..."]
4020 } elseif {$numcommits == 0} {
4021 show_status [mc "No commits selected"]
4025 # Stuff relating to the highlighting facility
4027 proc ishighlighted {id} {
4028 global vhighlights fhighlights nhighlights rhighlights
4030 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4031 return $nhighlights($id)
4033 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4034 return $vhighlights($id)
4036 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4037 return $fhighlights($id)
4039 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4040 return $rhighlights($id)
4042 return 0
4045 proc bolden {id font} {
4046 global canv linehtag currentid boldids need_redisplay
4048 # need_redisplay = 1 means the display is stale and about to be redrawn
4049 if {$need_redisplay} return
4050 lappend boldids $id
4051 $canv itemconf $linehtag($id) -font $font
4052 if {[info exists currentid] && $id eq $currentid} {
4053 $canv delete secsel
4054 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4055 -outline {{}} -tags secsel \
4056 -fill [$canv cget -selectbackground]]
4057 $canv lower $t
4061 proc bolden_name {id font} {
4062 global canv2 linentag currentid boldnameids need_redisplay
4064 if {$need_redisplay} return
4065 lappend boldnameids $id
4066 $canv2 itemconf $linentag($id) -font $font
4067 if {[info exists currentid] && $id eq $currentid} {
4068 $canv2 delete secsel
4069 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4070 -outline {{}} -tags secsel \
4071 -fill [$canv2 cget -selectbackground]]
4072 $canv2 lower $t
4076 proc unbolden {} {
4077 global boldids
4079 set stillbold {}
4080 foreach id $boldids {
4081 if {![ishighlighted $id]} {
4082 bolden $id mainfont
4083 } else {
4084 lappend stillbold $id
4087 set boldids $stillbold
4090 proc addvhighlight {n} {
4091 global hlview viewcomplete curview vhl_done commitidx
4093 if {[info exists hlview]} {
4094 delvhighlight
4096 set hlview $n
4097 if {$n != $curview && ![info exists viewcomplete($n)]} {
4098 start_rev_list $n
4100 set vhl_done $commitidx($hlview)
4101 if {$vhl_done > 0} {
4102 drawvisible
4106 proc delvhighlight {} {
4107 global hlview vhighlights
4109 if {![info exists hlview]} return
4110 unset hlview
4111 catch {unset vhighlights}
4112 unbolden
4115 proc vhighlightmore {} {
4116 global hlview vhl_done commitidx vhighlights curview
4118 set max $commitidx($hlview)
4119 set vr [visiblerows]
4120 set r0 [lindex $vr 0]
4121 set r1 [lindex $vr 1]
4122 for {set i $vhl_done} {$i < $max} {incr i} {
4123 set id [commitonrow $i $hlview]
4124 if {[commitinview $id $curview]} {
4125 set row [rowofcommit $id]
4126 if {$r0 <= $row && $row <= $r1} {
4127 if {![highlighted $row]} {
4128 bolden $id mainfontbold
4130 set vhighlights($id) 1
4134 set vhl_done $max
4135 return 0
4138 proc askvhighlight {row id} {
4139 global hlview vhighlights iddrawn
4141 if {[commitinview $id $hlview]} {
4142 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4143 bolden $id mainfontbold
4145 set vhighlights($id) 1
4146 } else {
4147 set vhighlights($id) 0
4151 proc hfiles_change {} {
4152 global highlight_files filehighlight fhighlights fh_serial
4153 global highlight_paths
4155 if {[info exists filehighlight]} {
4156 # delete previous highlights
4157 catch {close $filehighlight}
4158 unset filehighlight
4159 catch {unset fhighlights}
4160 unbolden
4161 unhighlight_filelist
4163 set highlight_paths {}
4164 after cancel do_file_hl $fh_serial
4165 incr fh_serial
4166 if {$highlight_files ne {}} {
4167 after 300 do_file_hl $fh_serial
4171 proc gdttype_change {name ix op} {
4172 global gdttype highlight_files findstring findpattern
4174 stopfinding
4175 if {$findstring ne {}} {
4176 if {$gdttype eq [mc "containing:"]} {
4177 if {$highlight_files ne {}} {
4178 set highlight_files {}
4179 hfiles_change
4181 findcom_change
4182 } else {
4183 if {$findpattern ne {}} {
4184 set findpattern {}
4185 findcom_change
4187 set highlight_files $findstring
4188 hfiles_change
4190 drawvisible
4192 # enable/disable findtype/findloc menus too
4195 proc find_change {name ix op} {
4196 global gdttype findstring highlight_files
4198 stopfinding
4199 if {$gdttype eq [mc "containing:"]} {
4200 findcom_change
4201 } else {
4202 if {$highlight_files ne $findstring} {
4203 set highlight_files $findstring
4204 hfiles_change
4207 drawvisible
4210 proc findcom_change args {
4211 global nhighlights boldnameids
4212 global findpattern findtype findstring gdttype
4214 stopfinding
4215 # delete previous highlights, if any
4216 foreach id $boldnameids {
4217 bolden_name $id mainfont
4219 set boldnameids {}
4220 catch {unset nhighlights}
4221 unbolden
4222 unmarkmatches
4223 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4224 set findpattern {}
4225 } elseif {$findtype eq [mc "Regexp"]} {
4226 set findpattern $findstring
4227 } else {
4228 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4229 $findstring]
4230 set findpattern "*$e*"
4234 proc makepatterns {l} {
4235 set ret {}
4236 foreach e $l {
4237 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4238 if {[string index $ee end] eq "/"} {
4239 lappend ret "$ee*"
4240 } else {
4241 lappend ret $ee
4242 lappend ret "$ee/*"
4245 return $ret
4248 proc do_file_hl {serial} {
4249 global highlight_files filehighlight highlight_paths gdttype fhl_list
4251 if {$gdttype eq [mc "touching paths:"]} {
4252 if {[catch {set paths [shellsplit $highlight_files]}]} return
4253 set highlight_paths [makepatterns $paths]
4254 highlight_filelist
4255 set gdtargs [concat -- $paths]
4256 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4257 set gdtargs [list "-S$highlight_files"]
4258 } else {
4259 # must be "containing:", i.e. we're searching commit info
4260 return
4262 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4263 set filehighlight [open $cmd r+]
4264 fconfigure $filehighlight -blocking 0
4265 filerun $filehighlight readfhighlight
4266 set fhl_list {}
4267 drawvisible
4268 flushhighlights
4271 proc flushhighlights {} {
4272 global filehighlight fhl_list
4274 if {[info exists filehighlight]} {
4275 lappend fhl_list {}
4276 puts $filehighlight ""
4277 flush $filehighlight
4281 proc askfilehighlight {row id} {
4282 global filehighlight fhighlights fhl_list
4284 lappend fhl_list $id
4285 set fhighlights($id) -1
4286 puts $filehighlight $id
4289 proc readfhighlight {} {
4290 global filehighlight fhighlights curview iddrawn
4291 global fhl_list find_dirn
4293 if {![info exists filehighlight]} {
4294 return 0
4296 set nr 0
4297 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4298 set line [string trim $line]
4299 set i [lsearch -exact $fhl_list $line]
4300 if {$i < 0} continue
4301 for {set j 0} {$j < $i} {incr j} {
4302 set id [lindex $fhl_list $j]
4303 set fhighlights($id) 0
4305 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4306 if {$line eq {}} continue
4307 if {![commitinview $line $curview]} continue
4308 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4309 bolden $line mainfontbold
4311 set fhighlights($line) 1
4313 if {[eof $filehighlight]} {
4314 # strange...
4315 puts "oops, git diff-tree died"
4316 catch {close $filehighlight}
4317 unset filehighlight
4318 return 0
4320 if {[info exists find_dirn]} {
4321 run findmore
4323 return 1
4326 proc doesmatch {f} {
4327 global findtype findpattern
4329 if {$findtype eq [mc "Regexp"]} {
4330 return [regexp $findpattern $f]
4331 } elseif {$findtype eq [mc "IgnCase"]} {
4332 return [string match -nocase $findpattern $f]
4333 } else {
4334 return [string match $findpattern $f]
4338 proc askfindhighlight {row id} {
4339 global nhighlights commitinfo iddrawn
4340 global findloc
4341 global markingmatches
4343 if {![info exists commitinfo($id)]} {
4344 getcommit $id
4346 set info $commitinfo($id)
4347 set isbold 0
4348 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4349 foreach f $info ty $fldtypes {
4350 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4351 [doesmatch $f]} {
4352 if {$ty eq [mc "Author"]} {
4353 set isbold 2
4354 break
4356 set isbold 1
4359 if {$isbold && [info exists iddrawn($id)]} {
4360 if {![ishighlighted $id]} {
4361 bolden $id mainfontbold
4362 if {$isbold > 1} {
4363 bolden_name $id mainfontbold
4366 if {$markingmatches} {
4367 markrowmatches $row $id
4370 set nhighlights($id) $isbold
4373 proc markrowmatches {row id} {
4374 global canv canv2 linehtag linentag commitinfo findloc
4376 set headline [lindex $commitinfo($id) 0]
4377 set author [lindex $commitinfo($id) 1]
4378 $canv delete match$row
4379 $canv2 delete match$row
4380 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4381 set m [findmatches $headline]
4382 if {$m ne {}} {
4383 markmatches $canv $row $headline $linehtag($id) $m \
4384 [$canv itemcget $linehtag($id) -font] $row
4387 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4388 set m [findmatches $author]
4389 if {$m ne {}} {
4390 markmatches $canv2 $row $author $linentag($id) $m \
4391 [$canv2 itemcget $linentag($id) -font] $row
4396 proc vrel_change {name ix op} {
4397 global highlight_related
4399 rhighlight_none
4400 if {$highlight_related ne [mc "None"]} {
4401 run drawvisible
4405 # prepare for testing whether commits are descendents or ancestors of a
4406 proc rhighlight_sel {a} {
4407 global descendent desc_todo ancestor anc_todo
4408 global highlight_related
4410 catch {unset descendent}
4411 set desc_todo [list $a]
4412 catch {unset ancestor}
4413 set anc_todo [list $a]
4414 if {$highlight_related ne [mc "None"]} {
4415 rhighlight_none
4416 run drawvisible
4420 proc rhighlight_none {} {
4421 global rhighlights
4423 catch {unset rhighlights}
4424 unbolden
4427 proc is_descendent {a} {
4428 global curview children descendent desc_todo
4430 set v $curview
4431 set la [rowofcommit $a]
4432 set todo $desc_todo
4433 set leftover {}
4434 set done 0
4435 for {set i 0} {$i < [llength $todo]} {incr i} {
4436 set do [lindex $todo $i]
4437 if {[rowofcommit $do] < $la} {
4438 lappend leftover $do
4439 continue
4441 foreach nk $children($v,$do) {
4442 if {![info exists descendent($nk)]} {
4443 set descendent($nk) 1
4444 lappend todo $nk
4445 if {$nk eq $a} {
4446 set done 1
4450 if {$done} {
4451 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4452 return
4455 set descendent($a) 0
4456 set desc_todo $leftover
4459 proc is_ancestor {a} {
4460 global curview parents ancestor anc_todo
4462 set v $curview
4463 set la [rowofcommit $a]
4464 set todo $anc_todo
4465 set leftover {}
4466 set done 0
4467 for {set i 0} {$i < [llength $todo]} {incr i} {
4468 set do [lindex $todo $i]
4469 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4470 lappend leftover $do
4471 continue
4473 foreach np $parents($v,$do) {
4474 if {![info exists ancestor($np)]} {
4475 set ancestor($np) 1
4476 lappend todo $np
4477 if {$np eq $a} {
4478 set done 1
4482 if {$done} {
4483 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4484 return
4487 set ancestor($a) 0
4488 set anc_todo $leftover
4491 proc askrelhighlight {row id} {
4492 global descendent highlight_related iddrawn rhighlights
4493 global selectedline ancestor
4495 if {$selectedline eq {}} return
4496 set isbold 0
4497 if {$highlight_related eq [mc "Descendant"] ||
4498 $highlight_related eq [mc "Not descendant"]} {
4499 if {![info exists descendent($id)]} {
4500 is_descendent $id
4502 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4503 set isbold 1
4505 } elseif {$highlight_related eq [mc "Ancestor"] ||
4506 $highlight_related eq [mc "Not ancestor"]} {
4507 if {![info exists ancestor($id)]} {
4508 is_ancestor $id
4510 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4511 set isbold 1
4514 if {[info exists iddrawn($id)]} {
4515 if {$isbold && ![ishighlighted $id]} {
4516 bolden $id mainfontbold
4519 set rhighlights($id) $isbold
4522 # Graph layout functions
4524 proc shortids {ids} {
4525 set res {}
4526 foreach id $ids {
4527 if {[llength $id] > 1} {
4528 lappend res [shortids $id]
4529 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4530 lappend res [string range $id 0 7]
4531 } else {
4532 lappend res $id
4535 return $res
4538 proc ntimes {n o} {
4539 set ret {}
4540 set o [list $o]
4541 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4542 if {($n & $mask) != 0} {
4543 set ret [concat $ret $o]
4545 set o [concat $o $o]
4547 return $ret
4550 proc ordertoken {id} {
4551 global ordertok curview varcid varcstart varctok curview parents children
4552 global nullid nullid2
4554 if {[info exists ordertok($id)]} {
4555 return $ordertok($id)
4557 set origid $id
4558 set todo {}
4559 while {1} {
4560 if {[info exists varcid($curview,$id)]} {
4561 set a $varcid($curview,$id)
4562 set p [lindex $varcstart($curview) $a]
4563 } else {
4564 set p [lindex $children($curview,$id) 0]
4566 if {[info exists ordertok($p)]} {
4567 set tok $ordertok($p)
4568 break
4570 set id [first_real_child $curview,$p]
4571 if {$id eq {}} {
4572 # it's a root
4573 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4574 break
4576 if {[llength $parents($curview,$id)] == 1} {
4577 lappend todo [list $p {}]
4578 } else {
4579 set j [lsearch -exact $parents($curview,$id) $p]
4580 if {$j < 0} {
4581 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4583 lappend todo [list $p [strrep $j]]
4586 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4587 set p [lindex $todo $i 0]
4588 append tok [lindex $todo $i 1]
4589 set ordertok($p) $tok
4591 set ordertok($origid) $tok
4592 return $tok
4595 # Work out where id should go in idlist so that order-token
4596 # values increase from left to right
4597 proc idcol {idlist id {i 0}} {
4598 set t [ordertoken $id]
4599 if {$i < 0} {
4600 set i 0
4602 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4603 if {$i > [llength $idlist]} {
4604 set i [llength $idlist]
4606 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4607 incr i
4608 } else {
4609 if {$t > [ordertoken [lindex $idlist $i]]} {
4610 while {[incr i] < [llength $idlist] &&
4611 $t >= [ordertoken [lindex $idlist $i]]} {}
4614 return $i
4617 proc initlayout {} {
4618 global rowidlist rowisopt rowfinal displayorder parentlist
4619 global numcommits canvxmax canv
4620 global nextcolor
4621 global colormap rowtextx
4623 set numcommits 0
4624 set displayorder {}
4625 set parentlist {}
4626 set nextcolor 0
4627 set rowidlist {}
4628 set rowisopt {}
4629 set rowfinal {}
4630 set canvxmax [$canv cget -width]
4631 catch {unset colormap}
4632 catch {unset rowtextx}
4633 setcanvscroll
4636 proc setcanvscroll {} {
4637 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4638 global lastscrollset lastscrollrows
4640 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4641 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4642 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4643 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4644 set lastscrollset [clock clicks -milliseconds]
4645 set lastscrollrows $numcommits
4648 proc visiblerows {} {
4649 global canv numcommits linespc
4651 set ymax [lindex [$canv cget -scrollregion] 3]
4652 if {$ymax eq {} || $ymax == 0} return
4653 set f [$canv yview]
4654 set y0 [expr {int([lindex $f 0] * $ymax)}]
4655 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4656 if {$r0 < 0} {
4657 set r0 0
4659 set y1 [expr {int([lindex $f 1] * $ymax)}]
4660 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4661 if {$r1 >= $numcommits} {
4662 set r1 [expr {$numcommits - 1}]
4664 return [list $r0 $r1]
4667 proc layoutmore {} {
4668 global commitidx viewcomplete curview
4669 global numcommits pending_select curview
4670 global lastscrollset lastscrollrows
4672 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4673 [clock clicks -milliseconds] - $lastscrollset > 500} {
4674 setcanvscroll
4676 if {[info exists pending_select] &&
4677 [commitinview $pending_select $curview]} {
4678 update
4679 selectline [rowofcommit $pending_select] 1
4681 drawvisible
4684 # With path limiting, we mightn't get the actual HEAD commit,
4685 # so ask git rev-list what is the first ancestor of HEAD that
4686 # touches a file in the path limit.
4687 proc get_viewmainhead {view} {
4688 global viewmainheadid vfilelimit viewinstances mainheadid
4690 catch {
4691 set rfd [open [concat | git rev-list -1 $mainheadid \
4692 -- $vfilelimit($view)] r]
4693 set j [reg_instance $rfd]
4694 lappend viewinstances($view) $j
4695 fconfigure $rfd -blocking 0
4696 filerun $rfd [list getviewhead $rfd $j $view]
4697 set viewmainheadid($curview) {}
4701 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4702 proc getviewhead {fd inst view} {
4703 global viewmainheadid commfd curview viewinstances showlocalchanges
4705 set id {}
4706 if {[gets $fd line] < 0} {
4707 if {![eof $fd]} {
4708 return 1
4710 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4711 set id $line
4713 set viewmainheadid($view) $id
4714 close $fd
4715 unset commfd($inst)
4716 set i [lsearch -exact $viewinstances($view) $inst]
4717 if {$i >= 0} {
4718 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4720 if {$showlocalchanges && $id ne {} && $view == $curview} {
4721 doshowlocalchanges
4723 return 0
4726 proc doshowlocalchanges {} {
4727 global curview viewmainheadid
4729 if {$viewmainheadid($curview) eq {}} return
4730 if {[commitinview $viewmainheadid($curview) $curview]} {
4731 dodiffindex
4732 } else {
4733 interestedin $viewmainheadid($curview) dodiffindex
4737 proc dohidelocalchanges {} {
4738 global nullid nullid2 lserial curview
4740 if {[commitinview $nullid $curview]} {
4741 removefakerow $nullid
4743 if {[commitinview $nullid2 $curview]} {
4744 removefakerow $nullid2
4746 incr lserial
4749 # spawn off a process to do git diff-index --cached HEAD
4750 proc dodiffindex {} {
4751 global lserial showlocalchanges vfilelimit curview
4752 global isworktree
4754 if {!$showlocalchanges || !$isworktree} return
4755 incr lserial
4756 set cmd "|git diff-index --cached HEAD"
4757 if {$vfilelimit($curview) ne {}} {
4758 set cmd [concat $cmd -- $vfilelimit($curview)]
4760 set fd [open $cmd r]
4761 fconfigure $fd -blocking 0
4762 set i [reg_instance $fd]
4763 filerun $fd [list readdiffindex $fd $lserial $i]
4766 proc readdiffindex {fd serial inst} {
4767 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4768 global vfilelimit
4770 set isdiff 1
4771 if {[gets $fd line] < 0} {
4772 if {![eof $fd]} {
4773 return 1
4775 set isdiff 0
4777 # we only need to see one line and we don't really care what it says...
4778 stop_instance $inst
4780 if {$serial != $lserial} {
4781 return 0
4784 # now see if there are any local changes not checked in to the index
4785 set cmd "|git diff-files"
4786 if {$vfilelimit($curview) ne {}} {
4787 set cmd [concat $cmd -- $vfilelimit($curview)]
4789 set fd [open $cmd r]
4790 fconfigure $fd -blocking 0
4791 set i [reg_instance $fd]
4792 filerun $fd [list readdifffiles $fd $serial $i]
4794 if {$isdiff && ![commitinview $nullid2 $curview]} {
4795 # add the line for the changes in the index to the graph
4796 set hl [mc "Local changes checked in to index but not committed"]
4797 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4798 set commitdata($nullid2) "\n $hl\n"
4799 if {[commitinview $nullid $curview]} {
4800 removefakerow $nullid
4802 insertfakerow $nullid2 $viewmainheadid($curview)
4803 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4804 if {[commitinview $nullid $curview]} {
4805 removefakerow $nullid
4807 removefakerow $nullid2
4809 return 0
4812 proc readdifffiles {fd serial inst} {
4813 global viewmainheadid nullid nullid2 curview
4814 global commitinfo commitdata lserial
4816 set isdiff 1
4817 if {[gets $fd line] < 0} {
4818 if {![eof $fd]} {
4819 return 1
4821 set isdiff 0
4823 # we only need to see one line and we don't really care what it says...
4824 stop_instance $inst
4826 if {$serial != $lserial} {
4827 return 0
4830 if {$isdiff && ![commitinview $nullid $curview]} {
4831 # add the line for the local diff to the graph
4832 set hl [mc "Local uncommitted changes, not checked in to index"]
4833 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4834 set commitdata($nullid) "\n $hl\n"
4835 if {[commitinview $nullid2 $curview]} {
4836 set p $nullid2
4837 } else {
4838 set p $viewmainheadid($curview)
4840 insertfakerow $nullid $p
4841 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4842 removefakerow $nullid
4844 return 0
4847 proc nextuse {id row} {
4848 global curview children
4850 if {[info exists children($curview,$id)]} {
4851 foreach kid $children($curview,$id) {
4852 if {![commitinview $kid $curview]} {
4853 return -1
4855 if {[rowofcommit $kid] > $row} {
4856 return [rowofcommit $kid]
4860 if {[commitinview $id $curview]} {
4861 return [rowofcommit $id]
4863 return -1
4866 proc prevuse {id row} {
4867 global curview children
4869 set ret -1
4870 if {[info exists children($curview,$id)]} {
4871 foreach kid $children($curview,$id) {
4872 if {![commitinview $kid $curview]} break
4873 if {[rowofcommit $kid] < $row} {
4874 set ret [rowofcommit $kid]
4878 return $ret
4881 proc make_idlist {row} {
4882 global displayorder parentlist uparrowlen downarrowlen mingaplen
4883 global commitidx curview children
4885 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4886 if {$r < 0} {
4887 set r 0
4889 set ra [expr {$row - $downarrowlen}]
4890 if {$ra < 0} {
4891 set ra 0
4893 set rb [expr {$row + $uparrowlen}]
4894 if {$rb > $commitidx($curview)} {
4895 set rb $commitidx($curview)
4897 make_disporder $r [expr {$rb + 1}]
4898 set ids {}
4899 for {} {$r < $ra} {incr r} {
4900 set nextid [lindex $displayorder [expr {$r + 1}]]
4901 foreach p [lindex $parentlist $r] {
4902 if {$p eq $nextid} continue
4903 set rn [nextuse $p $r]
4904 if {$rn >= $row &&
4905 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4906 lappend ids [list [ordertoken $p] $p]
4910 for {} {$r < $row} {incr r} {
4911 set nextid [lindex $displayorder [expr {$r + 1}]]
4912 foreach p [lindex $parentlist $r] {
4913 if {$p eq $nextid} continue
4914 set rn [nextuse $p $r]
4915 if {$rn < 0 || $rn >= $row} {
4916 lappend ids [list [ordertoken $p] $p]
4920 set id [lindex $displayorder $row]
4921 lappend ids [list [ordertoken $id] $id]
4922 while {$r < $rb} {
4923 foreach p [lindex $parentlist $r] {
4924 set firstkid [lindex $children($curview,$p) 0]
4925 if {[rowofcommit $firstkid] < $row} {
4926 lappend ids [list [ordertoken $p] $p]
4929 incr r
4930 set id [lindex $displayorder $r]
4931 if {$id ne {}} {
4932 set firstkid [lindex $children($curview,$id) 0]
4933 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4934 lappend ids [list [ordertoken $id] $id]
4938 set idlist {}
4939 foreach idx [lsort -unique $ids] {
4940 lappend idlist [lindex $idx 1]
4942 return $idlist
4945 proc rowsequal {a b} {
4946 while {[set i [lsearch -exact $a {}]] >= 0} {
4947 set a [lreplace $a $i $i]
4949 while {[set i [lsearch -exact $b {}]] >= 0} {
4950 set b [lreplace $b $i $i]
4952 return [expr {$a eq $b}]
4955 proc makeupline {id row rend col} {
4956 global rowidlist uparrowlen downarrowlen mingaplen
4958 for {set r $rend} {1} {set r $rstart} {
4959 set rstart [prevuse $id $r]
4960 if {$rstart < 0} return
4961 if {$rstart < $row} break
4963 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4964 set rstart [expr {$rend - $uparrowlen - 1}]
4966 for {set r $rstart} {[incr r] <= $row} {} {
4967 set idlist [lindex $rowidlist $r]
4968 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4969 set col [idcol $idlist $id $col]
4970 lset rowidlist $r [linsert $idlist $col $id]
4971 changedrow $r
4976 proc layoutrows {row endrow} {
4977 global rowidlist rowisopt rowfinal displayorder
4978 global uparrowlen downarrowlen maxwidth mingaplen
4979 global children parentlist
4980 global commitidx viewcomplete curview
4982 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4983 set idlist {}
4984 if {$row > 0} {
4985 set rm1 [expr {$row - 1}]
4986 foreach id [lindex $rowidlist $rm1] {
4987 if {$id ne {}} {
4988 lappend idlist $id
4991 set final [lindex $rowfinal $rm1]
4993 for {} {$row < $endrow} {incr row} {
4994 set rm1 [expr {$row - 1}]
4995 if {$rm1 < 0 || $idlist eq {}} {
4996 set idlist [make_idlist $row]
4997 set final 1
4998 } else {
4999 set id [lindex $displayorder $rm1]
5000 set col [lsearch -exact $idlist $id]
5001 set idlist [lreplace $idlist $col $col]
5002 foreach p [lindex $parentlist $rm1] {
5003 if {[lsearch -exact $idlist $p] < 0} {
5004 set col [idcol $idlist $p $col]
5005 set idlist [linsert $idlist $col $p]
5006 # if not the first child, we have to insert a line going up
5007 if {$id ne [lindex $children($curview,$p) 0]} {
5008 makeupline $p $rm1 $row $col
5012 set id [lindex $displayorder $row]
5013 if {$row > $downarrowlen} {
5014 set termrow [expr {$row - $downarrowlen - 1}]
5015 foreach p [lindex $parentlist $termrow] {
5016 set i [lsearch -exact $idlist $p]
5017 if {$i < 0} continue
5018 set nr [nextuse $p $termrow]
5019 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5020 set idlist [lreplace $idlist $i $i]
5024 set col [lsearch -exact $idlist $id]
5025 if {$col < 0} {
5026 set col [idcol $idlist $id]
5027 set idlist [linsert $idlist $col $id]
5028 if {$children($curview,$id) ne {}} {
5029 makeupline $id $rm1 $row $col
5032 set r [expr {$row + $uparrowlen - 1}]
5033 if {$r < $commitidx($curview)} {
5034 set x $col
5035 foreach p [lindex $parentlist $r] {
5036 if {[lsearch -exact $idlist $p] >= 0} continue
5037 set fk [lindex $children($curview,$p) 0]
5038 if {[rowofcommit $fk] < $row} {
5039 set x [idcol $idlist $p $x]
5040 set idlist [linsert $idlist $x $p]
5043 if {[incr r] < $commitidx($curview)} {
5044 set p [lindex $displayorder $r]
5045 if {[lsearch -exact $idlist $p] < 0} {
5046 set fk [lindex $children($curview,$p) 0]
5047 if {$fk ne {} && [rowofcommit $fk] < $row} {
5048 set x [idcol $idlist $p $x]
5049 set idlist [linsert $idlist $x $p]
5055 if {$final && !$viewcomplete($curview) &&
5056 $row + $uparrowlen + $mingaplen + $downarrowlen
5057 >= $commitidx($curview)} {
5058 set final 0
5060 set l [llength $rowidlist]
5061 if {$row == $l} {
5062 lappend rowidlist $idlist
5063 lappend rowisopt 0
5064 lappend rowfinal $final
5065 } elseif {$row < $l} {
5066 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5067 lset rowidlist $row $idlist
5068 changedrow $row
5070 lset rowfinal $row $final
5071 } else {
5072 set pad [ntimes [expr {$row - $l}] {}]
5073 set rowidlist [concat $rowidlist $pad]
5074 lappend rowidlist $idlist
5075 set rowfinal [concat $rowfinal $pad]
5076 lappend rowfinal $final
5077 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5080 return $row
5083 proc changedrow {row} {
5084 global displayorder iddrawn rowisopt need_redisplay
5086 set l [llength $rowisopt]
5087 if {$row < $l} {
5088 lset rowisopt $row 0
5089 if {$row + 1 < $l} {
5090 lset rowisopt [expr {$row + 1}] 0
5091 if {$row + 2 < $l} {
5092 lset rowisopt [expr {$row + 2}] 0
5096 set id [lindex $displayorder $row]
5097 if {[info exists iddrawn($id)]} {
5098 set need_redisplay 1
5102 proc insert_pad {row col npad} {
5103 global rowidlist
5105 set pad [ntimes $npad {}]
5106 set idlist [lindex $rowidlist $row]
5107 set bef [lrange $idlist 0 [expr {$col - 1}]]
5108 set aft [lrange $idlist $col end]
5109 set i [lsearch -exact $aft {}]
5110 if {$i > 0} {
5111 set aft [lreplace $aft $i $i]
5113 lset rowidlist $row [concat $bef $pad $aft]
5114 changedrow $row
5117 proc optimize_rows {row col endrow} {
5118 global rowidlist rowisopt displayorder curview children
5120 if {$row < 1} {
5121 set row 1
5123 for {} {$row < $endrow} {incr row; set col 0} {
5124 if {[lindex $rowisopt $row]} continue
5125 set haspad 0
5126 set y0 [expr {$row - 1}]
5127 set ym [expr {$row - 2}]
5128 set idlist [lindex $rowidlist $row]
5129 set previdlist [lindex $rowidlist $y0]
5130 if {$idlist eq {} || $previdlist eq {}} continue
5131 if {$ym >= 0} {
5132 set pprevidlist [lindex $rowidlist $ym]
5133 if {$pprevidlist eq {}} continue
5134 } else {
5135 set pprevidlist {}
5137 set x0 -1
5138 set xm -1
5139 for {} {$col < [llength $idlist]} {incr col} {
5140 set id [lindex $idlist $col]
5141 if {[lindex $previdlist $col] eq $id} continue
5142 if {$id eq {}} {
5143 set haspad 1
5144 continue
5146 set x0 [lsearch -exact $previdlist $id]
5147 if {$x0 < 0} continue
5148 set z [expr {$x0 - $col}]
5149 set isarrow 0
5150 set z0 {}
5151 if {$ym >= 0} {
5152 set xm [lsearch -exact $pprevidlist $id]
5153 if {$xm >= 0} {
5154 set z0 [expr {$xm - $x0}]
5157 if {$z0 eq {}} {
5158 # if row y0 is the first child of $id then it's not an arrow
5159 if {[lindex $children($curview,$id) 0] ne
5160 [lindex $displayorder $y0]} {
5161 set isarrow 1
5164 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5165 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5166 set isarrow 1
5168 # Looking at lines from this row to the previous row,
5169 # make them go straight up if they end in an arrow on
5170 # the previous row; otherwise make them go straight up
5171 # or at 45 degrees.
5172 if {$z < -1 || ($z < 0 && $isarrow)} {
5173 # Line currently goes left too much;
5174 # insert pads in the previous row, then optimize it
5175 set npad [expr {-1 - $z + $isarrow}]
5176 insert_pad $y0 $x0 $npad
5177 if {$y0 > 0} {
5178 optimize_rows $y0 $x0 $row
5180 set previdlist [lindex $rowidlist $y0]
5181 set x0 [lsearch -exact $previdlist $id]
5182 set z [expr {$x0 - $col}]
5183 if {$z0 ne {}} {
5184 set pprevidlist [lindex $rowidlist $ym]
5185 set xm [lsearch -exact $pprevidlist $id]
5186 set z0 [expr {$xm - $x0}]
5188 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5189 # Line currently goes right too much;
5190 # insert pads in this line
5191 set npad [expr {$z - 1 + $isarrow}]
5192 insert_pad $row $col $npad
5193 set idlist [lindex $rowidlist $row]
5194 incr col $npad
5195 set z [expr {$x0 - $col}]
5196 set haspad 1
5198 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5199 # this line links to its first child on row $row-2
5200 set id [lindex $displayorder $ym]
5201 set xc [lsearch -exact $pprevidlist $id]
5202 if {$xc >= 0} {
5203 set z0 [expr {$xc - $x0}]
5206 # avoid lines jigging left then immediately right
5207 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5208 insert_pad $y0 $x0 1
5209 incr x0
5210 optimize_rows $y0 $x0 $row
5211 set previdlist [lindex $rowidlist $y0]
5214 if {!$haspad} {
5215 # Find the first column that doesn't have a line going right
5216 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5217 set id [lindex $idlist $col]
5218 if {$id eq {}} break
5219 set x0 [lsearch -exact $previdlist $id]
5220 if {$x0 < 0} {
5221 # check if this is the link to the first child
5222 set kid [lindex $displayorder $y0]
5223 if {[lindex $children($curview,$id) 0] eq $kid} {
5224 # it is, work out offset to child
5225 set x0 [lsearch -exact $previdlist $kid]
5228 if {$x0 <= $col} break
5230 # Insert a pad at that column as long as it has a line and
5231 # isn't the last column
5232 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5233 set idlist [linsert $idlist $col {}]
5234 lset rowidlist $row $idlist
5235 changedrow $row
5241 proc xc {row col} {
5242 global canvx0 linespc
5243 return [expr {$canvx0 + $col * $linespc}]
5246 proc yc {row} {
5247 global canvy0 linespc
5248 return [expr {$canvy0 + $row * $linespc}]
5251 proc linewidth {id} {
5252 global thickerline lthickness
5254 set wid $lthickness
5255 if {[info exists thickerline] && $id eq $thickerline} {
5256 set wid [expr {2 * $lthickness}]
5258 return $wid
5261 proc rowranges {id} {
5262 global curview children uparrowlen downarrowlen
5263 global rowidlist
5265 set kids $children($curview,$id)
5266 if {$kids eq {}} {
5267 return {}
5269 set ret {}
5270 lappend kids $id
5271 foreach child $kids {
5272 if {![commitinview $child $curview]} break
5273 set row [rowofcommit $child]
5274 if {![info exists prev]} {
5275 lappend ret [expr {$row + 1}]
5276 } else {
5277 if {$row <= $prevrow} {
5278 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5280 # see if the line extends the whole way from prevrow to row
5281 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5282 [lsearch -exact [lindex $rowidlist \
5283 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5284 # it doesn't, see where it ends
5285 set r [expr {$prevrow + $downarrowlen}]
5286 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5287 while {[incr r -1] > $prevrow &&
5288 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5289 } else {
5290 while {[incr r] <= $row &&
5291 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5292 incr r -1
5294 lappend ret $r
5295 # see where it starts up again
5296 set r [expr {$row - $uparrowlen}]
5297 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5298 while {[incr r] < $row &&
5299 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5300 } else {
5301 while {[incr r -1] >= $prevrow &&
5302 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5303 incr r
5305 lappend ret $r
5308 if {$child eq $id} {
5309 lappend ret $row
5311 set prev $child
5312 set prevrow $row
5314 return $ret
5317 proc drawlineseg {id row endrow arrowlow} {
5318 global rowidlist displayorder iddrawn linesegs
5319 global canv colormap linespc curview maxlinelen parentlist
5321 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5322 set le [expr {$row + 1}]
5323 set arrowhigh 1
5324 while {1} {
5325 set c [lsearch -exact [lindex $rowidlist $le] $id]
5326 if {$c < 0} {
5327 incr le -1
5328 break
5330 lappend cols $c
5331 set x [lindex $displayorder $le]
5332 if {$x eq $id} {
5333 set arrowhigh 0
5334 break
5336 if {[info exists iddrawn($x)] || $le == $endrow} {
5337 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5338 if {$c >= 0} {
5339 lappend cols $c
5340 set arrowhigh 0
5342 break
5344 incr le
5346 if {$le <= $row} {
5347 return $row
5350 set lines {}
5351 set i 0
5352 set joinhigh 0
5353 if {[info exists linesegs($id)]} {
5354 set lines $linesegs($id)
5355 foreach li $lines {
5356 set r0 [lindex $li 0]
5357 if {$r0 > $row} {
5358 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5359 set joinhigh 1
5361 break
5363 incr i
5366 set joinlow 0
5367 if {$i > 0} {
5368 set li [lindex $lines [expr {$i-1}]]
5369 set r1 [lindex $li 1]
5370 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5371 set joinlow 1
5375 set x [lindex $cols [expr {$le - $row}]]
5376 set xp [lindex $cols [expr {$le - 1 - $row}]]
5377 set dir [expr {$xp - $x}]
5378 if {$joinhigh} {
5379 set ith [lindex $lines $i 2]
5380 set coords [$canv coords $ith]
5381 set ah [$canv itemcget $ith -arrow]
5382 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5383 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5384 if {$x2 ne {} && $x - $x2 == $dir} {
5385 set coords [lrange $coords 0 end-2]
5387 } else {
5388 set coords [list [xc $le $x] [yc $le]]
5390 if {$joinlow} {
5391 set itl [lindex $lines [expr {$i-1}] 2]
5392 set al [$canv itemcget $itl -arrow]
5393 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5394 } elseif {$arrowlow} {
5395 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5396 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5397 set arrowlow 0
5400 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5401 for {set y $le} {[incr y -1] > $row} {} {
5402 set x $xp
5403 set xp [lindex $cols [expr {$y - 1 - $row}]]
5404 set ndir [expr {$xp - $x}]
5405 if {$dir != $ndir || $xp < 0} {
5406 lappend coords [xc $y $x] [yc $y]
5408 set dir $ndir
5410 if {!$joinlow} {
5411 if {$xp < 0} {
5412 # join parent line to first child
5413 set ch [lindex $displayorder $row]
5414 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5415 if {$xc < 0} {
5416 puts "oops: drawlineseg: child $ch not on row $row"
5417 } elseif {$xc != $x} {
5418 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5419 set d [expr {int(0.5 * $linespc)}]
5420 set x1 [xc $row $x]
5421 if {$xc < $x} {
5422 set x2 [expr {$x1 - $d}]
5423 } else {
5424 set x2 [expr {$x1 + $d}]
5426 set y2 [yc $row]
5427 set y1 [expr {$y2 + $d}]
5428 lappend coords $x1 $y1 $x2 $y2
5429 } elseif {$xc < $x - 1} {
5430 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5431 } elseif {$xc > $x + 1} {
5432 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5434 set x $xc
5436 lappend coords [xc $row $x] [yc $row]
5437 } else {
5438 set xn [xc $row $xp]
5439 set yn [yc $row]
5440 lappend coords $xn $yn
5442 if {!$joinhigh} {
5443 assigncolor $id
5444 set t [$canv create line $coords -width [linewidth $id] \
5445 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5446 $canv lower $t
5447 bindline $t $id
5448 set lines [linsert $lines $i [list $row $le $t]]
5449 } else {
5450 $canv coords $ith $coords
5451 if {$arrow ne $ah} {
5452 $canv itemconf $ith -arrow $arrow
5454 lset lines $i 0 $row
5456 } else {
5457 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5458 set ndir [expr {$xo - $xp}]
5459 set clow [$canv coords $itl]
5460 if {$dir == $ndir} {
5461 set clow [lrange $clow 2 end]
5463 set coords [concat $coords $clow]
5464 if {!$joinhigh} {
5465 lset lines [expr {$i-1}] 1 $le
5466 } else {
5467 # coalesce two pieces
5468 $canv delete $ith
5469 set b [lindex $lines [expr {$i-1}] 0]
5470 set e [lindex $lines $i 1]
5471 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5473 $canv coords $itl $coords
5474 if {$arrow ne $al} {
5475 $canv itemconf $itl -arrow $arrow
5479 set linesegs($id) $lines
5480 return $le
5483 proc drawparentlinks {id row} {
5484 global rowidlist canv colormap curview parentlist
5485 global idpos linespc
5487 set rowids [lindex $rowidlist $row]
5488 set col [lsearch -exact $rowids $id]
5489 if {$col < 0} return
5490 set olds [lindex $parentlist $row]
5491 set row2 [expr {$row + 1}]
5492 set x [xc $row $col]
5493 set y [yc $row]
5494 set y2 [yc $row2]
5495 set d [expr {int(0.5 * $linespc)}]
5496 set ymid [expr {$y + $d}]
5497 set ids [lindex $rowidlist $row2]
5498 # rmx = right-most X coord used
5499 set rmx 0
5500 foreach p $olds {
5501 set i [lsearch -exact $ids $p]
5502 if {$i < 0} {
5503 puts "oops, parent $p of $id not in list"
5504 continue
5506 set x2 [xc $row2 $i]
5507 if {$x2 > $rmx} {
5508 set rmx $x2
5510 set j [lsearch -exact $rowids $p]
5511 if {$j < 0} {
5512 # drawlineseg will do this one for us
5513 continue
5515 assigncolor $p
5516 # should handle duplicated parents here...
5517 set coords [list $x $y]
5518 if {$i != $col} {
5519 # if attaching to a vertical segment, draw a smaller
5520 # slant for visual distinctness
5521 if {$i == $j} {
5522 if {$i < $col} {
5523 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5524 } else {
5525 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5527 } elseif {$i < $col && $i < $j} {
5528 # segment slants towards us already
5529 lappend coords [xc $row $j] $y
5530 } else {
5531 if {$i < $col - 1} {
5532 lappend coords [expr {$x2 + $linespc}] $y
5533 } elseif {$i > $col + 1} {
5534 lappend coords [expr {$x2 - $linespc}] $y
5536 lappend coords $x2 $y2
5538 } else {
5539 lappend coords $x2 $y2
5541 set t [$canv create line $coords -width [linewidth $p] \
5542 -fill $colormap($p) -tags lines.$p]
5543 $canv lower $t
5544 bindline $t $p
5546 if {$rmx > [lindex $idpos($id) 1]} {
5547 lset idpos($id) 1 $rmx
5548 redrawtags $id
5552 proc drawlines {id} {
5553 global canv
5555 $canv itemconf lines.$id -width [linewidth $id]
5558 proc drawcmittext {id row col} {
5559 global linespc canv canv2 canv3 fgcolor curview
5560 global cmitlisted commitinfo rowidlist parentlist
5561 global rowtextx idpos idtags idheads idotherrefs
5562 global linehtag linentag linedtag selectedline
5563 global canvxmax boldids boldnameids fgcolor
5564 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5566 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5567 set listed $cmitlisted($curview,$id)
5568 if {$id eq $nullid} {
5569 set ofill red
5570 } elseif {$id eq $nullid2} {
5571 set ofill green
5572 } elseif {$id eq $mainheadid} {
5573 set ofill yellow
5574 } else {
5575 set ofill [lindex $circlecolors $listed]
5577 set x [xc $row $col]
5578 set y [yc $row]
5579 set orad [expr {$linespc / 3}]
5580 if {$listed <= 2} {
5581 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5582 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5583 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5584 } elseif {$listed == 3} {
5585 # triangle pointing left for left-side commits
5586 set t [$canv create polygon \
5587 [expr {$x - $orad}] $y \
5588 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5589 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5590 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5591 } else {
5592 # triangle pointing right for right-side commits
5593 set t [$canv create polygon \
5594 [expr {$x + $orad - 1}] $y \
5595 [expr {$x - $orad}] [expr {$y - $orad}] \
5596 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5597 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5599 set circleitem($row) $t
5600 $canv raise $t
5601 $canv bind $t <1> {selcanvline {} %x %y}
5602 set rmx [llength [lindex $rowidlist $row]]
5603 set olds [lindex $parentlist $row]
5604 if {$olds ne {}} {
5605 set nextids [lindex $rowidlist [expr {$row + 1}]]
5606 foreach p $olds {
5607 set i [lsearch -exact $nextids $p]
5608 if {$i > $rmx} {
5609 set rmx $i
5613 set xt [xc $row $rmx]
5614 set rowtextx($row) $xt
5615 set idpos($id) [list $x $xt $y]
5616 if {[info exists idtags($id)] || [info exists idheads($id)]
5617 || [info exists idotherrefs($id)]} {
5618 set xt [drawtags $id $x $xt $y]
5620 set headline [lindex $commitinfo($id) 0]
5621 set name [lindex $commitinfo($id) 1]
5622 set date [lindex $commitinfo($id) 2]
5623 set date [formatdate $date]
5624 set font mainfont
5625 set nfont mainfont
5626 set isbold [ishighlighted $id]
5627 if {$isbold > 0} {
5628 lappend boldids $id
5629 set font mainfontbold
5630 if {$isbold > 1} {
5631 lappend boldnameids $id
5632 set nfont mainfontbold
5635 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5636 -text $headline -font $font -tags text]
5637 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5638 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5639 -text $name -font $nfont -tags text]
5640 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5641 -text $date -font mainfont -tags text]
5642 if {$selectedline == $row} {
5643 make_secsel $id
5645 set xr [expr {$xt + [font measure $font $headline]}]
5646 if {$xr > $canvxmax} {
5647 set canvxmax $xr
5648 setcanvscroll
5652 proc drawcmitrow {row} {
5653 global displayorder rowidlist nrows_drawn
5654 global iddrawn markingmatches
5655 global commitinfo numcommits
5656 global filehighlight fhighlights findpattern nhighlights
5657 global hlview vhighlights
5658 global highlight_related rhighlights
5660 if {$row >= $numcommits} return
5662 set id [lindex $displayorder $row]
5663 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5664 askvhighlight $row $id
5666 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5667 askfilehighlight $row $id
5669 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5670 askfindhighlight $row $id
5672 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5673 askrelhighlight $row $id
5675 if {![info exists iddrawn($id)]} {
5676 set col [lsearch -exact [lindex $rowidlist $row] $id]
5677 if {$col < 0} {
5678 puts "oops, row $row id $id not in list"
5679 return
5681 if {![info exists commitinfo($id)]} {
5682 getcommit $id
5684 assigncolor $id
5685 drawcmittext $id $row $col
5686 set iddrawn($id) 1
5687 incr nrows_drawn
5689 if {$markingmatches} {
5690 markrowmatches $row $id
5694 proc drawcommits {row {endrow {}}} {
5695 global numcommits iddrawn displayorder curview need_redisplay
5696 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5698 if {$row < 0} {
5699 set row 0
5701 if {$endrow eq {}} {
5702 set endrow $row
5704 if {$endrow >= $numcommits} {
5705 set endrow [expr {$numcommits - 1}]
5708 set rl1 [expr {$row - $downarrowlen - 3}]
5709 if {$rl1 < 0} {
5710 set rl1 0
5712 set ro1 [expr {$row - 3}]
5713 if {$ro1 < 0} {
5714 set ro1 0
5716 set r2 [expr {$endrow + $uparrowlen + 3}]
5717 if {$r2 > $numcommits} {
5718 set r2 $numcommits
5720 for {set r $rl1} {$r < $r2} {incr r} {
5721 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5722 if {$rl1 < $r} {
5723 layoutrows $rl1 $r
5725 set rl1 [expr {$r + 1}]
5728 if {$rl1 < $r} {
5729 layoutrows $rl1 $r
5731 optimize_rows $ro1 0 $r2
5732 if {$need_redisplay || $nrows_drawn > 2000} {
5733 clear_display
5734 drawvisible
5737 # make the lines join to already-drawn rows either side
5738 set r [expr {$row - 1}]
5739 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5740 set r $row
5742 set er [expr {$endrow + 1}]
5743 if {$er >= $numcommits ||
5744 ![info exists iddrawn([lindex $displayorder $er])]} {
5745 set er $endrow
5747 for {} {$r <= $er} {incr r} {
5748 set id [lindex $displayorder $r]
5749 set wasdrawn [info exists iddrawn($id)]
5750 drawcmitrow $r
5751 if {$r == $er} break
5752 set nextid [lindex $displayorder [expr {$r + 1}]]
5753 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5754 drawparentlinks $id $r
5756 set rowids [lindex $rowidlist $r]
5757 foreach lid $rowids {
5758 if {$lid eq {}} continue
5759 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5760 if {$lid eq $id} {
5761 # see if this is the first child of any of its parents
5762 foreach p [lindex $parentlist $r] {
5763 if {[lsearch -exact $rowids $p] < 0} {
5764 # make this line extend up to the child
5765 set lineend($p) [drawlineseg $p $r $er 0]
5768 } else {
5769 set lineend($lid) [drawlineseg $lid $r $er 1]
5775 proc undolayout {row} {
5776 global uparrowlen mingaplen downarrowlen
5777 global rowidlist rowisopt rowfinal need_redisplay
5779 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5780 if {$r < 0} {
5781 set r 0
5783 if {[llength $rowidlist] > $r} {
5784 incr r -1
5785 set rowidlist [lrange $rowidlist 0 $r]
5786 set rowfinal [lrange $rowfinal 0 $r]
5787 set rowisopt [lrange $rowisopt 0 $r]
5788 set need_redisplay 1
5789 run drawvisible
5793 proc drawvisible {} {
5794 global canv linespc curview vrowmod selectedline targetrow targetid
5795 global need_redisplay cscroll numcommits
5797 set fs [$canv yview]
5798 set ymax [lindex [$canv cget -scrollregion] 3]
5799 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5800 set f0 [lindex $fs 0]
5801 set f1 [lindex $fs 1]
5802 set y0 [expr {int($f0 * $ymax)}]
5803 set y1 [expr {int($f1 * $ymax)}]
5805 if {[info exists targetid]} {
5806 if {[commitinview $targetid $curview]} {
5807 set r [rowofcommit $targetid]
5808 if {$r != $targetrow} {
5809 # Fix up the scrollregion and change the scrolling position
5810 # now that our target row has moved.
5811 set diff [expr {($r - $targetrow) * $linespc}]
5812 set targetrow $r
5813 setcanvscroll
5814 set ymax [lindex [$canv cget -scrollregion] 3]
5815 incr y0 $diff
5816 incr y1 $diff
5817 set f0 [expr {$y0 / $ymax}]
5818 set f1 [expr {$y1 / $ymax}]
5819 allcanvs yview moveto $f0
5820 $cscroll set $f0 $f1
5821 set need_redisplay 1
5823 } else {
5824 unset targetid
5828 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5829 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5830 if {$endrow >= $vrowmod($curview)} {
5831 update_arcrows $curview
5833 if {$selectedline ne {} &&
5834 $row <= $selectedline && $selectedline <= $endrow} {
5835 set targetrow $selectedline
5836 } elseif {[info exists targetid]} {
5837 set targetrow [expr {int(($row + $endrow) / 2)}]
5839 if {[info exists targetrow]} {
5840 if {$targetrow >= $numcommits} {
5841 set targetrow [expr {$numcommits - 1}]
5843 set targetid [commitonrow $targetrow]
5845 drawcommits $row $endrow
5848 proc clear_display {} {
5849 global iddrawn linesegs need_redisplay nrows_drawn
5850 global vhighlights fhighlights nhighlights rhighlights
5851 global linehtag linentag linedtag boldids boldnameids
5853 allcanvs delete all
5854 catch {unset iddrawn}
5855 catch {unset linesegs}
5856 catch {unset linehtag}
5857 catch {unset linentag}
5858 catch {unset linedtag}
5859 set boldids {}
5860 set boldnameids {}
5861 catch {unset vhighlights}
5862 catch {unset fhighlights}
5863 catch {unset nhighlights}
5864 catch {unset rhighlights}
5865 set need_redisplay 0
5866 set nrows_drawn 0
5869 proc findcrossings {id} {
5870 global rowidlist parentlist numcommits displayorder
5872 set cross {}
5873 set ccross {}
5874 foreach {s e} [rowranges $id] {
5875 if {$e >= $numcommits} {
5876 set e [expr {$numcommits - 1}]
5878 if {$e <= $s} continue
5879 for {set row $e} {[incr row -1] >= $s} {} {
5880 set x [lsearch -exact [lindex $rowidlist $row] $id]
5881 if {$x < 0} break
5882 set olds [lindex $parentlist $row]
5883 set kid [lindex $displayorder $row]
5884 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5885 if {$kidx < 0} continue
5886 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5887 foreach p $olds {
5888 set px [lsearch -exact $nextrow $p]
5889 if {$px < 0} continue
5890 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5891 if {[lsearch -exact $ccross $p] >= 0} continue
5892 if {$x == $px + ($kidx < $px? -1: 1)} {
5893 lappend ccross $p
5894 } elseif {[lsearch -exact $cross $p] < 0} {
5895 lappend cross $p
5901 return [concat $ccross {{}} $cross]
5904 proc assigncolor {id} {
5905 global colormap colors nextcolor
5906 global parents children children curview
5908 if {[info exists colormap($id)]} return
5909 set ncolors [llength $colors]
5910 if {[info exists children($curview,$id)]} {
5911 set kids $children($curview,$id)
5912 } else {
5913 set kids {}
5915 if {[llength $kids] == 1} {
5916 set child [lindex $kids 0]
5917 if {[info exists colormap($child)]
5918 && [llength $parents($curview,$child)] == 1} {
5919 set colormap($id) $colormap($child)
5920 return
5923 set badcolors {}
5924 set origbad {}
5925 foreach x [findcrossings $id] {
5926 if {$x eq {}} {
5927 # delimiter between corner crossings and other crossings
5928 if {[llength $badcolors] >= $ncolors - 1} break
5929 set origbad $badcolors
5931 if {[info exists colormap($x)]
5932 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5933 lappend badcolors $colormap($x)
5936 if {[llength $badcolors] >= $ncolors} {
5937 set badcolors $origbad
5939 set origbad $badcolors
5940 if {[llength $badcolors] < $ncolors - 1} {
5941 foreach child $kids {
5942 if {[info exists colormap($child)]
5943 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5944 lappend badcolors $colormap($child)
5946 foreach p $parents($curview,$child) {
5947 if {[info exists colormap($p)]
5948 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5949 lappend badcolors $colormap($p)
5953 if {[llength $badcolors] >= $ncolors} {
5954 set badcolors $origbad
5957 for {set i 0} {$i <= $ncolors} {incr i} {
5958 set c [lindex $colors $nextcolor]
5959 if {[incr nextcolor] >= $ncolors} {
5960 set nextcolor 0
5962 if {[lsearch -exact $badcolors $c]} break
5964 set colormap($id) $c
5967 proc bindline {t id} {
5968 global canv
5970 $canv bind $t <Enter> "lineenter %x %y $id"
5971 $canv bind $t <Motion> "linemotion %x %y $id"
5972 $canv bind $t <Leave> "lineleave $id"
5973 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5976 proc drawtags {id x xt y1} {
5977 global idtags idheads idotherrefs mainhead
5978 global linespc lthickness
5979 global canv rowtextx curview fgcolor bgcolor ctxbut
5981 set marks {}
5982 set ntags 0
5983 set nheads 0
5984 if {[info exists idtags($id)]} {
5985 set marks $idtags($id)
5986 set ntags [llength $marks]
5988 if {[info exists idheads($id)]} {
5989 set marks [concat $marks $idheads($id)]
5990 set nheads [llength $idheads($id)]
5992 if {[info exists idotherrefs($id)]} {
5993 set marks [concat $marks $idotherrefs($id)]
5995 if {$marks eq {}} {
5996 return $xt
5999 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6000 set yt [expr {$y1 - 0.5 * $linespc}]
6001 set yb [expr {$yt + $linespc - 1}]
6002 set xvals {}
6003 set wvals {}
6004 set i -1
6005 foreach tag $marks {
6006 incr i
6007 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6008 set wid [font measure mainfontbold $tag]
6009 } else {
6010 set wid [font measure mainfont $tag]
6012 lappend xvals $xt
6013 lappend wvals $wid
6014 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6016 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6017 -width $lthickness -fill black -tags tag.$id]
6018 $canv lower $t
6019 foreach tag $marks x $xvals wid $wvals {
6020 set xl [expr {$x + $delta}]
6021 set xr [expr {$x + $delta + $wid + $lthickness}]
6022 set font mainfont
6023 if {[incr ntags -1] >= 0} {
6024 # draw a tag
6025 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6026 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6027 -width 1 -outline black -fill yellow -tags tag.$id]
6028 $canv bind $t <1> [list showtag $tag 1]
6029 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6030 } else {
6031 # draw a head or other ref
6032 if {[incr nheads -1] >= 0} {
6033 set col green
6034 if {$tag eq $mainhead} {
6035 set font mainfontbold
6037 } else {
6038 set col "#ddddff"
6040 set xl [expr {$xl - $delta/2}]
6041 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6042 -width 1 -outline black -fill $col -tags tag.$id
6043 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6044 set rwid [font measure mainfont $remoteprefix]
6045 set xi [expr {$x + 1}]
6046 set yti [expr {$yt + 1}]
6047 set xri [expr {$x + $rwid}]
6048 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6049 -width 0 -fill "#ffddaa" -tags tag.$id
6052 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6053 -font $font -tags [list tag.$id text]]
6054 if {$ntags >= 0} {
6055 $canv bind $t <1> [list showtag $tag 1]
6056 } elseif {$nheads >= 0} {
6057 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6060 return $xt
6063 proc xcoord {i level ln} {
6064 global canvx0 xspc1 xspc2
6066 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6067 if {$i > 0 && $i == $level} {
6068 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6069 } elseif {$i > $level} {
6070 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6072 return $x
6075 proc show_status {msg} {
6076 global canv fgcolor
6078 clear_display
6079 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6080 -tags text -fill $fgcolor
6083 # Don't change the text pane cursor if it is currently the hand cursor,
6084 # showing that we are over a sha1 ID link.
6085 proc settextcursor {c} {
6086 global ctext curtextcursor
6088 if {[$ctext cget -cursor] == $curtextcursor} {
6089 $ctext config -cursor $c
6091 set curtextcursor $c
6094 proc nowbusy {what {name {}}} {
6095 global isbusy busyname statusw
6097 if {[array names isbusy] eq {}} {
6098 . config -cursor watch
6099 settextcursor watch
6101 set isbusy($what) 1
6102 set busyname($what) $name
6103 if {$name ne {}} {
6104 $statusw conf -text $name
6108 proc notbusy {what} {
6109 global isbusy maincursor textcursor busyname statusw
6111 catch {
6112 unset isbusy($what)
6113 if {$busyname($what) ne {} &&
6114 [$statusw cget -text] eq $busyname($what)} {
6115 $statusw conf -text {}
6118 if {[array names isbusy] eq {}} {
6119 . config -cursor $maincursor
6120 settextcursor $textcursor
6124 proc findmatches {f} {
6125 global findtype findstring
6126 if {$findtype == [mc "Regexp"]} {
6127 set matches [regexp -indices -all -inline $findstring $f]
6128 } else {
6129 set fs $findstring
6130 if {$findtype == [mc "IgnCase"]} {
6131 set f [string tolower $f]
6132 set fs [string tolower $fs]
6134 set matches {}
6135 set i 0
6136 set l [string length $fs]
6137 while {[set j [string first $fs $f $i]] >= 0} {
6138 lappend matches [list $j [expr {$j+$l-1}]]
6139 set i [expr {$j + $l}]
6142 return $matches
6145 proc dofind {{dirn 1} {wrap 1}} {
6146 global findstring findstartline findcurline selectedline numcommits
6147 global gdttype filehighlight fh_serial find_dirn findallowwrap
6149 if {[info exists find_dirn]} {
6150 if {$find_dirn == $dirn} return
6151 stopfinding
6153 focus .
6154 if {$findstring eq {} || $numcommits == 0} return
6155 if {$selectedline eq {}} {
6156 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6157 } else {
6158 set findstartline $selectedline
6160 set findcurline $findstartline
6161 nowbusy finding [mc "Searching"]
6162 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6163 after cancel do_file_hl $fh_serial
6164 do_file_hl $fh_serial
6166 set find_dirn $dirn
6167 set findallowwrap $wrap
6168 run findmore
6171 proc stopfinding {} {
6172 global find_dirn findcurline fprogcoord
6174 if {[info exists find_dirn]} {
6175 unset find_dirn
6176 unset findcurline
6177 notbusy finding
6178 set fprogcoord 0
6179 adjustprogress
6181 stopblaming
6184 proc findmore {} {
6185 global commitdata commitinfo numcommits findpattern findloc
6186 global findstartline findcurline findallowwrap
6187 global find_dirn gdttype fhighlights fprogcoord
6188 global curview varcorder vrownum varccommits vrowmod
6190 if {![info exists find_dirn]} {
6191 return 0
6193 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6194 set l $findcurline
6195 set moretodo 0
6196 if {$find_dirn > 0} {
6197 incr l
6198 if {$l >= $numcommits} {
6199 set l 0
6201 if {$l <= $findstartline} {
6202 set lim [expr {$findstartline + 1}]
6203 } else {
6204 set lim $numcommits
6205 set moretodo $findallowwrap
6207 } else {
6208 if {$l == 0} {
6209 set l $numcommits
6211 incr l -1
6212 if {$l >= $findstartline} {
6213 set lim [expr {$findstartline - 1}]
6214 } else {
6215 set lim -1
6216 set moretodo $findallowwrap
6219 set n [expr {($lim - $l) * $find_dirn}]
6220 if {$n > 500} {
6221 set n 500
6222 set moretodo 1
6224 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6225 update_arcrows $curview
6227 set found 0
6228 set domore 1
6229 set ai [bsearch $vrownum($curview) $l]
6230 set a [lindex $varcorder($curview) $ai]
6231 set arow [lindex $vrownum($curview) $ai]
6232 set ids [lindex $varccommits($curview,$a)]
6233 set arowend [expr {$arow + [llength $ids]}]
6234 if {$gdttype eq [mc "containing:"]} {
6235 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6236 if {$l < $arow || $l >= $arowend} {
6237 incr ai $find_dirn
6238 set a [lindex $varcorder($curview) $ai]
6239 set arow [lindex $vrownum($curview) $ai]
6240 set ids [lindex $varccommits($curview,$a)]
6241 set arowend [expr {$arow + [llength $ids]}]
6243 set id [lindex $ids [expr {$l - $arow}]]
6244 # shouldn't happen unless git log doesn't give all the commits...
6245 if {![info exists commitdata($id)] ||
6246 ![doesmatch $commitdata($id)]} {
6247 continue
6249 if {![info exists commitinfo($id)]} {
6250 getcommit $id
6252 set info $commitinfo($id)
6253 foreach f $info ty $fldtypes {
6254 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6255 [doesmatch $f]} {
6256 set found 1
6257 break
6260 if {$found} break
6262 } else {
6263 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6264 if {$l < $arow || $l >= $arowend} {
6265 incr ai $find_dirn
6266 set a [lindex $varcorder($curview) $ai]
6267 set arow [lindex $vrownum($curview) $ai]
6268 set ids [lindex $varccommits($curview,$a)]
6269 set arowend [expr {$arow + [llength $ids]}]
6271 set id [lindex $ids [expr {$l - $arow}]]
6272 if {![info exists fhighlights($id)]} {
6273 # this sets fhighlights($id) to -1
6274 askfilehighlight $l $id
6276 if {$fhighlights($id) > 0} {
6277 set found $domore
6278 break
6280 if {$fhighlights($id) < 0} {
6281 if {$domore} {
6282 set domore 0
6283 set findcurline [expr {$l - $find_dirn}]
6288 if {$found || ($domore && !$moretodo)} {
6289 unset findcurline
6290 unset find_dirn
6291 notbusy finding
6292 set fprogcoord 0
6293 adjustprogress
6294 if {$found} {
6295 findselectline $l
6296 } else {
6297 bell
6299 return 0
6301 if {!$domore} {
6302 flushhighlights
6303 } else {
6304 set findcurline [expr {$l - $find_dirn}]
6306 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6307 if {$n < 0} {
6308 incr n $numcommits
6310 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6311 adjustprogress
6312 return $domore
6315 proc findselectline {l} {
6316 global findloc commentend ctext findcurline markingmatches gdttype
6318 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6319 set findcurline $l
6320 selectline $l 1
6321 if {$markingmatches &&
6322 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6323 # highlight the matches in the comments
6324 set f [$ctext get 1.0 $commentend]
6325 set matches [findmatches $f]
6326 foreach match $matches {
6327 set start [lindex $match 0]
6328 set end [expr {[lindex $match 1] + 1}]
6329 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6332 drawvisible
6335 # mark the bits of a headline or author that match a find string
6336 proc markmatches {canv l str tag matches font row} {
6337 global selectedline
6339 set bbox [$canv bbox $tag]
6340 set x0 [lindex $bbox 0]
6341 set y0 [lindex $bbox 1]
6342 set y1 [lindex $bbox 3]
6343 foreach match $matches {
6344 set start [lindex $match 0]
6345 set end [lindex $match 1]
6346 if {$start > $end} continue
6347 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6348 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6349 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6350 [expr {$x0+$xlen+2}] $y1 \
6351 -outline {} -tags [list match$l matches] -fill yellow]
6352 $canv lower $t
6353 if {$row == $selectedline} {
6354 $canv raise $t secsel
6359 proc unmarkmatches {} {
6360 global markingmatches
6362 allcanvs delete matches
6363 set markingmatches 0
6364 stopfinding
6367 proc selcanvline {w x y} {
6368 global canv canvy0 ctext linespc
6369 global rowtextx
6370 set ymax [lindex [$canv cget -scrollregion] 3]
6371 if {$ymax == {}} return
6372 set yfrac [lindex [$canv yview] 0]
6373 set y [expr {$y + $yfrac * $ymax}]
6374 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6375 if {$l < 0} {
6376 set l 0
6378 if {$w eq $canv} {
6379 set xmax [lindex [$canv cget -scrollregion] 2]
6380 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6381 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6383 unmarkmatches
6384 selectline $l 1
6387 proc commit_descriptor {p} {
6388 global commitinfo
6389 if {![info exists commitinfo($p)]} {
6390 getcommit $p
6392 set l "..."
6393 if {[llength $commitinfo($p)] > 1} {
6394 set l [lindex $commitinfo($p) 0]
6396 return "$p ($l)\n"
6399 # append some text to the ctext widget, and make any SHA1 ID
6400 # that we know about be a clickable link.
6401 proc appendwithlinks {text tags} {
6402 global ctext linknum curview
6404 set start [$ctext index "end - 1c"]
6405 $ctext insert end $text $tags
6406 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6407 foreach l $links {
6408 set s [lindex $l 0]
6409 set e [lindex $l 1]
6410 set linkid [string range $text $s $e]
6411 incr e
6412 $ctext tag delete link$linknum
6413 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6414 setlink $linkid link$linknum
6415 incr linknum
6419 proc setlink {id lk} {
6420 global curview ctext pendinglinks
6422 set known 0
6423 if {[string length $id] < 40} {
6424 set matches [longid $id]
6425 if {[llength $matches] > 0} {
6426 if {[llength $matches] > 1} return
6427 set known 1
6428 set id [lindex $matches 0]
6430 } else {
6431 set known [commitinview $id $curview]
6433 if {$known} {
6434 $ctext tag conf $lk -foreground blue -underline 1
6435 $ctext tag bind $lk <1> [list selbyid $id]
6436 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6437 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6438 } else {
6439 lappend pendinglinks($id) $lk
6440 interestedin $id {makelink %P}
6444 proc makelink {id} {
6445 global pendinglinks
6447 if {![info exists pendinglinks($id)]} return
6448 foreach lk $pendinglinks($id) {
6449 setlink $id $lk
6451 unset pendinglinks($id)
6454 proc linkcursor {w inc} {
6455 global linkentercount curtextcursor
6457 if {[incr linkentercount $inc] > 0} {
6458 $w configure -cursor hand2
6459 } else {
6460 $w configure -cursor $curtextcursor
6461 if {$linkentercount < 0} {
6462 set linkentercount 0
6467 proc viewnextline {dir} {
6468 global canv linespc
6470 $canv delete hover
6471 set ymax [lindex [$canv cget -scrollregion] 3]
6472 set wnow [$canv yview]
6473 set wtop [expr {[lindex $wnow 0] * $ymax}]
6474 set newtop [expr {$wtop + $dir * $linespc}]
6475 if {$newtop < 0} {
6476 set newtop 0
6477 } elseif {$newtop > $ymax} {
6478 set newtop $ymax
6480 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6483 # add a list of tag or branch names at position pos
6484 # returns the number of names inserted
6485 proc appendrefs {pos ids var} {
6486 global ctext linknum curview $var maxrefs
6488 if {[catch {$ctext index $pos}]} {
6489 return 0
6491 $ctext conf -state normal
6492 $ctext delete $pos "$pos lineend"
6493 set tags {}
6494 foreach id $ids {
6495 foreach tag [set $var\($id\)] {
6496 lappend tags [list $tag $id]
6499 if {[llength $tags] > $maxrefs} {
6500 $ctext insert $pos "many ([llength $tags])"
6501 } else {
6502 set tags [lsort -index 0 -decreasing $tags]
6503 set sep {}
6504 foreach ti $tags {
6505 set id [lindex $ti 1]
6506 set lk link$linknum
6507 incr linknum
6508 $ctext tag delete $lk
6509 $ctext insert $pos $sep
6510 $ctext insert $pos [lindex $ti 0] $lk
6511 setlink $id $lk
6512 set sep ", "
6515 $ctext conf -state disabled
6516 return [llength $tags]
6519 # called when we have finished computing the nearby tags
6520 proc dispneartags {delay} {
6521 global selectedline currentid showneartags tagphase
6523 if {$selectedline eq {} || !$showneartags} return
6524 after cancel dispnexttag
6525 if {$delay} {
6526 after 200 dispnexttag
6527 set tagphase -1
6528 } else {
6529 after idle dispnexttag
6530 set tagphase 0
6534 proc dispnexttag {} {
6535 global selectedline currentid showneartags tagphase ctext
6537 if {$selectedline eq {} || !$showneartags} return
6538 switch -- $tagphase {
6540 set dtags [desctags $currentid]
6541 if {$dtags ne {}} {
6542 appendrefs precedes $dtags idtags
6546 set atags [anctags $currentid]
6547 if {$atags ne {}} {
6548 appendrefs follows $atags idtags
6552 set dheads [descheads $currentid]
6553 if {$dheads ne {}} {
6554 if {[appendrefs branch $dheads idheads] > 1
6555 && [$ctext get "branch -3c"] eq "h"} {
6556 # turn "Branch" into "Branches"
6557 $ctext conf -state normal
6558 $ctext insert "branch -2c" "es"
6559 $ctext conf -state disabled
6564 if {[incr tagphase] <= 2} {
6565 after idle dispnexttag
6569 proc make_secsel {id} {
6570 global linehtag linentag linedtag canv canv2 canv3
6572 if {![info exists linehtag($id)]} return
6573 $canv delete secsel
6574 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6575 -tags secsel -fill [$canv cget -selectbackground]]
6576 $canv lower $t
6577 $canv2 delete secsel
6578 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6579 -tags secsel -fill [$canv2 cget -selectbackground]]
6580 $canv2 lower $t
6581 $canv3 delete secsel
6582 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6583 -tags secsel -fill [$canv3 cget -selectbackground]]
6584 $canv3 lower $t
6587 proc selectline {l isnew {desired_loc {}}} {
6588 global canv ctext commitinfo selectedline
6589 global canvy0 linespc parents children curview
6590 global currentid sha1entry
6591 global commentend idtags linknum
6592 global mergemax numcommits pending_select
6593 global cmitmode showneartags allcommits
6594 global targetrow targetid lastscrollrows
6595 global autoselect jump_to_here
6597 catch {unset pending_select}
6598 $canv delete hover
6599 normalline
6600 unsel_reflist
6601 stopfinding
6602 if {$l < 0 || $l >= $numcommits} return
6603 set id [commitonrow $l]
6604 set targetid $id
6605 set targetrow $l
6606 set selectedline $l
6607 set currentid $id
6608 if {$lastscrollrows < $numcommits} {
6609 setcanvscroll
6612 set y [expr {$canvy0 + $l * $linespc}]
6613 set ymax [lindex [$canv cget -scrollregion] 3]
6614 set ytop [expr {$y - $linespc - 1}]
6615 set ybot [expr {$y + $linespc + 1}]
6616 set wnow [$canv yview]
6617 set wtop [expr {[lindex $wnow 0] * $ymax}]
6618 set wbot [expr {[lindex $wnow 1] * $ymax}]
6619 set wh [expr {$wbot - $wtop}]
6620 set newtop $wtop
6621 if {$ytop < $wtop} {
6622 if {$ybot < $wtop} {
6623 set newtop [expr {$y - $wh / 2.0}]
6624 } else {
6625 set newtop $ytop
6626 if {$newtop > $wtop - $linespc} {
6627 set newtop [expr {$wtop - $linespc}]
6630 } elseif {$ybot > $wbot} {
6631 if {$ytop > $wbot} {
6632 set newtop [expr {$y - $wh / 2.0}]
6633 } else {
6634 set newtop [expr {$ybot - $wh}]
6635 if {$newtop < $wtop + $linespc} {
6636 set newtop [expr {$wtop + $linespc}]
6640 if {$newtop != $wtop} {
6641 if {$newtop < 0} {
6642 set newtop 0
6644 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6645 drawvisible
6648 make_secsel $id
6650 if {$isnew} {
6651 addtohistory [list selbyid $id]
6654 $sha1entry delete 0 end
6655 $sha1entry insert 0 $id
6656 if {$autoselect} {
6657 $sha1entry selection from 0
6658 $sha1entry selection to end
6660 rhighlight_sel $id
6662 $ctext conf -state normal
6663 clear_ctext
6664 set linknum 0
6665 if {![info exists commitinfo($id)]} {
6666 getcommit $id
6668 set info $commitinfo($id)
6669 set date [formatdate [lindex $info 2]]
6670 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6671 set date [formatdate [lindex $info 4]]
6672 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6673 if {[info exists idtags($id)]} {
6674 $ctext insert end [mc "Tags:"]
6675 foreach tag $idtags($id) {
6676 $ctext insert end " $tag"
6678 $ctext insert end "\n"
6681 set headers {}
6682 set olds $parents($curview,$id)
6683 if {[llength $olds] > 1} {
6684 set np 0
6685 foreach p $olds {
6686 if {$np >= $mergemax} {
6687 set tag mmax
6688 } else {
6689 set tag m$np
6691 $ctext insert end "[mc "Parent"]: " $tag
6692 appendwithlinks [commit_descriptor $p] {}
6693 incr np
6695 } else {
6696 foreach p $olds {
6697 append headers "[mc "Parent"]: [commit_descriptor $p]"
6701 foreach c $children($curview,$id) {
6702 append headers "[mc "Child"]: [commit_descriptor $c]"
6705 # make anything that looks like a SHA1 ID be a clickable link
6706 appendwithlinks $headers {}
6707 if {$showneartags} {
6708 if {![info exists allcommits]} {
6709 getallcommits
6711 $ctext insert end "[mc "Branch"]: "
6712 $ctext mark set branch "end -1c"
6713 $ctext mark gravity branch left
6714 $ctext insert end "\n[mc "Follows"]: "
6715 $ctext mark set follows "end -1c"
6716 $ctext mark gravity follows left
6717 $ctext insert end "\n[mc "Precedes"]: "
6718 $ctext mark set precedes "end -1c"
6719 $ctext mark gravity precedes left
6720 $ctext insert end "\n"
6721 dispneartags 1
6723 $ctext insert end "\n"
6724 set comment [lindex $info 5]
6725 if {[string first "\r" $comment] >= 0} {
6726 set comment [string map {"\r" "\n "} $comment]
6728 appendwithlinks $comment {comment}
6730 $ctext tag remove found 1.0 end
6731 $ctext conf -state disabled
6732 set commentend [$ctext index "end - 1c"]
6734 set jump_to_here $desired_loc
6735 init_flist [mc "Comments"]
6736 if {$cmitmode eq "tree"} {
6737 gettree $id
6738 } elseif {[llength $olds] <= 1} {
6739 startdiff $id
6740 } else {
6741 mergediff $id
6745 proc selfirstline {} {
6746 unmarkmatches
6747 selectline 0 1
6750 proc sellastline {} {
6751 global numcommits
6752 unmarkmatches
6753 set l [expr {$numcommits - 1}]
6754 selectline $l 1
6757 proc selnextline {dir} {
6758 global selectedline
6759 focus .
6760 if {$selectedline eq {}} return
6761 set l [expr {$selectedline + $dir}]
6762 unmarkmatches
6763 selectline $l 1
6766 proc selnextpage {dir} {
6767 global canv linespc selectedline numcommits
6769 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6770 if {$lpp < 1} {
6771 set lpp 1
6773 allcanvs yview scroll [expr {$dir * $lpp}] units
6774 drawvisible
6775 if {$selectedline eq {}} return
6776 set l [expr {$selectedline + $dir * $lpp}]
6777 if {$l < 0} {
6778 set l 0
6779 } elseif {$l >= $numcommits} {
6780 set l [expr $numcommits - 1]
6782 unmarkmatches
6783 selectline $l 1
6786 proc unselectline {} {
6787 global selectedline currentid
6789 set selectedline {}
6790 catch {unset currentid}
6791 allcanvs delete secsel
6792 rhighlight_none
6795 proc reselectline {} {
6796 global selectedline
6798 if {$selectedline ne {}} {
6799 selectline $selectedline 0
6803 proc addtohistory {cmd} {
6804 global history historyindex curview
6806 set elt [list $curview $cmd]
6807 if {$historyindex > 0
6808 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6809 return
6812 if {$historyindex < [llength $history]} {
6813 set history [lreplace $history $historyindex end $elt]
6814 } else {
6815 lappend history $elt
6817 incr historyindex
6818 if {$historyindex > 1} {
6819 .tf.bar.leftbut conf -state normal
6820 } else {
6821 .tf.bar.leftbut conf -state disabled
6823 .tf.bar.rightbut conf -state disabled
6826 proc godo {elt} {
6827 global curview
6829 set view [lindex $elt 0]
6830 set cmd [lindex $elt 1]
6831 if {$curview != $view} {
6832 showview $view
6834 eval $cmd
6837 proc goback {} {
6838 global history historyindex
6839 focus .
6841 if {$historyindex > 1} {
6842 incr historyindex -1
6843 godo [lindex $history [expr {$historyindex - 1}]]
6844 .tf.bar.rightbut conf -state normal
6846 if {$historyindex <= 1} {
6847 .tf.bar.leftbut conf -state disabled
6851 proc goforw {} {
6852 global history historyindex
6853 focus .
6855 if {$historyindex < [llength $history]} {
6856 set cmd [lindex $history $historyindex]
6857 incr historyindex
6858 godo $cmd
6859 .tf.bar.leftbut conf -state normal
6861 if {$historyindex >= [llength $history]} {
6862 .tf.bar.rightbut conf -state disabled
6866 proc gettree {id} {
6867 global treefilelist treeidlist diffids diffmergeid treepending
6868 global nullid nullid2
6870 set diffids $id
6871 catch {unset diffmergeid}
6872 if {![info exists treefilelist($id)]} {
6873 if {![info exists treepending]} {
6874 if {$id eq $nullid} {
6875 set cmd [list | git ls-files]
6876 } elseif {$id eq $nullid2} {
6877 set cmd [list | git ls-files --stage -t]
6878 } else {
6879 set cmd [list | git ls-tree -r $id]
6881 if {[catch {set gtf [open $cmd r]}]} {
6882 return
6884 set treepending $id
6885 set treefilelist($id) {}
6886 set treeidlist($id) {}
6887 fconfigure $gtf -blocking 0 -encoding binary
6888 filerun $gtf [list gettreeline $gtf $id]
6890 } else {
6891 setfilelist $id
6895 proc gettreeline {gtf id} {
6896 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6898 set nl 0
6899 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6900 if {$diffids eq $nullid} {
6901 set fname $line
6902 } else {
6903 set i [string first "\t" $line]
6904 if {$i < 0} continue
6905 set fname [string range $line [expr {$i+1}] end]
6906 set line [string range $line 0 [expr {$i-1}]]
6907 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6908 set sha1 [lindex $line 2]
6909 lappend treeidlist($id) $sha1
6911 if {[string index $fname 0] eq "\""} {
6912 set fname [lindex $fname 0]
6914 set fname [encoding convertfrom $fname]
6915 lappend treefilelist($id) $fname
6917 if {![eof $gtf]} {
6918 return [expr {$nl >= 1000? 2: 1}]
6920 close $gtf
6921 unset treepending
6922 if {$cmitmode ne "tree"} {
6923 if {![info exists diffmergeid]} {
6924 gettreediffs $diffids
6926 } elseif {$id ne $diffids} {
6927 gettree $diffids
6928 } else {
6929 setfilelist $id
6931 return 0
6934 proc showfile {f} {
6935 global treefilelist treeidlist diffids nullid nullid2
6936 global ctext_file_names ctext_file_lines
6937 global ctext commentend
6939 set i [lsearch -exact $treefilelist($diffids) $f]
6940 if {$i < 0} {
6941 puts "oops, $f not in list for id $diffids"
6942 return
6944 if {$diffids eq $nullid} {
6945 if {[catch {set bf [open $f r]} err]} {
6946 puts "oops, can't read $f: $err"
6947 return
6949 } else {
6950 set blob [lindex $treeidlist($diffids) $i]
6951 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6952 puts "oops, error reading blob $blob: $err"
6953 return
6956 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6957 filerun $bf [list getblobline $bf $diffids]
6958 $ctext config -state normal
6959 clear_ctext $commentend
6960 lappend ctext_file_names $f
6961 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6962 $ctext insert end "\n"
6963 $ctext insert end "$f\n" filesep
6964 $ctext config -state disabled
6965 $ctext yview $commentend
6966 settabs 0
6969 proc getblobline {bf id} {
6970 global diffids cmitmode ctext
6972 if {$id ne $diffids || $cmitmode ne "tree"} {
6973 catch {close $bf}
6974 return 0
6976 $ctext config -state normal
6977 set nl 0
6978 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6979 $ctext insert end "$line\n"
6981 if {[eof $bf]} {
6982 global jump_to_here ctext_file_names commentend
6984 # delete last newline
6985 $ctext delete "end - 2c" "end - 1c"
6986 close $bf
6987 if {$jump_to_here ne {} &&
6988 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6989 set lnum [expr {[lindex $jump_to_here 1] +
6990 [lindex [split $commentend .] 0]}]
6991 mark_ctext_line $lnum
6993 return 0
6995 $ctext config -state disabled
6996 return [expr {$nl >= 1000? 2: 1}]
6999 proc mark_ctext_line {lnum} {
7000 global ctext markbgcolor
7002 $ctext tag delete omark
7003 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7004 $ctext tag conf omark -background $markbgcolor
7005 $ctext see $lnum.0
7008 proc mergediff {id} {
7009 global diffmergeid
7010 global diffids treediffs
7011 global parents curview
7013 set diffmergeid $id
7014 set diffids $id
7015 set treediffs($id) {}
7016 set np [llength $parents($curview,$id)]
7017 settabs $np
7018 getblobdiffs $id
7021 proc startdiff {ids} {
7022 global treediffs diffids treepending diffmergeid nullid nullid2
7024 settabs 1
7025 set diffids $ids
7026 catch {unset diffmergeid}
7027 if {![info exists treediffs($ids)] ||
7028 [lsearch -exact $ids $nullid] >= 0 ||
7029 [lsearch -exact $ids $nullid2] >= 0} {
7030 if {![info exists treepending]} {
7031 gettreediffs $ids
7033 } else {
7034 addtocflist $ids
7038 proc path_filter {filter name} {
7039 foreach p $filter {
7040 set l [string length $p]
7041 if {[string index $p end] eq "/"} {
7042 if {[string compare -length $l $p $name] == 0} {
7043 return 1
7045 } else {
7046 if {[string compare -length $l $p $name] == 0 &&
7047 ([string length $name] == $l ||
7048 [string index $name $l] eq "/")} {
7049 return 1
7053 return 0
7056 proc addtocflist {ids} {
7057 global treediffs
7059 add_flist $treediffs($ids)
7060 getblobdiffs $ids
7063 proc diffcmd {ids flags} {
7064 global nullid nullid2
7066 set i [lsearch -exact $ids $nullid]
7067 set j [lsearch -exact $ids $nullid2]
7068 if {$i >= 0} {
7069 if {[llength $ids] > 1 && $j < 0} {
7070 # comparing working directory with some specific revision
7071 set cmd [concat | git diff-index $flags]
7072 if {$i == 0} {
7073 lappend cmd -R [lindex $ids 1]
7074 } else {
7075 lappend cmd [lindex $ids 0]
7077 } else {
7078 # comparing working directory with index
7079 set cmd [concat | git diff-files $flags]
7080 if {$j == 1} {
7081 lappend cmd -R
7084 } elseif {$j >= 0} {
7085 set cmd [concat | git diff-index --cached $flags]
7086 if {[llength $ids] > 1} {
7087 # comparing index with specific revision
7088 if {$i == 0} {
7089 lappend cmd -R [lindex $ids 1]
7090 } else {
7091 lappend cmd [lindex $ids 0]
7093 } else {
7094 # comparing index with HEAD
7095 lappend cmd HEAD
7097 } else {
7098 set cmd [concat | git diff-tree -r $flags $ids]
7100 return $cmd
7103 proc gettreediffs {ids} {
7104 global treediff treepending
7106 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7108 set treepending $ids
7109 set treediff {}
7110 fconfigure $gdtf -blocking 0 -encoding binary
7111 filerun $gdtf [list gettreediffline $gdtf $ids]
7114 proc gettreediffline {gdtf ids} {
7115 global treediff treediffs treepending diffids diffmergeid
7116 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7118 set nr 0
7119 set sublist {}
7120 set max 1000
7121 if {$perfile_attrs} {
7122 # cache_gitattr is slow, and even slower on win32 where we
7123 # have to invoke it for only about 30 paths at a time
7124 set max 500
7125 if {[tk windowingsystem] == "win32"} {
7126 set max 120
7129 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7130 set i [string first "\t" $line]
7131 if {$i >= 0} {
7132 set file [string range $line [expr {$i+1}] end]
7133 if {[string index $file 0] eq "\""} {
7134 set file [lindex $file 0]
7136 set file [encoding convertfrom $file]
7137 if {$file ne [lindex $treediff end]} {
7138 lappend treediff $file
7139 lappend sublist $file
7143 if {$perfile_attrs} {
7144 cache_gitattr encoding $sublist
7146 if {![eof $gdtf]} {
7147 return [expr {$nr >= $max? 2: 1}]
7149 close $gdtf
7150 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7151 set flist {}
7152 foreach f $treediff {
7153 if {[path_filter $vfilelimit($curview) $f]} {
7154 lappend flist $f
7157 set treediffs($ids) $flist
7158 } else {
7159 set treediffs($ids) $treediff
7161 unset treepending
7162 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7163 gettree $diffids
7164 } elseif {$ids != $diffids} {
7165 if {![info exists diffmergeid]} {
7166 gettreediffs $diffids
7168 } else {
7169 addtocflist $ids
7171 return 0
7174 # empty string or positive integer
7175 proc diffcontextvalidate {v} {
7176 return [regexp {^(|[1-9][0-9]*)$} $v]
7179 proc diffcontextchange {n1 n2 op} {
7180 global diffcontextstring diffcontext
7182 if {[string is integer -strict $diffcontextstring]} {
7183 if {$diffcontextstring > 0} {
7184 set diffcontext $diffcontextstring
7185 reselectline
7190 proc changeignorespace {} {
7191 reselectline
7194 proc getblobdiffs {ids} {
7195 global blobdifffd diffids env
7196 global diffinhdr treediffs
7197 global diffcontext
7198 global ignorespace
7199 global limitdiffs vfilelimit curview
7200 global diffencoding targetline diffnparents
7202 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7203 if {$ignorespace} {
7204 append cmd " -w"
7206 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7207 set cmd [concat $cmd -- $vfilelimit($curview)]
7209 if {[catch {set bdf [open $cmd r]} err]} {
7210 error_popup [mc "Error getting diffs: %s" $err]
7211 return
7213 set targetline {}
7214 set diffnparents 0
7215 set diffinhdr 0
7216 set diffencoding [get_path_encoding {}]
7217 fconfigure $bdf -blocking 0 -encoding binary
7218 set blobdifffd($ids) $bdf
7219 filerun $bdf [list getblobdiffline $bdf $diffids]
7222 proc setinlist {var i val} {
7223 global $var
7225 while {[llength [set $var]] < $i} {
7226 lappend $var {}
7228 if {[llength [set $var]] == $i} {
7229 lappend $var $val
7230 } else {
7231 lset $var $i $val
7235 proc makediffhdr {fname ids} {
7236 global ctext curdiffstart treediffs diffencoding
7237 global ctext_file_names jump_to_here targetline diffline
7239 set fname [encoding convertfrom $fname]
7240 set diffencoding [get_path_encoding $fname]
7241 set i [lsearch -exact $treediffs($ids) $fname]
7242 if {$i >= 0} {
7243 setinlist difffilestart $i $curdiffstart
7245 lset ctext_file_names end $fname
7246 set l [expr {(78 - [string length $fname]) / 2}]
7247 set pad [string range "----------------------------------------" 1 $l]
7248 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7249 set targetline {}
7250 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7251 set targetline [lindex $jump_to_here 1]
7253 set diffline 0
7256 proc getblobdiffline {bdf ids} {
7257 global diffids blobdifffd ctext curdiffstart
7258 global diffnexthead diffnextnote difffilestart
7259 global ctext_file_names ctext_file_lines
7260 global diffinhdr treediffs mergemax diffnparents
7261 global diffencoding jump_to_here targetline diffline
7263 set nr 0
7264 $ctext conf -state normal
7265 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7266 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7267 close $bdf
7268 return 0
7270 if {![string compare -length 5 "diff " $line]} {
7271 if {![regexp {^diff (--cc|--git) } $line m type]} {
7272 set line [encoding convertfrom $line]
7273 $ctext insert end "$line\n" hunksep
7274 continue
7276 # start of a new file
7277 set diffinhdr 1
7278 $ctext insert end "\n"
7279 set curdiffstart [$ctext index "end - 1c"]
7280 lappend ctext_file_names ""
7281 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7282 $ctext insert end "\n" filesep
7284 if {$type eq "--cc"} {
7285 # start of a new file in a merge diff
7286 set fname [string range $line 10 end]
7287 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7288 lappend treediffs($ids) $fname
7289 add_flist [list $fname]
7292 } else {
7293 set line [string range $line 11 end]
7294 # If the name hasn't changed the length will be odd,
7295 # the middle char will be a space, and the two bits either
7296 # side will be a/name and b/name, or "a/name" and "b/name".
7297 # If the name has changed we'll get "rename from" and
7298 # "rename to" or "copy from" and "copy to" lines following
7299 # this, and we'll use them to get the filenames.
7300 # This complexity is necessary because spaces in the
7301 # filename(s) don't get escaped.
7302 set l [string length $line]
7303 set i [expr {$l / 2}]
7304 if {!(($l & 1) && [string index $line $i] eq " " &&
7305 [string range $line 2 [expr {$i - 1}]] eq \
7306 [string range $line [expr {$i + 3}] end])} {
7307 continue
7309 # unescape if quoted and chop off the a/ from the front
7310 if {[string index $line 0] eq "\""} {
7311 set fname [string range [lindex $line 0] 2 end]
7312 } else {
7313 set fname [string range $line 2 [expr {$i - 1}]]
7316 makediffhdr $fname $ids
7318 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7319 set fname [encoding convertfrom [string range $line 16 end]]
7320 $ctext insert end "\n"
7321 set curdiffstart [$ctext index "end - 1c"]
7322 lappend ctext_file_names $fname
7323 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7324 $ctext insert end "$line\n" filesep
7325 set i [lsearch -exact $treediffs($ids) $fname]
7326 if {$i >= 0} {
7327 setinlist difffilestart $i $curdiffstart
7330 } elseif {![string compare -length 2 "@@" $line]} {
7331 regexp {^@@+} $line ats
7332 set line [encoding convertfrom $diffencoding $line]
7333 $ctext insert end "$line\n" hunksep
7334 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7335 set diffline $nl
7337 set diffnparents [expr {[string length $ats] - 1}]
7338 set diffinhdr 0
7340 } elseif {$diffinhdr} {
7341 if {![string compare -length 12 "rename from " $line]} {
7342 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7343 if {[string index $fname 0] eq "\""} {
7344 set fname [lindex $fname 0]
7346 set fname [encoding convertfrom $fname]
7347 set i [lsearch -exact $treediffs($ids) $fname]
7348 if {$i >= 0} {
7349 setinlist difffilestart $i $curdiffstart
7351 } elseif {![string compare -length 10 $line "rename to "] ||
7352 ![string compare -length 8 $line "copy to "]} {
7353 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7354 if {[string index $fname 0] eq "\""} {
7355 set fname [lindex $fname 0]
7357 makediffhdr $fname $ids
7358 } elseif {[string compare -length 3 $line "---"] == 0} {
7359 # do nothing
7360 continue
7361 } elseif {[string compare -length 3 $line "+++"] == 0} {
7362 set diffinhdr 0
7363 continue
7365 $ctext insert end "$line\n" filesep
7367 } else {
7368 set line [encoding convertfrom $diffencoding $line]
7369 # parse the prefix - one ' ', '-' or '+' for each parent
7370 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7371 set tag [expr {$diffnparents > 1? "m": "d"}]
7372 if {[string trim $prefix " -+"] eq {}} {
7373 # prefix only has " ", "-" and "+" in it: normal diff line
7374 set num [string first "-" $prefix]
7375 if {$num >= 0} {
7376 # removed line, first parent with line is $num
7377 if {$num >= $mergemax} {
7378 set num "max"
7380 $ctext insert end "$line\n" $tag$num
7381 } else {
7382 set tags {}
7383 if {[string first "+" $prefix] >= 0} {
7384 # added line
7385 lappend tags ${tag}result
7386 if {$diffnparents > 1} {
7387 set num [string first " " $prefix]
7388 if {$num >= 0} {
7389 if {$num >= $mergemax} {
7390 set num "max"
7392 lappend tags m$num
7396 if {$targetline ne {}} {
7397 if {$diffline == $targetline} {
7398 set seehere [$ctext index "end - 1 chars"]
7399 set targetline {}
7400 } else {
7401 incr diffline
7404 $ctext insert end "$line\n" $tags
7406 } else {
7407 # "\ No newline at end of file",
7408 # or something else we don't recognize
7409 $ctext insert end "$line\n" hunksep
7413 if {[info exists seehere]} {
7414 mark_ctext_line [lindex [split $seehere .] 0]
7416 $ctext conf -state disabled
7417 if {[eof $bdf]} {
7418 close $bdf
7419 return 0
7421 return [expr {$nr >= 1000? 2: 1}]
7424 proc changediffdisp {} {
7425 global ctext diffelide
7427 $ctext tag conf d0 -elide [lindex $diffelide 0]
7428 $ctext tag conf dresult -elide [lindex $diffelide 1]
7431 proc highlightfile {loc cline} {
7432 global ctext cflist cflist_top
7434 $ctext yview $loc
7435 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7436 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7437 $cflist see $cline.0
7438 set cflist_top $cline
7441 proc prevfile {} {
7442 global difffilestart ctext cmitmode
7444 if {$cmitmode eq "tree"} return
7445 set prev 0.0
7446 set prevline 1
7447 set here [$ctext index @0,0]
7448 foreach loc $difffilestart {
7449 if {[$ctext compare $loc >= $here]} {
7450 highlightfile $prev $prevline
7451 return
7453 set prev $loc
7454 incr prevline
7456 highlightfile $prev $prevline
7459 proc nextfile {} {
7460 global difffilestart ctext cmitmode
7462 if {$cmitmode eq "tree"} return
7463 set here [$ctext index @0,0]
7464 set line 1
7465 foreach loc $difffilestart {
7466 incr line
7467 if {[$ctext compare $loc > $here]} {
7468 highlightfile $loc $line
7469 return
7474 proc clear_ctext {{first 1.0}} {
7475 global ctext smarktop smarkbot
7476 global ctext_file_names ctext_file_lines
7477 global pendinglinks
7479 set l [lindex [split $first .] 0]
7480 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7481 set smarktop $l
7483 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7484 set smarkbot $l
7486 $ctext delete $first end
7487 if {$first eq "1.0"} {
7488 catch {unset pendinglinks}
7490 set ctext_file_names {}
7491 set ctext_file_lines {}
7494 proc settabs {{firstab {}}} {
7495 global firsttabstop tabstop ctext have_tk85
7497 if {$firstab ne {} && $have_tk85} {
7498 set firsttabstop $firstab
7500 set w [font measure textfont "0"]
7501 if {$firsttabstop != 0} {
7502 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7503 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7504 } elseif {$have_tk85 || $tabstop != 8} {
7505 $ctext conf -tabs [expr {$tabstop * $w}]
7506 } else {
7507 $ctext conf -tabs {}
7511 proc incrsearch {name ix op} {
7512 global ctext searchstring searchdirn
7514 $ctext tag remove found 1.0 end
7515 if {[catch {$ctext index anchor}]} {
7516 # no anchor set, use start of selection, or of visible area
7517 set sel [$ctext tag ranges sel]
7518 if {$sel ne {}} {
7519 $ctext mark set anchor [lindex $sel 0]
7520 } elseif {$searchdirn eq "-forwards"} {
7521 $ctext mark set anchor @0,0
7522 } else {
7523 $ctext mark set anchor @0,[winfo height $ctext]
7526 if {$searchstring ne {}} {
7527 set here [$ctext search $searchdirn -- $searchstring anchor]
7528 if {$here ne {}} {
7529 $ctext see $here
7531 searchmarkvisible 1
7535 proc dosearch {} {
7536 global sstring ctext searchstring searchdirn
7538 focus $sstring
7539 $sstring icursor end
7540 set searchdirn -forwards
7541 if {$searchstring ne {}} {
7542 set sel [$ctext tag ranges sel]
7543 if {$sel ne {}} {
7544 set start "[lindex $sel 0] + 1c"
7545 } elseif {[catch {set start [$ctext index anchor]}]} {
7546 set start "@0,0"
7548 set match [$ctext search -count mlen -- $searchstring $start]
7549 $ctext tag remove sel 1.0 end
7550 if {$match eq {}} {
7551 bell
7552 return
7554 $ctext see $match
7555 set mend "$match + $mlen c"
7556 $ctext tag add sel $match $mend
7557 $ctext mark unset anchor
7561 proc dosearchback {} {
7562 global sstring ctext searchstring searchdirn
7564 focus $sstring
7565 $sstring icursor end
7566 set searchdirn -backwards
7567 if {$searchstring ne {}} {
7568 set sel [$ctext tag ranges sel]
7569 if {$sel ne {}} {
7570 set start [lindex $sel 0]
7571 } elseif {[catch {set start [$ctext index anchor]}]} {
7572 set start @0,[winfo height $ctext]
7574 set match [$ctext search -backwards -count ml -- $searchstring $start]
7575 $ctext tag remove sel 1.0 end
7576 if {$match eq {}} {
7577 bell
7578 return
7580 $ctext see $match
7581 set mend "$match + $ml c"
7582 $ctext tag add sel $match $mend
7583 $ctext mark unset anchor
7587 proc searchmark {first last} {
7588 global ctext searchstring
7590 set mend $first.0
7591 while {1} {
7592 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7593 if {$match eq {}} break
7594 set mend "$match + $mlen c"
7595 $ctext tag add found $match $mend
7599 proc searchmarkvisible {doall} {
7600 global ctext smarktop smarkbot
7602 set topline [lindex [split [$ctext index @0,0] .] 0]
7603 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7604 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7605 # no overlap with previous
7606 searchmark $topline $botline
7607 set smarktop $topline
7608 set smarkbot $botline
7609 } else {
7610 if {$topline < $smarktop} {
7611 searchmark $topline [expr {$smarktop-1}]
7612 set smarktop $topline
7614 if {$botline > $smarkbot} {
7615 searchmark [expr {$smarkbot+1}] $botline
7616 set smarkbot $botline
7621 proc scrolltext {f0 f1} {
7622 global searchstring
7624 .bleft.bottom.sb set $f0 $f1
7625 if {$searchstring ne {}} {
7626 searchmarkvisible 0
7630 proc setcoords {} {
7631 global linespc charspc canvx0 canvy0
7632 global xspc1 xspc2 lthickness
7634 set linespc [font metrics mainfont -linespace]
7635 set charspc [font measure mainfont "m"]
7636 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7637 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7638 set lthickness [expr {int($linespc / 9) + 1}]
7639 set xspc1(0) $linespc
7640 set xspc2 $linespc
7643 proc redisplay {} {
7644 global canv
7645 global selectedline
7647 set ymax [lindex [$canv cget -scrollregion] 3]
7648 if {$ymax eq {} || $ymax == 0} return
7649 set span [$canv yview]
7650 clear_display
7651 setcanvscroll
7652 allcanvs yview moveto [lindex $span 0]
7653 drawvisible
7654 if {$selectedline ne {}} {
7655 selectline $selectedline 0
7656 allcanvs yview moveto [lindex $span 0]
7660 proc parsefont {f n} {
7661 global fontattr
7663 set fontattr($f,family) [lindex $n 0]
7664 set s [lindex $n 1]
7665 if {$s eq {} || $s == 0} {
7666 set s 10
7667 } elseif {$s < 0} {
7668 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7670 set fontattr($f,size) $s
7671 set fontattr($f,weight) normal
7672 set fontattr($f,slant) roman
7673 foreach style [lrange $n 2 end] {
7674 switch -- $style {
7675 "normal" -
7676 "bold" {set fontattr($f,weight) $style}
7677 "roman" -
7678 "italic" {set fontattr($f,slant) $style}
7683 proc fontflags {f {isbold 0}} {
7684 global fontattr
7686 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7687 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7688 -slant $fontattr($f,slant)]
7691 proc fontname {f} {
7692 global fontattr
7694 set n [list $fontattr($f,family) $fontattr($f,size)]
7695 if {$fontattr($f,weight) eq "bold"} {
7696 lappend n "bold"
7698 if {$fontattr($f,slant) eq "italic"} {
7699 lappend n "italic"
7701 return $n
7704 proc incrfont {inc} {
7705 global mainfont textfont ctext canv cflist showrefstop
7706 global stopped entries fontattr
7708 unmarkmatches
7709 set s $fontattr(mainfont,size)
7710 incr s $inc
7711 if {$s < 1} {
7712 set s 1
7714 set fontattr(mainfont,size) $s
7715 font config mainfont -size $s
7716 font config mainfontbold -size $s
7717 set mainfont [fontname mainfont]
7718 set s $fontattr(textfont,size)
7719 incr s $inc
7720 if {$s < 1} {
7721 set s 1
7723 set fontattr(textfont,size) $s
7724 font config textfont -size $s
7725 font config textfontbold -size $s
7726 set textfont [fontname textfont]
7727 setcoords
7728 settabs
7729 redisplay
7732 proc clearsha1 {} {
7733 global sha1entry sha1string
7734 if {[string length $sha1string] == 40} {
7735 $sha1entry delete 0 end
7739 proc sha1change {n1 n2 op} {
7740 global sha1string currentid sha1but
7741 if {$sha1string == {}
7742 || ([info exists currentid] && $sha1string == $currentid)} {
7743 set state disabled
7744 } else {
7745 set state normal
7747 if {[$sha1but cget -state] == $state} return
7748 if {$state == "normal"} {
7749 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7750 } else {
7751 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7755 proc gotocommit {} {
7756 global sha1string tagids headids curview varcid
7758 if {$sha1string == {}
7759 || ([info exists currentid] && $sha1string == $currentid)} return
7760 if {[info exists tagids($sha1string)]} {
7761 set id $tagids($sha1string)
7762 } elseif {[info exists headids($sha1string)]} {
7763 set id $headids($sha1string)
7764 } else {
7765 set id [string tolower $sha1string]
7766 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7767 set matches [longid $id]
7768 if {$matches ne {}} {
7769 if {[llength $matches] > 1} {
7770 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7771 return
7773 set id [lindex $matches 0]
7777 if {[commitinview $id $curview]} {
7778 selectline [rowofcommit $id] 1
7779 return
7781 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7782 set msg [mc "SHA1 id %s is not known" $sha1string]
7783 } else {
7784 set msg [mc "Tag/Head %s is not known" $sha1string]
7786 error_popup $msg
7789 proc lineenter {x y id} {
7790 global hoverx hovery hoverid hovertimer
7791 global commitinfo canv
7793 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7794 set hoverx $x
7795 set hovery $y
7796 set hoverid $id
7797 if {[info exists hovertimer]} {
7798 after cancel $hovertimer
7800 set hovertimer [after 500 linehover]
7801 $canv delete hover
7804 proc linemotion {x y id} {
7805 global hoverx hovery hoverid hovertimer
7807 if {[info exists hoverid] && $id == $hoverid} {
7808 set hoverx $x
7809 set hovery $y
7810 if {[info exists hovertimer]} {
7811 after cancel $hovertimer
7813 set hovertimer [after 500 linehover]
7817 proc lineleave {id} {
7818 global hoverid hovertimer canv
7820 if {[info exists hoverid] && $id == $hoverid} {
7821 $canv delete hover
7822 if {[info exists hovertimer]} {
7823 after cancel $hovertimer
7824 unset hovertimer
7826 unset hoverid
7830 proc linehover {} {
7831 global hoverx hovery hoverid hovertimer
7832 global canv linespc lthickness
7833 global commitinfo
7835 set text [lindex $commitinfo($hoverid) 0]
7836 set ymax [lindex [$canv cget -scrollregion] 3]
7837 if {$ymax == {}} return
7838 set yfrac [lindex [$canv yview] 0]
7839 set x [expr {$hoverx + 2 * $linespc}]
7840 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7841 set x0 [expr {$x - 2 * $lthickness}]
7842 set y0 [expr {$y - 2 * $lthickness}]
7843 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7844 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7845 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7846 -fill \#ffff80 -outline black -width 1 -tags hover]
7847 $canv raise $t
7848 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7849 -font mainfont]
7850 $canv raise $t
7853 proc clickisonarrow {id y} {
7854 global lthickness
7856 set ranges [rowranges $id]
7857 set thresh [expr {2 * $lthickness + 6}]
7858 set n [expr {[llength $ranges] - 1}]
7859 for {set i 1} {$i < $n} {incr i} {
7860 set row [lindex $ranges $i]
7861 if {abs([yc $row] - $y) < $thresh} {
7862 return $i
7865 return {}
7868 proc arrowjump {id n y} {
7869 global canv
7871 # 1 <-> 2, 3 <-> 4, etc...
7872 set n [expr {(($n - 1) ^ 1) + 1}]
7873 set row [lindex [rowranges $id] $n]
7874 set yt [yc $row]
7875 set ymax [lindex [$canv cget -scrollregion] 3]
7876 if {$ymax eq {} || $ymax <= 0} return
7877 set view [$canv yview]
7878 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7879 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7880 if {$yfrac < 0} {
7881 set yfrac 0
7883 allcanvs yview moveto $yfrac
7886 proc lineclick {x y id isnew} {
7887 global ctext commitinfo children canv thickerline curview
7889 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7890 unmarkmatches
7891 unselectline
7892 normalline
7893 $canv delete hover
7894 # draw this line thicker than normal
7895 set thickerline $id
7896 drawlines $id
7897 if {$isnew} {
7898 set ymax [lindex [$canv cget -scrollregion] 3]
7899 if {$ymax eq {}} return
7900 set yfrac [lindex [$canv yview] 0]
7901 set y [expr {$y + $yfrac * $ymax}]
7903 set dirn [clickisonarrow $id $y]
7904 if {$dirn ne {}} {
7905 arrowjump $id $dirn $y
7906 return
7909 if {$isnew} {
7910 addtohistory [list lineclick $x $y $id 0]
7912 # fill the details pane with info about this line
7913 $ctext conf -state normal
7914 clear_ctext
7915 settabs 0
7916 $ctext insert end "[mc "Parent"]:\t"
7917 $ctext insert end $id link0
7918 setlink $id link0
7919 set info $commitinfo($id)
7920 $ctext insert end "\n\t[lindex $info 0]\n"
7921 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7922 set date [formatdate [lindex $info 2]]
7923 $ctext insert end "\t[mc "Date"]:\t$date\n"
7924 set kids $children($curview,$id)
7925 if {$kids ne {}} {
7926 $ctext insert end "\n[mc "Children"]:"
7927 set i 0
7928 foreach child $kids {
7929 incr i
7930 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7931 set info $commitinfo($child)
7932 $ctext insert end "\n\t"
7933 $ctext insert end $child link$i
7934 setlink $child link$i
7935 $ctext insert end "\n\t[lindex $info 0]"
7936 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7937 set date [formatdate [lindex $info 2]]
7938 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7941 $ctext conf -state disabled
7942 init_flist {}
7945 proc normalline {} {
7946 global thickerline
7947 if {[info exists thickerline]} {
7948 set id $thickerline
7949 unset thickerline
7950 drawlines $id
7954 proc selbyid {id} {
7955 global curview
7956 if {[commitinview $id $curview]} {
7957 selectline [rowofcommit $id] 1
7961 proc mstime {} {
7962 global startmstime
7963 if {![info exists startmstime]} {
7964 set startmstime [clock clicks -milliseconds]
7966 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7969 proc rowmenu {x y id} {
7970 global rowctxmenu selectedline rowmenuid curview
7971 global nullid nullid2 fakerowmenu mainhead
7973 stopfinding
7974 set rowmenuid $id
7975 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7976 set state disabled
7977 } else {
7978 set state normal
7980 if {$id ne $nullid && $id ne $nullid2} {
7981 set menu $rowctxmenu
7982 if {$mainhead ne {}} {
7983 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
7984 } else {
7985 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7987 } else {
7988 set menu $fakerowmenu
7990 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7991 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7992 $menu entryconfigure [mca "Make patch"] -state $state
7993 tk_popup $menu $x $y
7996 proc diffvssel {dirn} {
7997 global rowmenuid selectedline
7999 if {$selectedline eq {}} return
8000 if {$dirn} {
8001 set oldid [commitonrow $selectedline]
8002 set newid $rowmenuid
8003 } else {
8004 set oldid $rowmenuid
8005 set newid [commitonrow $selectedline]
8007 addtohistory [list doseldiff $oldid $newid]
8008 doseldiff $oldid $newid
8011 proc doseldiff {oldid newid} {
8012 global ctext
8013 global commitinfo
8015 $ctext conf -state normal
8016 clear_ctext
8017 init_flist [mc "Top"]
8018 $ctext insert end "[mc "From"] "
8019 $ctext insert end $oldid link0
8020 setlink $oldid link0
8021 $ctext insert end "\n "
8022 $ctext insert end [lindex $commitinfo($oldid) 0]
8023 $ctext insert end "\n\n[mc "To"] "
8024 $ctext insert end $newid link1
8025 setlink $newid link1
8026 $ctext insert end "\n "
8027 $ctext insert end [lindex $commitinfo($newid) 0]
8028 $ctext insert end "\n"
8029 $ctext conf -state disabled
8030 $ctext tag remove found 1.0 end
8031 startdiff [list $oldid $newid]
8034 proc mkpatch {} {
8035 global rowmenuid currentid commitinfo patchtop patchnum
8037 if {![info exists currentid]} return
8038 set oldid $currentid
8039 set oldhead [lindex $commitinfo($oldid) 0]
8040 set newid $rowmenuid
8041 set newhead [lindex $commitinfo($newid) 0]
8042 set top .patch
8043 set patchtop $top
8044 catch {destroy $top}
8045 toplevel $top
8046 make_transient $top .
8047 label $top.title -text [mc "Generate patch"]
8048 grid $top.title - -pady 10
8049 label $top.from -text [mc "From:"]
8050 entry $top.fromsha1 -width 40 -relief flat
8051 $top.fromsha1 insert 0 $oldid
8052 $top.fromsha1 conf -state readonly
8053 grid $top.from $top.fromsha1 -sticky w
8054 entry $top.fromhead -width 60 -relief flat
8055 $top.fromhead insert 0 $oldhead
8056 $top.fromhead conf -state readonly
8057 grid x $top.fromhead -sticky w
8058 label $top.to -text [mc "To:"]
8059 entry $top.tosha1 -width 40 -relief flat
8060 $top.tosha1 insert 0 $newid
8061 $top.tosha1 conf -state readonly
8062 grid $top.to $top.tosha1 -sticky w
8063 entry $top.tohead -width 60 -relief flat
8064 $top.tohead insert 0 $newhead
8065 $top.tohead conf -state readonly
8066 grid x $top.tohead -sticky w
8067 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8068 grid $top.rev x -pady 10
8069 label $top.flab -text [mc "Output file:"]
8070 entry $top.fname -width 60
8071 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8072 incr patchnum
8073 grid $top.flab $top.fname -sticky w
8074 frame $top.buts
8075 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8076 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8077 bind $top <Key-Return> mkpatchgo
8078 bind $top <Key-Escape> mkpatchcan
8079 grid $top.buts.gen $top.buts.can
8080 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8081 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8082 grid $top.buts - -pady 10 -sticky ew
8083 focus $top.fname
8086 proc mkpatchrev {} {
8087 global patchtop
8089 set oldid [$patchtop.fromsha1 get]
8090 set oldhead [$patchtop.fromhead get]
8091 set newid [$patchtop.tosha1 get]
8092 set newhead [$patchtop.tohead get]
8093 foreach e [list fromsha1 fromhead tosha1 tohead] \
8094 v [list $newid $newhead $oldid $oldhead] {
8095 $patchtop.$e conf -state normal
8096 $patchtop.$e delete 0 end
8097 $patchtop.$e insert 0 $v
8098 $patchtop.$e conf -state readonly
8102 proc mkpatchgo {} {
8103 global patchtop nullid nullid2
8105 set oldid [$patchtop.fromsha1 get]
8106 set newid [$patchtop.tosha1 get]
8107 set fname [$patchtop.fname get]
8108 set cmd [diffcmd [list $oldid $newid] -p]
8109 # trim off the initial "|"
8110 set cmd [lrange $cmd 1 end]
8111 lappend cmd >$fname &
8112 if {[catch {eval exec $cmd} err]} {
8113 error_popup "[mc "Error creating patch:"] $err" $patchtop
8115 catch {destroy $patchtop}
8116 unset patchtop
8119 proc mkpatchcan {} {
8120 global patchtop
8122 catch {destroy $patchtop}
8123 unset patchtop
8126 proc mktag {} {
8127 global rowmenuid mktagtop commitinfo
8129 set top .maketag
8130 set mktagtop $top
8131 catch {destroy $top}
8132 toplevel $top
8133 make_transient $top .
8134 label $top.title -text [mc "Create tag"]
8135 grid $top.title - -pady 10
8136 label $top.id -text [mc "ID:"]
8137 entry $top.sha1 -width 40 -relief flat
8138 $top.sha1 insert 0 $rowmenuid
8139 $top.sha1 conf -state readonly
8140 grid $top.id $top.sha1 -sticky w
8141 entry $top.head -width 60 -relief flat
8142 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8143 $top.head conf -state readonly
8144 grid x $top.head -sticky w
8145 label $top.tlab -text [mc "Tag name:"]
8146 entry $top.tag -width 60
8147 grid $top.tlab $top.tag -sticky w
8148 frame $top.buts
8149 button $top.buts.gen -text [mc "Create"] -command mktaggo
8150 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8151 bind $top <Key-Return> mktaggo
8152 bind $top <Key-Escape> mktagcan
8153 grid $top.buts.gen $top.buts.can
8154 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8155 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8156 grid $top.buts - -pady 10 -sticky ew
8157 focus $top.tag
8160 proc domktag {} {
8161 global mktagtop env tagids idtags
8163 set id [$mktagtop.sha1 get]
8164 set tag [$mktagtop.tag get]
8165 if {$tag == {}} {
8166 error_popup [mc "No tag name specified"] $mktagtop
8167 return 0
8169 if {[info exists tagids($tag)]} {
8170 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8171 return 0
8173 if {[catch {
8174 exec git tag $tag $id
8175 } err]} {
8176 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8177 return 0
8180 set tagids($tag) $id
8181 lappend idtags($id) $tag
8182 redrawtags $id
8183 addedtag $id
8184 dispneartags 0
8185 run refill_reflist
8186 return 1
8189 proc redrawtags {id} {
8190 global canv linehtag idpos currentid curview cmitlisted
8191 global canvxmax iddrawn circleitem mainheadid circlecolors
8193 if {![commitinview $id $curview]} return
8194 if {![info exists iddrawn($id)]} return
8195 set row [rowofcommit $id]
8196 if {$id eq $mainheadid} {
8197 set ofill yellow
8198 } else {
8199 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8201 $canv itemconf $circleitem($row) -fill $ofill
8202 $canv delete tag.$id
8203 set xt [eval drawtags $id $idpos($id)]
8204 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8205 set text [$canv itemcget $linehtag($id) -text]
8206 set font [$canv itemcget $linehtag($id) -font]
8207 set xr [expr {$xt + [font measure $font $text]}]
8208 if {$xr > $canvxmax} {
8209 set canvxmax $xr
8210 setcanvscroll
8212 if {[info exists currentid] && $currentid == $id} {
8213 make_secsel $id
8217 proc mktagcan {} {
8218 global mktagtop
8220 catch {destroy $mktagtop}
8221 unset mktagtop
8224 proc mktaggo {} {
8225 if {![domktag]} return
8226 mktagcan
8229 proc writecommit {} {
8230 global rowmenuid wrcomtop commitinfo wrcomcmd
8232 set top .writecommit
8233 set wrcomtop $top
8234 catch {destroy $top}
8235 toplevel $top
8236 make_transient $top .
8237 label $top.title -text [mc "Write commit to file"]
8238 grid $top.title - -pady 10
8239 label $top.id -text [mc "ID:"]
8240 entry $top.sha1 -width 40 -relief flat
8241 $top.sha1 insert 0 $rowmenuid
8242 $top.sha1 conf -state readonly
8243 grid $top.id $top.sha1 -sticky w
8244 entry $top.head -width 60 -relief flat
8245 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8246 $top.head conf -state readonly
8247 grid x $top.head -sticky w
8248 label $top.clab -text [mc "Command:"]
8249 entry $top.cmd -width 60 -textvariable wrcomcmd
8250 grid $top.clab $top.cmd -sticky w -pady 10
8251 label $top.flab -text [mc "Output file:"]
8252 entry $top.fname -width 60
8253 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8254 grid $top.flab $top.fname -sticky w
8255 frame $top.buts
8256 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8257 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8258 bind $top <Key-Return> wrcomgo
8259 bind $top <Key-Escape> wrcomcan
8260 grid $top.buts.gen $top.buts.can
8261 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8262 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8263 grid $top.buts - -pady 10 -sticky ew
8264 focus $top.fname
8267 proc wrcomgo {} {
8268 global wrcomtop
8270 set id [$wrcomtop.sha1 get]
8271 set cmd "echo $id | [$wrcomtop.cmd get]"
8272 set fname [$wrcomtop.fname get]
8273 if {[catch {exec sh -c $cmd >$fname &} err]} {
8274 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8276 catch {destroy $wrcomtop}
8277 unset wrcomtop
8280 proc wrcomcan {} {
8281 global wrcomtop
8283 catch {destroy $wrcomtop}
8284 unset wrcomtop
8287 proc mkbranch {} {
8288 global rowmenuid mkbrtop
8290 set top .makebranch
8291 catch {destroy $top}
8292 toplevel $top
8293 make_transient $top .
8294 label $top.title -text [mc "Create new branch"]
8295 grid $top.title - -pady 10
8296 label $top.id -text [mc "ID:"]
8297 entry $top.sha1 -width 40 -relief flat
8298 $top.sha1 insert 0 $rowmenuid
8299 $top.sha1 conf -state readonly
8300 grid $top.id $top.sha1 -sticky w
8301 label $top.nlab -text [mc "Name:"]
8302 entry $top.name -width 40
8303 grid $top.nlab $top.name -sticky w
8304 frame $top.buts
8305 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8306 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8307 bind $top <Key-Return> [list mkbrgo $top]
8308 bind $top <Key-Escape> "catch {destroy $top}"
8309 grid $top.buts.go $top.buts.can
8310 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8311 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8312 grid $top.buts - -pady 10 -sticky ew
8313 focus $top.name
8316 proc mkbrgo {top} {
8317 global headids idheads
8319 set name [$top.name get]
8320 set id [$top.sha1 get]
8321 set cmdargs {}
8322 set old_id {}
8323 if {$name eq {}} {
8324 error_popup [mc "Please specify a name for the new branch"] $top
8325 return
8327 if {[info exists headids($name)]} {
8328 if {![confirm_popup [mc \
8329 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8330 return
8332 set old_id $headids($name)
8333 lappend cmdargs -f
8335 catch {destroy $top}
8336 lappend cmdargs $name $id
8337 nowbusy newbranch
8338 update
8339 if {[catch {
8340 eval exec git branch $cmdargs
8341 } err]} {
8342 notbusy newbranch
8343 error_popup $err
8344 } else {
8345 notbusy newbranch
8346 if {$old_id ne {}} {
8347 movehead $id $name
8348 movedhead $id $name
8349 redrawtags $old_id
8350 redrawtags $id
8351 } else {
8352 set headids($name) $id
8353 lappend idheads($id) $name
8354 addedhead $id $name
8355 redrawtags $id
8357 dispneartags 0
8358 run refill_reflist
8362 proc exec_citool {tool_args {baseid {}}} {
8363 global commitinfo env
8365 set save_env [array get env GIT_AUTHOR_*]
8367 if {$baseid ne {}} {
8368 if {![info exists commitinfo($baseid)]} {
8369 getcommit $baseid
8371 set author [lindex $commitinfo($baseid) 1]
8372 set date [lindex $commitinfo($baseid) 2]
8373 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8374 $author author name email]
8375 && $date ne {}} {
8376 set env(GIT_AUTHOR_NAME) $name
8377 set env(GIT_AUTHOR_EMAIL) $email
8378 set env(GIT_AUTHOR_DATE) $date
8382 eval exec git citool $tool_args &
8384 array unset env GIT_AUTHOR_*
8385 array set env $save_env
8388 proc cherrypick {} {
8389 global rowmenuid curview
8390 global mainhead mainheadid
8392 set oldhead [exec git rev-parse HEAD]
8393 set dheads [descheads $rowmenuid]
8394 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8395 set ok [confirm_popup [mc "Commit %s is already\
8396 included in branch %s -- really re-apply it?" \
8397 [string range $rowmenuid 0 7] $mainhead]]
8398 if {!$ok} return
8400 nowbusy cherrypick [mc "Cherry-picking"]
8401 update
8402 # Unfortunately git-cherry-pick writes stuff to stderr even when
8403 # no error occurs, and exec takes that as an indication of error...
8404 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8405 notbusy cherrypick
8406 if {[regexp -line \
8407 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8408 $err msg fname]} {
8409 error_popup [mc "Cherry-pick failed because of local changes\
8410 to file '%s'.\nPlease commit, reset or stash\
8411 your changes and try again." $fname]
8412 } elseif {[regexp -line \
8413 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8414 $err]} {
8415 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8416 conflict.\nDo you wish to run git citool to\
8417 resolve it?"]]} {
8418 # Force citool to read MERGE_MSG
8419 file delete [file join [gitdir] "GITGUI_MSG"]
8420 exec_citool {} $rowmenuid
8422 } else {
8423 error_popup $err
8425 run updatecommits
8426 return
8428 set newhead [exec git rev-parse HEAD]
8429 if {$newhead eq $oldhead} {
8430 notbusy cherrypick
8431 error_popup [mc "No changes committed"]
8432 return
8434 addnewchild $newhead $oldhead
8435 if {[commitinview $oldhead $curview]} {
8436 # XXX this isn't right if we have a path limit...
8437 insertrow $newhead $oldhead $curview
8438 if {$mainhead ne {}} {
8439 movehead $newhead $mainhead
8440 movedhead $newhead $mainhead
8442 set mainheadid $newhead
8443 redrawtags $oldhead
8444 redrawtags $newhead
8445 selbyid $newhead
8447 notbusy cherrypick
8450 proc resethead {} {
8451 global mainhead rowmenuid confirm_ok resettype
8453 set confirm_ok 0
8454 set w ".confirmreset"
8455 toplevel $w
8456 make_transient $w .
8457 wm title $w [mc "Confirm reset"]
8458 message $w.m -text \
8459 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8460 -justify center -aspect 1000
8461 pack $w.m -side top -fill x -padx 20 -pady 20
8462 frame $w.f -relief sunken -border 2
8463 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8464 grid $w.f.rt -sticky w
8465 set resettype mixed
8466 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8467 -text [mc "Soft: Leave working tree and index untouched"]
8468 grid $w.f.soft -sticky w
8469 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8470 -text [mc "Mixed: Leave working tree untouched, reset index"]
8471 grid $w.f.mixed -sticky w
8472 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8473 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8474 grid $w.f.hard -sticky w
8475 pack $w.f -side top -fill x
8476 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8477 pack $w.ok -side left -fill x -padx 20 -pady 20
8478 button $w.cancel -text [mc Cancel] -command "destroy $w"
8479 bind $w <Key-Escape> [list destroy $w]
8480 pack $w.cancel -side right -fill x -padx 20 -pady 20
8481 bind $w <Visibility> "grab $w; focus $w"
8482 tkwait window $w
8483 if {!$confirm_ok} return
8484 if {[catch {set fd [open \
8485 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8486 error_popup $err
8487 } else {
8488 dohidelocalchanges
8489 filerun $fd [list readresetstat $fd]
8490 nowbusy reset [mc "Resetting"]
8491 selbyid $rowmenuid
8495 proc readresetstat {fd} {
8496 global mainhead mainheadid showlocalchanges rprogcoord
8498 if {[gets $fd line] >= 0} {
8499 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8500 set rprogcoord [expr {1.0 * $m / $n}]
8501 adjustprogress
8503 return 1
8505 set rprogcoord 0
8506 adjustprogress
8507 notbusy reset
8508 if {[catch {close $fd} err]} {
8509 error_popup $err
8511 set oldhead $mainheadid
8512 set newhead [exec git rev-parse HEAD]
8513 if {$newhead ne $oldhead} {
8514 movehead $newhead $mainhead
8515 movedhead $newhead $mainhead
8516 set mainheadid $newhead
8517 redrawtags $oldhead
8518 redrawtags $newhead
8520 if {$showlocalchanges} {
8521 doshowlocalchanges
8523 return 0
8526 # context menu for a head
8527 proc headmenu {x y id head} {
8528 global headmenuid headmenuhead headctxmenu mainhead
8530 stopfinding
8531 set headmenuid $id
8532 set headmenuhead $head
8533 set state normal
8534 if {$head eq $mainhead} {
8535 set state disabled
8537 $headctxmenu entryconfigure 0 -state $state
8538 $headctxmenu entryconfigure 1 -state $state
8539 tk_popup $headctxmenu $x $y
8542 proc cobranch {} {
8543 global headmenuid headmenuhead headids
8544 global showlocalchanges
8546 # check the tree is clean first??
8547 nowbusy checkout [mc "Checking out"]
8548 update
8549 dohidelocalchanges
8550 if {[catch {
8551 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8552 } err]} {
8553 notbusy checkout
8554 error_popup $err
8555 if {$showlocalchanges} {
8556 dodiffindex
8558 } else {
8559 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8563 proc readcheckoutstat {fd newhead newheadid} {
8564 global mainhead mainheadid headids showlocalchanges progresscoords
8565 global viewmainheadid curview
8567 if {[gets $fd line] >= 0} {
8568 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8569 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8570 adjustprogress
8572 return 1
8574 set progresscoords {0 0}
8575 adjustprogress
8576 notbusy checkout
8577 if {[catch {close $fd} err]} {
8578 error_popup $err
8580 set oldmainid $mainheadid
8581 set mainhead $newhead
8582 set mainheadid $newheadid
8583 set viewmainheadid($curview) $newheadid
8584 redrawtags $oldmainid
8585 redrawtags $newheadid
8586 selbyid $newheadid
8587 if {$showlocalchanges} {
8588 dodiffindex
8592 proc rmbranch {} {
8593 global headmenuid headmenuhead mainhead
8594 global idheads
8596 set head $headmenuhead
8597 set id $headmenuid
8598 # this check shouldn't be needed any more...
8599 if {$head eq $mainhead} {
8600 error_popup [mc "Cannot delete the currently checked-out branch"]
8601 return
8603 set dheads [descheads $id]
8604 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8605 # the stuff on this branch isn't on any other branch
8606 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8607 branch.\nReally delete branch %s?" $head $head]]} return
8609 nowbusy rmbranch
8610 update
8611 if {[catch {exec git branch -D $head} err]} {
8612 notbusy rmbranch
8613 error_popup $err
8614 return
8616 removehead $id $head
8617 removedhead $id $head
8618 redrawtags $id
8619 notbusy rmbranch
8620 dispneartags 0
8621 run refill_reflist
8624 # Display a list of tags and heads
8625 proc showrefs {} {
8626 global showrefstop bgcolor fgcolor selectbgcolor
8627 global bglist fglist reflistfilter reflist maincursor
8629 set top .showrefs
8630 set showrefstop $top
8631 if {[winfo exists $top]} {
8632 raise $top
8633 refill_reflist
8634 return
8636 toplevel $top
8637 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8638 make_transient $top .
8639 text $top.list -background $bgcolor -foreground $fgcolor \
8640 -selectbackground $selectbgcolor -font mainfont \
8641 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8642 -width 30 -height 20 -cursor $maincursor \
8643 -spacing1 1 -spacing3 1 -state disabled
8644 $top.list tag configure highlight -background $selectbgcolor
8645 lappend bglist $top.list
8646 lappend fglist $top.list
8647 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8648 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8649 grid $top.list $top.ysb -sticky nsew
8650 grid $top.xsb x -sticky ew
8651 frame $top.f
8652 label $top.f.l -text "[mc "Filter"]: "
8653 entry $top.f.e -width 20 -textvariable reflistfilter
8654 set reflistfilter "*"
8655 trace add variable reflistfilter write reflistfilter_change
8656 pack $top.f.e -side right -fill x -expand 1
8657 pack $top.f.l -side left
8658 grid $top.f - -sticky ew -pady 2
8659 button $top.close -command [list destroy $top] -text [mc "Close"]
8660 bind $top <Key-Escape> [list destroy $top]
8661 grid $top.close -
8662 grid columnconfigure $top 0 -weight 1
8663 grid rowconfigure $top 0 -weight 1
8664 bind $top.list <1> {break}
8665 bind $top.list <B1-Motion> {break}
8666 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8667 set reflist {}
8668 refill_reflist
8671 proc sel_reflist {w x y} {
8672 global showrefstop reflist headids tagids otherrefids
8674 if {![winfo exists $showrefstop]} return
8675 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8676 set ref [lindex $reflist [expr {$l-1}]]
8677 set n [lindex $ref 0]
8678 switch -- [lindex $ref 1] {
8679 "H" {selbyid $headids($n)}
8680 "T" {selbyid $tagids($n)}
8681 "o" {selbyid $otherrefids($n)}
8683 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8686 proc unsel_reflist {} {
8687 global showrefstop
8689 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8690 $showrefstop.list tag remove highlight 0.0 end
8693 proc reflistfilter_change {n1 n2 op} {
8694 global reflistfilter
8696 after cancel refill_reflist
8697 after 200 refill_reflist
8700 proc refill_reflist {} {
8701 global reflist reflistfilter showrefstop headids tagids otherrefids
8702 global curview
8704 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8705 set refs {}
8706 foreach n [array names headids] {
8707 if {[string match $reflistfilter $n]} {
8708 if {[commitinview $headids($n) $curview]} {
8709 lappend refs [list $n H]
8710 } else {
8711 interestedin $headids($n) {run refill_reflist}
8715 foreach n [array names tagids] {
8716 if {[string match $reflistfilter $n]} {
8717 if {[commitinview $tagids($n) $curview]} {
8718 lappend refs [list $n T]
8719 } else {
8720 interestedin $tagids($n) {run refill_reflist}
8724 foreach n [array names otherrefids] {
8725 if {[string match $reflistfilter $n]} {
8726 if {[commitinview $otherrefids($n) $curview]} {
8727 lappend refs [list $n o]
8728 } else {
8729 interestedin $otherrefids($n) {run refill_reflist}
8733 set refs [lsort -index 0 $refs]
8734 if {$refs eq $reflist} return
8736 # Update the contents of $showrefstop.list according to the
8737 # differences between $reflist (old) and $refs (new)
8738 $showrefstop.list conf -state normal
8739 $showrefstop.list insert end "\n"
8740 set i 0
8741 set j 0
8742 while {$i < [llength $reflist] || $j < [llength $refs]} {
8743 if {$i < [llength $reflist]} {
8744 if {$j < [llength $refs]} {
8745 set cmp [string compare [lindex $reflist $i 0] \
8746 [lindex $refs $j 0]]
8747 if {$cmp == 0} {
8748 set cmp [string compare [lindex $reflist $i 1] \
8749 [lindex $refs $j 1]]
8751 } else {
8752 set cmp -1
8754 } else {
8755 set cmp 1
8757 switch -- $cmp {
8758 -1 {
8759 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8760 incr i
8763 incr i
8764 incr j
8767 set l [expr {$j + 1}]
8768 $showrefstop.list image create $l.0 -align baseline \
8769 -image reficon-[lindex $refs $j 1] -padx 2
8770 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8771 incr j
8775 set reflist $refs
8776 # delete last newline
8777 $showrefstop.list delete end-2c end-1c
8778 $showrefstop.list conf -state disabled
8781 # Stuff for finding nearby tags
8782 proc getallcommits {} {
8783 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8784 global idheads idtags idotherrefs allparents tagobjid
8786 if {![info exists allcommits]} {
8787 set nextarc 0
8788 set allcommits 0
8789 set seeds {}
8790 set allcwait 0
8791 set cachedarcs 0
8792 set allccache [file join [gitdir] "gitk.cache"]
8793 if {![catch {
8794 set f [open $allccache r]
8795 set allcwait 1
8796 getcache $f
8797 }]} return
8800 if {$allcwait} {
8801 return
8803 set cmd [list | git rev-list --parents]
8804 set allcupdate [expr {$seeds ne {}}]
8805 if {!$allcupdate} {
8806 set ids "--all"
8807 } else {
8808 set refs [concat [array names idheads] [array names idtags] \
8809 [array names idotherrefs]]
8810 set ids {}
8811 set tagobjs {}
8812 foreach name [array names tagobjid] {
8813 lappend tagobjs $tagobjid($name)
8815 foreach id [lsort -unique $refs] {
8816 if {![info exists allparents($id)] &&
8817 [lsearch -exact $tagobjs $id] < 0} {
8818 lappend ids $id
8821 if {$ids ne {}} {
8822 foreach id $seeds {
8823 lappend ids "^$id"
8827 if {$ids ne {}} {
8828 set fd [open [concat $cmd $ids] r]
8829 fconfigure $fd -blocking 0
8830 incr allcommits
8831 nowbusy allcommits
8832 filerun $fd [list getallclines $fd]
8833 } else {
8834 dispneartags 0
8838 # Since most commits have 1 parent and 1 child, we group strings of
8839 # such commits into "arcs" joining branch/merge points (BMPs), which
8840 # are commits that either don't have 1 parent or don't have 1 child.
8842 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8843 # arcout(id) - outgoing arcs for BMP
8844 # arcids(a) - list of IDs on arc including end but not start
8845 # arcstart(a) - BMP ID at start of arc
8846 # arcend(a) - BMP ID at end of arc
8847 # growing(a) - arc a is still growing
8848 # arctags(a) - IDs out of arcids (excluding end) that have tags
8849 # archeads(a) - IDs out of arcids (excluding end) that have heads
8850 # The start of an arc is at the descendent end, so "incoming" means
8851 # coming from descendents, and "outgoing" means going towards ancestors.
8853 proc getallclines {fd} {
8854 global allparents allchildren idtags idheads nextarc
8855 global arcnos arcids arctags arcout arcend arcstart archeads growing
8856 global seeds allcommits cachedarcs allcupdate
8858 set nid 0
8859 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8860 set id [lindex $line 0]
8861 if {[info exists allparents($id)]} {
8862 # seen it already
8863 continue
8865 set cachedarcs 0
8866 set olds [lrange $line 1 end]
8867 set allparents($id) $olds
8868 if {![info exists allchildren($id)]} {
8869 set allchildren($id) {}
8870 set arcnos($id) {}
8871 lappend seeds $id
8872 } else {
8873 set a $arcnos($id)
8874 if {[llength $olds] == 1 && [llength $a] == 1} {
8875 lappend arcids($a) $id
8876 if {[info exists idtags($id)]} {
8877 lappend arctags($a) $id
8879 if {[info exists idheads($id)]} {
8880 lappend archeads($a) $id
8882 if {[info exists allparents($olds)]} {
8883 # seen parent already
8884 if {![info exists arcout($olds)]} {
8885 splitarc $olds
8887 lappend arcids($a) $olds
8888 set arcend($a) $olds
8889 unset growing($a)
8891 lappend allchildren($olds) $id
8892 lappend arcnos($olds) $a
8893 continue
8896 foreach a $arcnos($id) {
8897 lappend arcids($a) $id
8898 set arcend($a) $id
8899 unset growing($a)
8902 set ao {}
8903 foreach p $olds {
8904 lappend allchildren($p) $id
8905 set a [incr nextarc]
8906 set arcstart($a) $id
8907 set archeads($a) {}
8908 set arctags($a) {}
8909 set archeads($a) {}
8910 set arcids($a) {}
8911 lappend ao $a
8912 set growing($a) 1
8913 if {[info exists allparents($p)]} {
8914 # seen it already, may need to make a new branch
8915 if {![info exists arcout($p)]} {
8916 splitarc $p
8918 lappend arcids($a) $p
8919 set arcend($a) $p
8920 unset growing($a)
8922 lappend arcnos($p) $a
8924 set arcout($id) $ao
8926 if {$nid > 0} {
8927 global cached_dheads cached_dtags cached_atags
8928 catch {unset cached_dheads}
8929 catch {unset cached_dtags}
8930 catch {unset cached_atags}
8932 if {![eof $fd]} {
8933 return [expr {$nid >= 1000? 2: 1}]
8935 set cacheok 1
8936 if {[catch {
8937 fconfigure $fd -blocking 1
8938 close $fd
8939 } err]} {
8940 # got an error reading the list of commits
8941 # if we were updating, try rereading the whole thing again
8942 if {$allcupdate} {
8943 incr allcommits -1
8944 dropcache $err
8945 return
8947 error_popup "[mc "Error reading commit topology information;\
8948 branch and preceding/following tag information\
8949 will be incomplete."]\n($err)"
8950 set cacheok 0
8952 if {[incr allcommits -1] == 0} {
8953 notbusy allcommits
8954 if {$cacheok} {
8955 run savecache
8958 dispneartags 0
8959 return 0
8962 proc recalcarc {a} {
8963 global arctags archeads arcids idtags idheads
8965 set at {}
8966 set ah {}
8967 foreach id [lrange $arcids($a) 0 end-1] {
8968 if {[info exists idtags($id)]} {
8969 lappend at $id
8971 if {[info exists idheads($id)]} {
8972 lappend ah $id
8975 set arctags($a) $at
8976 set archeads($a) $ah
8979 proc splitarc {p} {
8980 global arcnos arcids nextarc arctags archeads idtags idheads
8981 global arcstart arcend arcout allparents growing
8983 set a $arcnos($p)
8984 if {[llength $a] != 1} {
8985 puts "oops splitarc called but [llength $a] arcs already"
8986 return
8988 set a [lindex $a 0]
8989 set i [lsearch -exact $arcids($a) $p]
8990 if {$i < 0} {
8991 puts "oops splitarc $p not in arc $a"
8992 return
8994 set na [incr nextarc]
8995 if {[info exists arcend($a)]} {
8996 set arcend($na) $arcend($a)
8997 } else {
8998 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8999 set j [lsearch -exact $arcnos($l) $a]
9000 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9002 set tail [lrange $arcids($a) [expr {$i+1}] end]
9003 set arcids($a) [lrange $arcids($a) 0 $i]
9004 set arcend($a) $p
9005 set arcstart($na) $p
9006 set arcout($p) $na
9007 set arcids($na) $tail
9008 if {[info exists growing($a)]} {
9009 set growing($na) 1
9010 unset growing($a)
9013 foreach id $tail {
9014 if {[llength $arcnos($id)] == 1} {
9015 set arcnos($id) $na
9016 } else {
9017 set j [lsearch -exact $arcnos($id) $a]
9018 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9022 # reconstruct tags and heads lists
9023 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9024 recalcarc $a
9025 recalcarc $na
9026 } else {
9027 set arctags($na) {}
9028 set archeads($na) {}
9032 # Update things for a new commit added that is a child of one
9033 # existing commit. Used when cherry-picking.
9034 proc addnewchild {id p} {
9035 global allparents allchildren idtags nextarc
9036 global arcnos arcids arctags arcout arcend arcstart archeads growing
9037 global seeds allcommits
9039 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9040 set allparents($id) [list $p]
9041 set allchildren($id) {}
9042 set arcnos($id) {}
9043 lappend seeds $id
9044 lappend allchildren($p) $id
9045 set a [incr nextarc]
9046 set arcstart($a) $id
9047 set archeads($a) {}
9048 set arctags($a) {}
9049 set arcids($a) [list $p]
9050 set arcend($a) $p
9051 if {![info exists arcout($p)]} {
9052 splitarc $p
9054 lappend arcnos($p) $a
9055 set arcout($id) [list $a]
9058 # This implements a cache for the topology information.
9059 # The cache saves, for each arc, the start and end of the arc,
9060 # the ids on the arc, and the outgoing arcs from the end.
9061 proc readcache {f} {
9062 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9063 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9064 global allcwait
9066 set a $nextarc
9067 set lim $cachedarcs
9068 if {$lim - $a > 500} {
9069 set lim [expr {$a + 500}]
9071 if {[catch {
9072 if {$a == $lim} {
9073 # finish reading the cache and setting up arctags, etc.
9074 set line [gets $f]
9075 if {$line ne "1"} {error "bad final version"}
9076 close $f
9077 foreach id [array names idtags] {
9078 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9079 [llength $allparents($id)] == 1} {
9080 set a [lindex $arcnos($id) 0]
9081 if {$arctags($a) eq {}} {
9082 recalcarc $a
9086 foreach id [array names idheads] {
9087 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9088 [llength $allparents($id)] == 1} {
9089 set a [lindex $arcnos($id) 0]
9090 if {$archeads($a) eq {}} {
9091 recalcarc $a
9095 foreach id [lsort -unique $possible_seeds] {
9096 if {$arcnos($id) eq {}} {
9097 lappend seeds $id
9100 set allcwait 0
9101 } else {
9102 while {[incr a] <= $lim} {
9103 set line [gets $f]
9104 if {[llength $line] != 3} {error "bad line"}
9105 set s [lindex $line 0]
9106 set arcstart($a) $s
9107 lappend arcout($s) $a
9108 if {![info exists arcnos($s)]} {
9109 lappend possible_seeds $s
9110 set arcnos($s) {}
9112 set e [lindex $line 1]
9113 if {$e eq {}} {
9114 set growing($a) 1
9115 } else {
9116 set arcend($a) $e
9117 if {![info exists arcout($e)]} {
9118 set arcout($e) {}
9121 set arcids($a) [lindex $line 2]
9122 foreach id $arcids($a) {
9123 lappend allparents($s) $id
9124 set s $id
9125 lappend arcnos($id) $a
9127 if {![info exists allparents($s)]} {
9128 set allparents($s) {}
9130 set arctags($a) {}
9131 set archeads($a) {}
9133 set nextarc [expr {$a - 1}]
9135 } err]} {
9136 dropcache $err
9137 return 0
9139 if {!$allcwait} {
9140 getallcommits
9142 return $allcwait
9145 proc getcache {f} {
9146 global nextarc cachedarcs possible_seeds
9148 if {[catch {
9149 set line [gets $f]
9150 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9151 # make sure it's an integer
9152 set cachedarcs [expr {int([lindex $line 1])}]
9153 if {$cachedarcs < 0} {error "bad number of arcs"}
9154 set nextarc 0
9155 set possible_seeds {}
9156 run readcache $f
9157 } err]} {
9158 dropcache $err
9160 return 0
9163 proc dropcache {err} {
9164 global allcwait nextarc cachedarcs seeds
9166 #puts "dropping cache ($err)"
9167 foreach v {arcnos arcout arcids arcstart arcend growing \
9168 arctags archeads allparents allchildren} {
9169 global $v
9170 catch {unset $v}
9172 set allcwait 0
9173 set nextarc 0
9174 set cachedarcs 0
9175 set seeds {}
9176 getallcommits
9179 proc writecache {f} {
9180 global cachearc cachedarcs allccache
9181 global arcstart arcend arcnos arcids arcout
9183 set a $cachearc
9184 set lim $cachedarcs
9185 if {$lim - $a > 1000} {
9186 set lim [expr {$a + 1000}]
9188 if {[catch {
9189 while {[incr a] <= $lim} {
9190 if {[info exists arcend($a)]} {
9191 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9192 } else {
9193 puts $f [list $arcstart($a) {} $arcids($a)]
9196 } err]} {
9197 catch {close $f}
9198 catch {file delete $allccache}
9199 #puts "writing cache failed ($err)"
9200 return 0
9202 set cachearc [expr {$a - 1}]
9203 if {$a > $cachedarcs} {
9204 puts $f "1"
9205 close $f
9206 return 0
9208 return 1
9211 proc savecache {} {
9212 global nextarc cachedarcs cachearc allccache
9214 if {$nextarc == $cachedarcs} return
9215 set cachearc 0
9216 set cachedarcs $nextarc
9217 catch {
9218 set f [open $allccache w]
9219 puts $f [list 1 $cachedarcs]
9220 run writecache $f
9224 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9225 # or 0 if neither is true.
9226 proc anc_or_desc {a b} {
9227 global arcout arcstart arcend arcnos cached_isanc
9229 if {$arcnos($a) eq $arcnos($b)} {
9230 # Both are on the same arc(s); either both are the same BMP,
9231 # or if one is not a BMP, the other is also not a BMP or is
9232 # the BMP at end of the arc (and it only has 1 incoming arc).
9233 # Or both can be BMPs with no incoming arcs.
9234 if {$a eq $b || $arcnos($a) eq {}} {
9235 return 0
9237 # assert {[llength $arcnos($a)] == 1}
9238 set arc [lindex $arcnos($a) 0]
9239 set i [lsearch -exact $arcids($arc) $a]
9240 set j [lsearch -exact $arcids($arc) $b]
9241 if {$i < 0 || $i > $j} {
9242 return 1
9243 } else {
9244 return -1
9248 if {![info exists arcout($a)]} {
9249 set arc [lindex $arcnos($a) 0]
9250 if {[info exists arcend($arc)]} {
9251 set aend $arcend($arc)
9252 } else {
9253 set aend {}
9255 set a $arcstart($arc)
9256 } else {
9257 set aend $a
9259 if {![info exists arcout($b)]} {
9260 set arc [lindex $arcnos($b) 0]
9261 if {[info exists arcend($arc)]} {
9262 set bend $arcend($arc)
9263 } else {
9264 set bend {}
9266 set b $arcstart($arc)
9267 } else {
9268 set bend $b
9270 if {$a eq $bend} {
9271 return 1
9273 if {$b eq $aend} {
9274 return -1
9276 if {[info exists cached_isanc($a,$bend)]} {
9277 if {$cached_isanc($a,$bend)} {
9278 return 1
9281 if {[info exists cached_isanc($b,$aend)]} {
9282 if {$cached_isanc($b,$aend)} {
9283 return -1
9285 if {[info exists cached_isanc($a,$bend)]} {
9286 return 0
9290 set todo [list $a $b]
9291 set anc($a) a
9292 set anc($b) b
9293 for {set i 0} {$i < [llength $todo]} {incr i} {
9294 set x [lindex $todo $i]
9295 if {$anc($x) eq {}} {
9296 continue
9298 foreach arc $arcnos($x) {
9299 set xd $arcstart($arc)
9300 if {$xd eq $bend} {
9301 set cached_isanc($a,$bend) 1
9302 set cached_isanc($b,$aend) 0
9303 return 1
9304 } elseif {$xd eq $aend} {
9305 set cached_isanc($b,$aend) 1
9306 set cached_isanc($a,$bend) 0
9307 return -1
9309 if {![info exists anc($xd)]} {
9310 set anc($xd) $anc($x)
9311 lappend todo $xd
9312 } elseif {$anc($xd) ne $anc($x)} {
9313 set anc($xd) {}
9317 set cached_isanc($a,$bend) 0
9318 set cached_isanc($b,$aend) 0
9319 return 0
9322 # This identifies whether $desc has an ancestor that is
9323 # a growing tip of the graph and which is not an ancestor of $anc
9324 # and returns 0 if so and 1 if not.
9325 # If we subsequently discover a tag on such a growing tip, and that
9326 # turns out to be a descendent of $anc (which it could, since we
9327 # don't necessarily see children before parents), then $desc
9328 # isn't a good choice to display as a descendent tag of
9329 # $anc (since it is the descendent of another tag which is
9330 # a descendent of $anc). Similarly, $anc isn't a good choice to
9331 # display as a ancestor tag of $desc.
9333 proc is_certain {desc anc} {
9334 global arcnos arcout arcstart arcend growing problems
9336 set certain {}
9337 if {[llength $arcnos($anc)] == 1} {
9338 # tags on the same arc are certain
9339 if {$arcnos($desc) eq $arcnos($anc)} {
9340 return 1
9342 if {![info exists arcout($anc)]} {
9343 # if $anc is partway along an arc, use the start of the arc instead
9344 set a [lindex $arcnos($anc) 0]
9345 set anc $arcstart($a)
9348 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9349 set x $desc
9350 } else {
9351 set a [lindex $arcnos($desc) 0]
9352 set x $arcend($a)
9354 if {$x == $anc} {
9355 return 1
9357 set anclist [list $x]
9358 set dl($x) 1
9359 set nnh 1
9360 set ngrowanc 0
9361 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9362 set x [lindex $anclist $i]
9363 if {$dl($x)} {
9364 incr nnh -1
9366 set done($x) 1
9367 foreach a $arcout($x) {
9368 if {[info exists growing($a)]} {
9369 if {![info exists growanc($x)] && $dl($x)} {
9370 set growanc($x) 1
9371 incr ngrowanc
9373 } else {
9374 set y $arcend($a)
9375 if {[info exists dl($y)]} {
9376 if {$dl($y)} {
9377 if {!$dl($x)} {
9378 set dl($y) 0
9379 if {![info exists done($y)]} {
9380 incr nnh -1
9382 if {[info exists growanc($x)]} {
9383 incr ngrowanc -1
9385 set xl [list $y]
9386 for {set k 0} {$k < [llength $xl]} {incr k} {
9387 set z [lindex $xl $k]
9388 foreach c $arcout($z) {
9389 if {[info exists arcend($c)]} {
9390 set v $arcend($c)
9391 if {[info exists dl($v)] && $dl($v)} {
9392 set dl($v) 0
9393 if {![info exists done($v)]} {
9394 incr nnh -1
9396 if {[info exists growanc($v)]} {
9397 incr ngrowanc -1
9399 lappend xl $v
9406 } elseif {$y eq $anc || !$dl($x)} {
9407 set dl($y) 0
9408 lappend anclist $y
9409 } else {
9410 set dl($y) 1
9411 lappend anclist $y
9412 incr nnh
9417 foreach x [array names growanc] {
9418 if {$dl($x)} {
9419 return 0
9421 return 0
9423 return 1
9426 proc validate_arctags {a} {
9427 global arctags idtags
9429 set i -1
9430 set na $arctags($a)
9431 foreach id $arctags($a) {
9432 incr i
9433 if {![info exists idtags($id)]} {
9434 set na [lreplace $na $i $i]
9435 incr i -1
9438 set arctags($a) $na
9441 proc validate_archeads {a} {
9442 global archeads idheads
9444 set i -1
9445 set na $archeads($a)
9446 foreach id $archeads($a) {
9447 incr i
9448 if {![info exists idheads($id)]} {
9449 set na [lreplace $na $i $i]
9450 incr i -1
9453 set archeads($a) $na
9456 # Return the list of IDs that have tags that are descendents of id,
9457 # ignoring IDs that are descendents of IDs already reported.
9458 proc desctags {id} {
9459 global arcnos arcstart arcids arctags idtags allparents
9460 global growing cached_dtags
9462 if {![info exists allparents($id)]} {
9463 return {}
9465 set t1 [clock clicks -milliseconds]
9466 set argid $id
9467 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9468 # part-way along an arc; check that arc first
9469 set a [lindex $arcnos($id) 0]
9470 if {$arctags($a) ne {}} {
9471 validate_arctags $a
9472 set i [lsearch -exact $arcids($a) $id]
9473 set tid {}
9474 foreach t $arctags($a) {
9475 set j [lsearch -exact $arcids($a) $t]
9476 if {$j >= $i} break
9477 set tid $t
9479 if {$tid ne {}} {
9480 return $tid
9483 set id $arcstart($a)
9484 if {[info exists idtags($id)]} {
9485 return $id
9488 if {[info exists cached_dtags($id)]} {
9489 return $cached_dtags($id)
9492 set origid $id
9493 set todo [list $id]
9494 set queued($id) 1
9495 set nc 1
9496 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9497 set id [lindex $todo $i]
9498 set done($id) 1
9499 set ta [info exists hastaggedancestor($id)]
9500 if {!$ta} {
9501 incr nc -1
9503 # ignore tags on starting node
9504 if {!$ta && $i > 0} {
9505 if {[info exists idtags($id)]} {
9506 set tagloc($id) $id
9507 set ta 1
9508 } elseif {[info exists cached_dtags($id)]} {
9509 set tagloc($id) $cached_dtags($id)
9510 set ta 1
9513 foreach a $arcnos($id) {
9514 set d $arcstart($a)
9515 if {!$ta && $arctags($a) ne {}} {
9516 validate_arctags $a
9517 if {$arctags($a) ne {}} {
9518 lappend tagloc($id) [lindex $arctags($a) end]
9521 if {$ta || $arctags($a) ne {}} {
9522 set tomark [list $d]
9523 for {set j 0} {$j < [llength $tomark]} {incr j} {
9524 set dd [lindex $tomark $j]
9525 if {![info exists hastaggedancestor($dd)]} {
9526 if {[info exists done($dd)]} {
9527 foreach b $arcnos($dd) {
9528 lappend tomark $arcstart($b)
9530 if {[info exists tagloc($dd)]} {
9531 unset tagloc($dd)
9533 } elseif {[info exists queued($dd)]} {
9534 incr nc -1
9536 set hastaggedancestor($dd) 1
9540 if {![info exists queued($d)]} {
9541 lappend todo $d
9542 set queued($d) 1
9543 if {![info exists hastaggedancestor($d)]} {
9544 incr nc
9549 set tags {}
9550 foreach id [array names tagloc] {
9551 if {![info exists hastaggedancestor($id)]} {
9552 foreach t $tagloc($id) {
9553 if {[lsearch -exact $tags $t] < 0} {
9554 lappend tags $t
9559 set t2 [clock clicks -milliseconds]
9560 set loopix $i
9562 # remove tags that are descendents of other tags
9563 for {set i 0} {$i < [llength $tags]} {incr i} {
9564 set a [lindex $tags $i]
9565 for {set j 0} {$j < $i} {incr j} {
9566 set b [lindex $tags $j]
9567 set r [anc_or_desc $a $b]
9568 if {$r == 1} {
9569 set tags [lreplace $tags $j $j]
9570 incr j -1
9571 incr i -1
9572 } elseif {$r == -1} {
9573 set tags [lreplace $tags $i $i]
9574 incr i -1
9575 break
9580 if {[array names growing] ne {}} {
9581 # graph isn't finished, need to check if any tag could get
9582 # eclipsed by another tag coming later. Simply ignore any
9583 # tags that could later get eclipsed.
9584 set ctags {}
9585 foreach t $tags {
9586 if {[is_certain $t $origid]} {
9587 lappend ctags $t
9590 if {$tags eq $ctags} {
9591 set cached_dtags($origid) $tags
9592 } else {
9593 set tags $ctags
9595 } else {
9596 set cached_dtags($origid) $tags
9598 set t3 [clock clicks -milliseconds]
9599 if {0 && $t3 - $t1 >= 100} {
9600 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9601 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9603 return $tags
9606 proc anctags {id} {
9607 global arcnos arcids arcout arcend arctags idtags allparents
9608 global growing cached_atags
9610 if {![info exists allparents($id)]} {
9611 return {}
9613 set t1 [clock clicks -milliseconds]
9614 set argid $id
9615 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9616 # part-way along an arc; check that arc first
9617 set a [lindex $arcnos($id) 0]
9618 if {$arctags($a) ne {}} {
9619 validate_arctags $a
9620 set i [lsearch -exact $arcids($a) $id]
9621 foreach t $arctags($a) {
9622 set j [lsearch -exact $arcids($a) $t]
9623 if {$j > $i} {
9624 return $t
9628 if {![info exists arcend($a)]} {
9629 return {}
9631 set id $arcend($a)
9632 if {[info exists idtags($id)]} {
9633 return $id
9636 if {[info exists cached_atags($id)]} {
9637 return $cached_atags($id)
9640 set origid $id
9641 set todo [list $id]
9642 set queued($id) 1
9643 set taglist {}
9644 set nc 1
9645 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9646 set id [lindex $todo $i]
9647 set done($id) 1
9648 set td [info exists hastaggeddescendent($id)]
9649 if {!$td} {
9650 incr nc -1
9652 # ignore tags on starting node
9653 if {!$td && $i > 0} {
9654 if {[info exists idtags($id)]} {
9655 set tagloc($id) $id
9656 set td 1
9657 } elseif {[info exists cached_atags($id)]} {
9658 set tagloc($id) $cached_atags($id)
9659 set td 1
9662 foreach a $arcout($id) {
9663 if {!$td && $arctags($a) ne {}} {
9664 validate_arctags $a
9665 if {$arctags($a) ne {}} {
9666 lappend tagloc($id) [lindex $arctags($a) 0]
9669 if {![info exists arcend($a)]} continue
9670 set d $arcend($a)
9671 if {$td || $arctags($a) ne {}} {
9672 set tomark [list $d]
9673 for {set j 0} {$j < [llength $tomark]} {incr j} {
9674 set dd [lindex $tomark $j]
9675 if {![info exists hastaggeddescendent($dd)]} {
9676 if {[info exists done($dd)]} {
9677 foreach b $arcout($dd) {
9678 if {[info exists arcend($b)]} {
9679 lappend tomark $arcend($b)
9682 if {[info exists tagloc($dd)]} {
9683 unset tagloc($dd)
9685 } elseif {[info exists queued($dd)]} {
9686 incr nc -1
9688 set hastaggeddescendent($dd) 1
9692 if {![info exists queued($d)]} {
9693 lappend todo $d
9694 set queued($d) 1
9695 if {![info exists hastaggeddescendent($d)]} {
9696 incr nc
9701 set t2 [clock clicks -milliseconds]
9702 set loopix $i
9703 set tags {}
9704 foreach id [array names tagloc] {
9705 if {![info exists hastaggeddescendent($id)]} {
9706 foreach t $tagloc($id) {
9707 if {[lsearch -exact $tags $t] < 0} {
9708 lappend tags $t
9714 # remove tags that are ancestors of other tags
9715 for {set i 0} {$i < [llength $tags]} {incr i} {
9716 set a [lindex $tags $i]
9717 for {set j 0} {$j < $i} {incr j} {
9718 set b [lindex $tags $j]
9719 set r [anc_or_desc $a $b]
9720 if {$r == -1} {
9721 set tags [lreplace $tags $j $j]
9722 incr j -1
9723 incr i -1
9724 } elseif {$r == 1} {
9725 set tags [lreplace $tags $i $i]
9726 incr i -1
9727 break
9732 if {[array names growing] ne {}} {
9733 # graph isn't finished, need to check if any tag could get
9734 # eclipsed by another tag coming later. Simply ignore any
9735 # tags that could later get eclipsed.
9736 set ctags {}
9737 foreach t $tags {
9738 if {[is_certain $origid $t]} {
9739 lappend ctags $t
9742 if {$tags eq $ctags} {
9743 set cached_atags($origid) $tags
9744 } else {
9745 set tags $ctags
9747 } else {
9748 set cached_atags($origid) $tags
9750 set t3 [clock clicks -milliseconds]
9751 if {0 && $t3 - $t1 >= 100} {
9752 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9753 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9755 return $tags
9758 # Return the list of IDs that have heads that are descendents of id,
9759 # including id itself if it has a head.
9760 proc descheads {id} {
9761 global arcnos arcstart arcids archeads idheads cached_dheads
9762 global allparents
9764 if {![info exists allparents($id)]} {
9765 return {}
9767 set aret {}
9768 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9769 # part-way along an arc; check it first
9770 set a [lindex $arcnos($id) 0]
9771 if {$archeads($a) ne {}} {
9772 validate_archeads $a
9773 set i [lsearch -exact $arcids($a) $id]
9774 foreach t $archeads($a) {
9775 set j [lsearch -exact $arcids($a) $t]
9776 if {$j > $i} break
9777 lappend aret $t
9780 set id $arcstart($a)
9782 set origid $id
9783 set todo [list $id]
9784 set seen($id) 1
9785 set ret {}
9786 for {set i 0} {$i < [llength $todo]} {incr i} {
9787 set id [lindex $todo $i]
9788 if {[info exists cached_dheads($id)]} {
9789 set ret [concat $ret $cached_dheads($id)]
9790 } else {
9791 if {[info exists idheads($id)]} {
9792 lappend ret $id
9794 foreach a $arcnos($id) {
9795 if {$archeads($a) ne {}} {
9796 validate_archeads $a
9797 if {$archeads($a) ne {}} {
9798 set ret [concat $ret $archeads($a)]
9801 set d $arcstart($a)
9802 if {![info exists seen($d)]} {
9803 lappend todo $d
9804 set seen($d) 1
9809 set ret [lsort -unique $ret]
9810 set cached_dheads($origid) $ret
9811 return [concat $ret $aret]
9814 proc addedtag {id} {
9815 global arcnos arcout cached_dtags cached_atags
9817 if {![info exists arcnos($id)]} return
9818 if {![info exists arcout($id)]} {
9819 recalcarc [lindex $arcnos($id) 0]
9821 catch {unset cached_dtags}
9822 catch {unset cached_atags}
9825 proc addedhead {hid head} {
9826 global arcnos arcout cached_dheads
9828 if {![info exists arcnos($hid)]} return
9829 if {![info exists arcout($hid)]} {
9830 recalcarc [lindex $arcnos($hid) 0]
9832 catch {unset cached_dheads}
9835 proc removedhead {hid head} {
9836 global cached_dheads
9838 catch {unset cached_dheads}
9841 proc movedhead {hid head} {
9842 global arcnos arcout cached_dheads
9844 if {![info exists arcnos($hid)]} return
9845 if {![info exists arcout($hid)]} {
9846 recalcarc [lindex $arcnos($hid) 0]
9848 catch {unset cached_dheads}
9851 proc changedrefs {} {
9852 global cached_dheads cached_dtags cached_atags
9853 global arctags archeads arcnos arcout idheads idtags
9855 foreach id [concat [array names idheads] [array names idtags]] {
9856 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9857 set a [lindex $arcnos($id) 0]
9858 if {![info exists donearc($a)]} {
9859 recalcarc $a
9860 set donearc($a) 1
9864 catch {unset cached_dtags}
9865 catch {unset cached_atags}
9866 catch {unset cached_dheads}
9869 proc rereadrefs {} {
9870 global idtags idheads idotherrefs mainheadid
9872 set refids [concat [array names idtags] \
9873 [array names idheads] [array names idotherrefs]]
9874 foreach id $refids {
9875 if {![info exists ref($id)]} {
9876 set ref($id) [listrefs $id]
9879 set oldmainhead $mainheadid
9880 readrefs
9881 changedrefs
9882 set refids [lsort -unique [concat $refids [array names idtags] \
9883 [array names idheads] [array names idotherrefs]]]
9884 foreach id $refids {
9885 set v [listrefs $id]
9886 if {![info exists ref($id)] || $ref($id) != $v} {
9887 redrawtags $id
9890 if {$oldmainhead ne $mainheadid} {
9891 redrawtags $oldmainhead
9892 redrawtags $mainheadid
9894 run refill_reflist
9897 proc listrefs {id} {
9898 global idtags idheads idotherrefs
9900 set x {}
9901 if {[info exists idtags($id)]} {
9902 set x $idtags($id)
9904 set y {}
9905 if {[info exists idheads($id)]} {
9906 set y $idheads($id)
9908 set z {}
9909 if {[info exists idotherrefs($id)]} {
9910 set z $idotherrefs($id)
9912 return [list $x $y $z]
9915 proc showtag {tag isnew} {
9916 global ctext tagcontents tagids linknum tagobjid
9918 if {$isnew} {
9919 addtohistory [list showtag $tag 0]
9921 $ctext conf -state normal
9922 clear_ctext
9923 settabs 0
9924 set linknum 0
9925 if {![info exists tagcontents($tag)]} {
9926 catch {
9927 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9930 if {[info exists tagcontents($tag)]} {
9931 set text $tagcontents($tag)
9932 } else {
9933 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9935 appendwithlinks $text {}
9936 $ctext conf -state disabled
9937 init_flist {}
9940 proc doquit {} {
9941 global stopped
9942 global gitktmpdir
9944 set stopped 100
9945 savestuff .
9946 destroy .
9948 if {[info exists gitktmpdir]} {
9949 catch {file delete -force $gitktmpdir}
9953 proc mkfontdisp {font top which} {
9954 global fontattr fontpref $font
9956 set fontpref($font) [set $font]
9957 button $top.${font}but -text $which -font optionfont \
9958 -command [list choosefont $font $which]
9959 label $top.$font -relief flat -font $font \
9960 -text $fontattr($font,family) -justify left
9961 grid x $top.${font}but $top.$font -sticky w
9964 proc choosefont {font which} {
9965 global fontparam fontlist fonttop fontattr
9966 global prefstop
9968 set fontparam(which) $which
9969 set fontparam(font) $font
9970 set fontparam(family) [font actual $font -family]
9971 set fontparam(size) $fontattr($font,size)
9972 set fontparam(weight) $fontattr($font,weight)
9973 set fontparam(slant) $fontattr($font,slant)
9974 set top .gitkfont
9975 set fonttop $top
9976 if {![winfo exists $top]} {
9977 font create sample
9978 eval font config sample [font actual $font]
9979 toplevel $top
9980 make_transient $top $prefstop
9981 wm title $top [mc "Gitk font chooser"]
9982 label $top.l -textvariable fontparam(which)
9983 pack $top.l -side top
9984 set fontlist [lsort [font families]]
9985 frame $top.f
9986 listbox $top.f.fam -listvariable fontlist \
9987 -yscrollcommand [list $top.f.sb set]
9988 bind $top.f.fam <<ListboxSelect>> selfontfam
9989 scrollbar $top.f.sb -command [list $top.f.fam yview]
9990 pack $top.f.sb -side right -fill y
9991 pack $top.f.fam -side left -fill both -expand 1
9992 pack $top.f -side top -fill both -expand 1
9993 frame $top.g
9994 spinbox $top.g.size -from 4 -to 40 -width 4 \
9995 -textvariable fontparam(size) \
9996 -validatecommand {string is integer -strict %s}
9997 checkbutton $top.g.bold -padx 5 \
9998 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9999 -variable fontparam(weight) -onvalue bold -offvalue normal
10000 checkbutton $top.g.ital -padx 5 \
10001 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10002 -variable fontparam(slant) -onvalue italic -offvalue roman
10003 pack $top.g.size $top.g.bold $top.g.ital -side left
10004 pack $top.g -side top
10005 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10006 -background white
10007 $top.c create text 100 25 -anchor center -text $which -font sample \
10008 -fill black -tags text
10009 bind $top.c <Configure> [list centertext $top.c]
10010 pack $top.c -side top -fill x
10011 frame $top.buts
10012 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10013 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10014 bind $top <Key-Return> fontok
10015 bind $top <Key-Escape> fontcan
10016 grid $top.buts.ok $top.buts.can
10017 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10018 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10019 pack $top.buts -side bottom -fill x
10020 trace add variable fontparam write chg_fontparam
10021 } else {
10022 raise $top
10023 $top.c itemconf text -text $which
10025 set i [lsearch -exact $fontlist $fontparam(family)]
10026 if {$i >= 0} {
10027 $top.f.fam selection set $i
10028 $top.f.fam see $i
10032 proc centertext {w} {
10033 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10036 proc fontok {} {
10037 global fontparam fontpref prefstop
10039 set f $fontparam(font)
10040 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10041 if {$fontparam(weight) eq "bold"} {
10042 lappend fontpref($f) "bold"
10044 if {$fontparam(slant) eq "italic"} {
10045 lappend fontpref($f) "italic"
10047 set w $prefstop.$f
10048 $w conf -text $fontparam(family) -font $fontpref($f)
10050 fontcan
10053 proc fontcan {} {
10054 global fonttop fontparam
10056 if {[info exists fonttop]} {
10057 catch {destroy $fonttop}
10058 catch {font delete sample}
10059 unset fonttop
10060 unset fontparam
10064 proc selfontfam {} {
10065 global fonttop fontparam
10067 set i [$fonttop.f.fam curselection]
10068 if {$i ne {}} {
10069 set fontparam(family) [$fonttop.f.fam get $i]
10073 proc chg_fontparam {v sub op} {
10074 global fontparam
10076 font config sample -$sub $fontparam($sub)
10079 proc doprefs {} {
10080 global maxwidth maxgraphpct
10081 global oldprefs prefstop showneartags showlocalchanges
10082 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10083 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10085 set top .gitkprefs
10086 set prefstop $top
10087 if {[winfo exists $top]} {
10088 raise $top
10089 return
10091 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10092 limitdiffs tabstop perfile_attrs} {
10093 set oldprefs($v) [set $v]
10095 toplevel $top
10096 wm title $top [mc "Gitk preferences"]
10097 make_transient $top .
10098 label $top.ldisp -text [mc "Commit list display options"]
10099 grid $top.ldisp - -sticky w -pady 10
10100 label $top.spacer -text " "
10101 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10102 -font optionfont
10103 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10104 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10105 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10106 -font optionfont
10107 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10108 grid x $top.maxpctl $top.maxpct -sticky w
10109 checkbutton $top.showlocal -text [mc "Show local changes"] \
10110 -font optionfont -variable showlocalchanges
10111 grid x $top.showlocal -sticky w
10112 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10113 -font optionfont -variable autoselect
10114 grid x $top.autoselect -sticky w
10116 label $top.ddisp -text [mc "Diff display options"]
10117 grid $top.ddisp - -sticky w -pady 10
10118 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10119 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10120 grid x $top.tabstopl $top.tabstop -sticky w
10121 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10122 -font optionfont -variable showneartags
10123 grid x $top.ntag -sticky w
10124 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10125 -font optionfont -variable limitdiffs
10126 grid x $top.ldiff -sticky w
10127 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10128 -font optionfont -variable perfile_attrs
10129 grid x $top.lattr -sticky w
10131 entry $top.extdifft -textvariable extdifftool
10132 frame $top.extdifff
10133 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10134 -padx 10
10135 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10136 -command choose_extdiff
10137 pack $top.extdifff.l $top.extdifff.b -side left
10138 grid x $top.extdifff $top.extdifft -sticky w
10140 label $top.cdisp -text [mc "Colors: press to choose"]
10141 grid $top.cdisp - -sticky w -pady 10
10142 label $top.bg -padx 40 -relief sunk -background $bgcolor
10143 button $top.bgbut -text [mc "Background"] -font optionfont \
10144 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10145 grid x $top.bgbut $top.bg -sticky w
10146 label $top.fg -padx 40 -relief sunk -background $fgcolor
10147 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10148 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10149 grid x $top.fgbut $top.fg -sticky w
10150 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10151 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10152 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10153 [list $ctext tag conf d0 -foreground]]
10154 grid x $top.diffoldbut $top.diffold -sticky w
10155 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10156 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10157 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10158 [list $ctext tag conf dresult -foreground]]
10159 grid x $top.diffnewbut $top.diffnew -sticky w
10160 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10161 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10162 -command [list choosecolor diffcolors 2 $top.hunksep \
10163 [mc "diff hunk header"] \
10164 [list $ctext tag conf hunksep -foreground]]
10165 grid x $top.hunksepbut $top.hunksep -sticky w
10166 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10167 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10168 -command [list choosecolor markbgcolor {} $top.markbgsep \
10169 [mc "marked line background"] \
10170 [list $ctext tag conf omark -background]]
10171 grid x $top.markbgbut $top.markbgsep -sticky w
10172 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10173 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10174 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10175 grid x $top.selbgbut $top.selbgsep -sticky w
10177 label $top.cfont -text [mc "Fonts: press to choose"]
10178 grid $top.cfont - -sticky w -pady 10
10179 mkfontdisp mainfont $top [mc "Main font"]
10180 mkfontdisp textfont $top [mc "Diff display font"]
10181 mkfontdisp uifont $top [mc "User interface font"]
10183 frame $top.buts
10184 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10185 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10186 bind $top <Key-Return> prefsok
10187 bind $top <Key-Escape> prefscan
10188 grid $top.buts.ok $top.buts.can
10189 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10190 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10191 grid $top.buts - - -pady 10 -sticky ew
10192 bind $top <Visibility> "focus $top.buts.ok"
10195 proc choose_extdiff {} {
10196 global extdifftool
10198 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10199 if {$prog ne {}} {
10200 set extdifftool $prog
10204 proc choosecolor {v vi w x cmd} {
10205 global $v
10207 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10208 -title [mc "Gitk: choose color for %s" $x]]
10209 if {$c eq {}} return
10210 $w conf -background $c
10211 lset $v $vi $c
10212 eval $cmd $c
10215 proc setselbg {c} {
10216 global bglist cflist
10217 foreach w $bglist {
10218 $w configure -selectbackground $c
10220 $cflist tag configure highlight \
10221 -background [$cflist cget -selectbackground]
10222 allcanvs itemconf secsel -fill $c
10225 proc setbg {c} {
10226 global bglist
10228 foreach w $bglist {
10229 $w conf -background $c
10233 proc setfg {c} {
10234 global fglist canv
10236 foreach w $fglist {
10237 $w conf -foreground $c
10239 allcanvs itemconf text -fill $c
10240 $canv itemconf circle -outline $c
10243 proc prefscan {} {
10244 global oldprefs prefstop
10246 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10247 limitdiffs tabstop perfile_attrs} {
10248 global $v
10249 set $v $oldprefs($v)
10251 catch {destroy $prefstop}
10252 unset prefstop
10253 fontcan
10256 proc prefsok {} {
10257 global maxwidth maxgraphpct
10258 global oldprefs prefstop showneartags showlocalchanges
10259 global fontpref mainfont textfont uifont
10260 global limitdiffs treediffs perfile_attrs
10262 catch {destroy $prefstop}
10263 unset prefstop
10264 fontcan
10265 set fontchanged 0
10266 if {$mainfont ne $fontpref(mainfont)} {
10267 set mainfont $fontpref(mainfont)
10268 parsefont mainfont $mainfont
10269 eval font configure mainfont [fontflags mainfont]
10270 eval font configure mainfontbold [fontflags mainfont 1]
10271 setcoords
10272 set fontchanged 1
10274 if {$textfont ne $fontpref(textfont)} {
10275 set textfont $fontpref(textfont)
10276 parsefont textfont $textfont
10277 eval font configure textfont [fontflags textfont]
10278 eval font configure textfontbold [fontflags textfont 1]
10280 if {$uifont ne $fontpref(uifont)} {
10281 set uifont $fontpref(uifont)
10282 parsefont uifont $uifont
10283 eval font configure uifont [fontflags uifont]
10285 settabs
10286 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10287 if {$showlocalchanges} {
10288 doshowlocalchanges
10289 } else {
10290 dohidelocalchanges
10293 if {$limitdiffs != $oldprefs(limitdiffs) ||
10294 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10295 # treediffs elements are limited by path;
10296 # won't have encodings cached if perfile_attrs was just turned on
10297 catch {unset treediffs}
10299 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10300 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10301 redisplay
10302 } elseif {$showneartags != $oldprefs(showneartags) ||
10303 $limitdiffs != $oldprefs(limitdiffs)} {
10304 reselectline
10308 proc formatdate {d} {
10309 global datetimeformat
10310 if {$d ne {}} {
10311 set d [clock format $d -format $datetimeformat]
10313 return $d
10316 # This list of encoding names and aliases is distilled from
10317 # http://www.iana.org/assignments/character-sets.
10318 # Not all of them are supported by Tcl.
10319 set encoding_aliases {
10320 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10321 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10322 { ISO-10646-UTF-1 csISO10646UTF1 }
10323 { ISO_646.basic:1983 ref csISO646basic1983 }
10324 { INVARIANT csINVARIANT }
10325 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10326 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10327 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10328 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10329 { NATS-DANO iso-ir-9-1 csNATSDANO }
10330 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10331 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10332 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10333 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10334 { ISO-2022-KR csISO2022KR }
10335 { EUC-KR csEUCKR }
10336 { ISO-2022-JP csISO2022JP }
10337 { ISO-2022-JP-2 csISO2022JP2 }
10338 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10339 csISO13JISC6220jp }
10340 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10341 { IT iso-ir-15 ISO646-IT csISO15Italian }
10342 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10343 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10344 { greek7-old iso-ir-18 csISO18Greek7Old }
10345 { latin-greek iso-ir-19 csISO19LatinGreek }
10346 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10347 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10348 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10349 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10350 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10351 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10352 { INIS iso-ir-49 csISO49INIS }
10353 { INIS-8 iso-ir-50 csISO50INIS8 }
10354 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10355 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10356 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10357 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10358 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10359 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10360 csISO60Norwegian1 }
10361 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10362 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10363 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10364 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10365 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10366 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10367 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10368 { greek7 iso-ir-88 csISO88Greek7 }
10369 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10370 { iso-ir-90 csISO90 }
10371 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10372 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10373 csISO92JISC62991984b }
10374 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10375 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10376 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10377 csISO95JIS62291984handadd }
10378 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10379 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10380 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10381 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10382 CP819 csISOLatin1 }
10383 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10384 { T.61-7bit iso-ir-102 csISO102T617bit }
10385 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10386 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10387 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10388 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10389 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10390 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10391 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10392 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10393 arabic csISOLatinArabic }
10394 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10395 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10396 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10397 greek greek8 csISOLatinGreek }
10398 { T.101-G2 iso-ir-128 csISO128T101G2 }
10399 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10400 csISOLatinHebrew }
10401 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10402 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10403 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10404 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10405 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10406 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10407 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10408 csISOLatinCyrillic }
10409 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10410 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10411 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10412 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10413 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10414 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10415 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10416 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10417 { ISO_10367-box iso-ir-155 csISO10367Box }
10418 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10419 { latin-lap lap iso-ir-158 csISO158Lap }
10420 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10421 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10422 { us-dk csUSDK }
10423 { dk-us csDKUS }
10424 { JIS_X0201 X0201 csHalfWidthKatakana }
10425 { KSC5636 ISO646-KR csKSC5636 }
10426 { ISO-10646-UCS-2 csUnicode }
10427 { ISO-10646-UCS-4 csUCS4 }
10428 { DEC-MCS dec csDECMCS }
10429 { hp-roman8 roman8 r8 csHPRoman8 }
10430 { macintosh mac csMacintosh }
10431 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10432 csIBM037 }
10433 { IBM038 EBCDIC-INT cp038 csIBM038 }
10434 { IBM273 CP273 csIBM273 }
10435 { IBM274 EBCDIC-BE CP274 csIBM274 }
10436 { IBM275 EBCDIC-BR cp275 csIBM275 }
10437 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10438 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10439 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10440 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10441 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10442 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10443 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10444 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10445 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10446 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10447 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10448 { IBM437 cp437 437 csPC8CodePage437 }
10449 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10450 { IBM775 cp775 csPC775Baltic }
10451 { IBM850 cp850 850 csPC850Multilingual }
10452 { IBM851 cp851 851 csIBM851 }
10453 { IBM852 cp852 852 csPCp852 }
10454 { IBM855 cp855 855 csIBM855 }
10455 { IBM857 cp857 857 csIBM857 }
10456 { IBM860 cp860 860 csIBM860 }
10457 { IBM861 cp861 861 cp-is csIBM861 }
10458 { IBM862 cp862 862 csPC862LatinHebrew }
10459 { IBM863 cp863 863 csIBM863 }
10460 { IBM864 cp864 csIBM864 }
10461 { IBM865 cp865 865 csIBM865 }
10462 { IBM866 cp866 866 csIBM866 }
10463 { IBM868 CP868 cp-ar csIBM868 }
10464 { IBM869 cp869 869 cp-gr csIBM869 }
10465 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10466 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10467 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10468 { IBM891 cp891 csIBM891 }
10469 { IBM903 cp903 csIBM903 }
10470 { IBM904 cp904 904 csIBBM904 }
10471 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10472 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10473 { IBM1026 CP1026 csIBM1026 }
10474 { EBCDIC-AT-DE csIBMEBCDICATDE }
10475 { EBCDIC-AT-DE-A csEBCDICATDEA }
10476 { EBCDIC-CA-FR csEBCDICCAFR }
10477 { EBCDIC-DK-NO csEBCDICDKNO }
10478 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10479 { EBCDIC-FI-SE csEBCDICFISE }
10480 { EBCDIC-FI-SE-A csEBCDICFISEA }
10481 { EBCDIC-FR csEBCDICFR }
10482 { EBCDIC-IT csEBCDICIT }
10483 { EBCDIC-PT csEBCDICPT }
10484 { EBCDIC-ES csEBCDICES }
10485 { EBCDIC-ES-A csEBCDICESA }
10486 { EBCDIC-ES-S csEBCDICESS }
10487 { EBCDIC-UK csEBCDICUK }
10488 { EBCDIC-US csEBCDICUS }
10489 { UNKNOWN-8BIT csUnknown8BiT }
10490 { MNEMONIC csMnemonic }
10491 { MNEM csMnem }
10492 { VISCII csVISCII }
10493 { VIQR csVIQR }
10494 { KOI8-R csKOI8R }
10495 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10496 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10497 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10498 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10499 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10500 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10501 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10502 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10503 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10504 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10505 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10506 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10507 { IBM1047 IBM-1047 }
10508 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10509 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10510 { UNICODE-1-1 csUnicode11 }
10511 { CESU-8 csCESU-8 }
10512 { BOCU-1 csBOCU-1 }
10513 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10514 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10515 l8 }
10516 { ISO-8859-15 ISO_8859-15 Latin-9 }
10517 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10518 { GBK CP936 MS936 windows-936 }
10519 { JIS_Encoding csJISEncoding }
10520 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10521 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10522 EUC-JP }
10523 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10524 { ISO-10646-UCS-Basic csUnicodeASCII }
10525 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10526 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10527 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10528 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10529 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10530 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10531 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10532 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10533 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10534 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10535 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10536 { Ventura-US csVenturaUS }
10537 { Ventura-International csVenturaInternational }
10538 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10539 { PC8-Turkish csPC8Turkish }
10540 { IBM-Symbols csIBMSymbols }
10541 { IBM-Thai csIBMThai }
10542 { HP-Legal csHPLegal }
10543 { HP-Pi-font csHPPiFont }
10544 { HP-Math8 csHPMath8 }
10545 { Adobe-Symbol-Encoding csHPPSMath }
10546 { HP-DeskTop csHPDesktop }
10547 { Ventura-Math csVenturaMath }
10548 { Microsoft-Publishing csMicrosoftPublishing }
10549 { Windows-31J csWindows31J }
10550 { GB2312 csGB2312 }
10551 { Big5 csBig5 }
10554 proc tcl_encoding {enc} {
10555 global encoding_aliases tcl_encoding_cache
10556 if {[info exists tcl_encoding_cache($enc)]} {
10557 return $tcl_encoding_cache($enc)
10559 set names [encoding names]
10560 set lcnames [string tolower $names]
10561 set enc [string tolower $enc]
10562 set i [lsearch -exact $lcnames $enc]
10563 if {$i < 0} {
10564 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10565 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10566 set i [lsearch -exact $lcnames $encx]
10569 if {$i < 0} {
10570 foreach l $encoding_aliases {
10571 set ll [string tolower $l]
10572 if {[lsearch -exact $ll $enc] < 0} continue
10573 # look through the aliases for one that tcl knows about
10574 foreach e $ll {
10575 set i [lsearch -exact $lcnames $e]
10576 if {$i < 0} {
10577 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10578 set i [lsearch -exact $lcnames $ex]
10581 if {$i >= 0} break
10583 break
10586 set tclenc {}
10587 if {$i >= 0} {
10588 set tclenc [lindex $names $i]
10590 set tcl_encoding_cache($enc) $tclenc
10591 return $tclenc
10594 proc gitattr {path attr default} {
10595 global path_attr_cache
10596 if {[info exists path_attr_cache($attr,$path)]} {
10597 set r $path_attr_cache($attr,$path)
10598 } else {
10599 set r "unspecified"
10600 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10601 regexp "(.*): encoding: (.*)" $line m f r
10603 set path_attr_cache($attr,$path) $r
10605 if {$r eq "unspecified"} {
10606 return $default
10608 return $r
10611 proc cache_gitattr {attr pathlist} {
10612 global path_attr_cache
10613 set newlist {}
10614 foreach path $pathlist {
10615 if {![info exists path_attr_cache($attr,$path)]} {
10616 lappend newlist $path
10619 set lim 1000
10620 if {[tk windowingsystem] == "win32"} {
10621 # windows has a 32k limit on the arguments to a command...
10622 set lim 30
10624 while {$newlist ne {}} {
10625 set head [lrange $newlist 0 [expr {$lim - 1}]]
10626 set newlist [lrange $newlist $lim end]
10627 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10628 foreach row [split $rlist "\n"] {
10629 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10630 if {[string index $path 0] eq "\""} {
10631 set path [encoding convertfrom [lindex $path 0]]
10633 set path_attr_cache($attr,$path) $value
10640 proc get_path_encoding {path} {
10641 global gui_encoding perfile_attrs
10642 set tcl_enc $gui_encoding
10643 if {$path ne {} && $perfile_attrs} {
10644 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10645 if {$enc2 ne {}} {
10646 set tcl_enc $enc2
10649 return $tcl_enc
10652 # First check that Tcl/Tk is recent enough
10653 if {[catch {package require Tk 8.4} err]} {
10654 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10655 Gitk requires at least Tcl/Tk 8.4."]
10656 exit 1
10659 # defaults...
10660 set wrcomcmd "git diff-tree --stdin -p --pretty"
10662 set gitencoding {}
10663 catch {
10664 set gitencoding [exec git config --get i18n.commitencoding]
10666 catch {
10667 set gitencoding [exec git config --get i18n.logoutputencoding]
10669 if {$gitencoding == ""} {
10670 set gitencoding "utf-8"
10672 set tclencoding [tcl_encoding $gitencoding]
10673 if {$tclencoding == {}} {
10674 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10677 set gui_encoding [encoding system]
10678 catch {
10679 set enc [exec git config --get gui.encoding]
10680 if {$enc ne {}} {
10681 set tclenc [tcl_encoding $enc]
10682 if {$tclenc ne {}} {
10683 set gui_encoding $tclenc
10684 } else {
10685 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10690 set mainfont {Helvetica 9}
10691 set textfont {Courier 9}
10692 set uifont {Helvetica 9 bold}
10693 set tabstop 8
10694 set findmergefiles 0
10695 set maxgraphpct 50
10696 set maxwidth 16
10697 set revlistorder 0
10698 set fastdate 0
10699 set uparrowlen 5
10700 set downarrowlen 5
10701 set mingaplen 100
10702 set cmitmode "patch"
10703 set wrapcomment "none"
10704 set showneartags 1
10705 set maxrefs 20
10706 set maxlinelen 200
10707 set showlocalchanges 1
10708 set limitdiffs 1
10709 set datetimeformat "%Y-%m-%d %H:%M:%S"
10710 set autoselect 1
10711 set perfile_attrs 0
10713 set extdifftool "meld"
10715 set colors {green red blue magenta darkgrey brown orange}
10716 set bgcolor white
10717 set fgcolor black
10718 set diffcolors {red "#00a000" blue}
10719 set diffcontext 3
10720 set ignorespace 0
10721 set selectbgcolor gray85
10722 set markbgcolor "#e0e0ff"
10724 set circlecolors {white blue gray blue blue}
10726 # button for popping up context menus
10727 if {[tk windowingsystem] eq "aqua"} {
10728 set ctxbut <Button-2>
10729 } else {
10730 set ctxbut <Button-3>
10733 ## For msgcat loading, first locate the installation location.
10734 if { [info exists ::env(GITK_MSGSDIR)] } {
10735 ## Msgsdir was manually set in the environment.
10736 set gitk_msgsdir $::env(GITK_MSGSDIR)
10737 } else {
10738 ## Let's guess the prefix from argv0.
10739 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10740 set gitk_libdir [file join $gitk_prefix share gitk lib]
10741 set gitk_msgsdir [file join $gitk_libdir msgs]
10742 unset gitk_prefix
10745 ## Internationalization (i18n) through msgcat and gettext. See
10746 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10747 package require msgcat
10748 namespace import ::msgcat::mc
10749 ## And eventually load the actual message catalog
10750 ::msgcat::mcload $gitk_msgsdir
10752 catch {source ~/.gitk}
10754 font create optionfont -family sans-serif -size -12
10756 parsefont mainfont $mainfont
10757 eval font create mainfont [fontflags mainfont]
10758 eval font create mainfontbold [fontflags mainfont 1]
10760 parsefont textfont $textfont
10761 eval font create textfont [fontflags textfont]
10762 eval font create textfontbold [fontflags textfont 1]
10764 parsefont uifont $uifont
10765 eval font create uifont [fontflags uifont]
10767 setoptions
10769 # check that we can find a .git directory somewhere...
10770 if {[catch {set gitdir [gitdir]}]} {
10771 show_error {} . [mc "Cannot find a git repository here."]
10772 exit 1
10774 if {![file isdirectory $gitdir]} {
10775 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10776 exit 1
10779 set selecthead {}
10780 set selectheadid {}
10782 set revtreeargs {}
10783 set cmdline_files {}
10784 set i 0
10785 set revtreeargscmd {}
10786 foreach arg $argv {
10787 switch -glob -- $arg {
10788 "" { }
10789 "--" {
10790 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10791 break
10793 "--select-commit=*" {
10794 set selecthead [string range $arg 16 end]
10796 "--argscmd=*" {
10797 set revtreeargscmd [string range $arg 10 end]
10799 default {
10800 lappend revtreeargs $arg
10803 incr i
10806 if {$selecthead eq "HEAD"} {
10807 set selecthead {}
10810 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10811 # no -- on command line, but some arguments (other than --argscmd)
10812 if {[catch {
10813 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10814 set cmdline_files [split $f "\n"]
10815 set n [llength $cmdline_files]
10816 set revtreeargs [lrange $revtreeargs 0 end-$n]
10817 # Unfortunately git rev-parse doesn't produce an error when
10818 # something is both a revision and a filename. To be consistent
10819 # with git log and git rev-list, check revtreeargs for filenames.
10820 foreach arg $revtreeargs {
10821 if {[file exists $arg]} {
10822 show_error {} . [mc "Ambiguous argument '%s': both revision\
10823 and filename" $arg]
10824 exit 1
10827 } err]} {
10828 # unfortunately we get both stdout and stderr in $err,
10829 # so look for "fatal:".
10830 set i [string first "fatal:" $err]
10831 if {$i > 0} {
10832 set err [string range $err [expr {$i + 6}] end]
10834 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10835 exit 1
10839 set nullid "0000000000000000000000000000000000000000"
10840 set nullid2 "0000000000000000000000000000000000000001"
10841 set nullfile "/dev/null"
10843 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10845 set runq {}
10846 set history {}
10847 set historyindex 0
10848 set fh_serial 0
10849 set nhl_names {}
10850 set highlight_paths {}
10851 set findpattern {}
10852 set searchdirn -forwards
10853 set boldids {}
10854 set boldnameids {}
10855 set diffelide {0 0}
10856 set markingmatches 0
10857 set linkentercount 0
10858 set need_redisplay 0
10859 set nrows_drawn 0
10860 set firsttabstop 0
10862 set nextviewnum 1
10863 set curview 0
10864 set selectedview 0
10865 set selectedhlview [mc "None"]
10866 set highlight_related [mc "None"]
10867 set highlight_files {}
10868 set viewfiles(0) {}
10869 set viewperm(0) 0
10870 set viewargs(0) {}
10871 set viewargscmd(0) {}
10873 set selectedline {}
10874 set numcommits 0
10875 set loginstance 0
10876 set cmdlineok 0
10877 set stopped 0
10878 set stuffsaved 0
10879 set patchnum 0
10880 set lserial 0
10881 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10882 setcoords
10883 makewindow
10884 # wait for the window to become visible
10885 tkwait visibility .
10886 wm title . "[file tail $argv0]: [file tail [pwd]]"
10887 readrefs
10889 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10890 # create a view for the files/dirs specified on the command line
10891 set curview 1
10892 set selectedview 1
10893 set nextviewnum 2
10894 set viewname(1) [mc "Command line"]
10895 set viewfiles(1) $cmdline_files
10896 set viewargs(1) $revtreeargs
10897 set viewargscmd(1) $revtreeargscmd
10898 set viewperm(1) 0
10899 set vdatemode(1) 0
10900 addviewmenu 1
10901 .bar.view entryconf [mca "Edit view..."] -state normal
10902 .bar.view entryconf [mca "Delete view"] -state normal
10905 if {[info exists permviews]} {
10906 foreach v $permviews {
10907 set n $nextviewnum
10908 incr nextviewnum
10909 set viewname($n) [lindex $v 0]
10910 set viewfiles($n) [lindex $v 1]
10911 set viewargs($n) [lindex $v 2]
10912 set viewargscmd($n) [lindex $v 3]
10913 set viewperm($n) 1
10914 addviewmenu $n
10918 if {[tk windowingsystem] eq "win32"} {
10919 focus -force .
10922 getcommits {}