Revert accidentally merged commits
[git/dscho.git] / gitk-git / gitk
bloba2c589f7495de2296ca926623d7658a812175f20
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
183 lappend glflags $arg
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191 # These mean that we get a subset of the commits
192 set filtered 1
193 lappend glflags $arg
195 "-n" {
196 # This appears to be the only one that has a value as a
197 # separate word following it
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" - "--all" {
203 lappend revargs $arg
205 "--merge" {
206 set vmergeonly($n) 1
207 # git rev-parse doesn't understand --merge
208 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
210 "-*" {
211 # Other flag arguments including -<n>
212 if {[string is digit -strict [string range $arg 1 end]]} {
213 set filtered 1
214 } else {
215 # a flag argument that we don't recognize;
216 # that means we can't optimize
217 set allknown 0
219 lappend glflags $arg
221 default {
222 # Non-flag arguments specify commits or ranges of commits
223 if {[string match "*...*" $arg]} {
224 lappend revargs --gitk-symmetric-diff-marker
226 lappend revargs $arg
230 set vdflags($n) $diffargs
231 set vflags($n) $glflags
232 set vrevs($n) $revargs
233 set vfiltered($n) $filtered
234 set vorigargs($n) $origargs
235 return $allknown
238 proc parseviewrevs {view revs} {
239 global vposids vnegids
241 if {$revs eq {}} {
242 set revs HEAD
244 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
245 # we get stdout followed by stderr in $err
246 # for an unknown rev, git rev-parse echoes it and then errors out
247 set errlines [split $err "\n"]
248 set badrev {}
249 for {set l 0} {$l < [llength $errlines]} {incr l} {
250 set line [lindex $errlines $l]
251 if {!([string length $line] == 40 && [string is xdigit $line])} {
252 if {[string match "fatal:*" $line]} {
253 if {[string match "fatal: ambiguous argument*" $line]
254 && $badrev ne {}} {
255 if {[llength $badrev] == 1} {
256 set err "unknown revision $badrev"
257 } else {
258 set err "unknown revisions: [join $badrev ", "]"
260 } else {
261 set err [join [lrange $errlines $l end] "\n"]
263 break
265 lappend badrev $line
268 error_popup "[mc "Error parsing revisions:"] $err"
269 return {}
271 set ret {}
272 set pos {}
273 set neg {}
274 set sdm 0
275 foreach id [split $ids "\n"] {
276 if {$id eq "--gitk-symmetric-diff-marker"} {
277 set sdm 4
278 } elseif {[string match "^*" $id]} {
279 if {$sdm != 1} {
280 lappend ret $id
281 if {$sdm == 3} {
282 set sdm 0
285 lappend neg [string range $id 1 end]
286 } else {
287 if {$sdm != 2} {
288 lappend ret $id
289 } else {
290 lset ret end [lindex $ret end]...$id
292 lappend pos $id
294 incr sdm -1
296 set vposids($view) $pos
297 set vnegids($view) $neg
298 return $ret
301 # Start off a git log process and arrange to read its output
302 proc start_rev_list {view} {
303 global startmsecs commitidx viewcomplete curview
304 global tclencoding
305 global viewargs viewargscmd viewfiles vfilelimit
306 global showlocalchanges
307 global viewactive viewinstances vmergeonly
308 global mainheadid viewmainheadid viewmainheadid_orig
309 global vcanopt vflags vrevs vorigargs
311 set startmsecs [clock clicks -milliseconds]
312 set commitidx($view) 0
313 # these are set this way for the error exits
314 set viewcomplete($view) 1
315 set viewactive($view) 0
316 varcinit $view
318 set args $viewargs($view)
319 if {$viewargscmd($view) ne {}} {
320 if {[catch {
321 set str [exec sh -c $viewargscmd($view)]
322 } err]} {
323 error_popup "[mc "Error executing --argscmd command:"] $err"
324 return 0
326 set args [concat $args [split $str "\n"]]
328 set vcanopt($view) [parseviewargs $view $args]
330 set files $viewfiles($view)
331 if {$vmergeonly($view)} {
332 set files [unmerged_files $files]
333 if {$files eq {}} {
334 global nr_unmerged
335 if {$nr_unmerged == 0} {
336 error_popup [mc "No files selected: --merge specified but\
337 no files are unmerged."]
338 } else {
339 error_popup [mc "No files selected: --merge specified but\
340 no unmerged files are within file limit."]
342 return 0
345 set vfilelimit($view) $files
347 if {$vcanopt($view)} {
348 set revs [parseviewrevs $view $vrevs($view)]
349 if {$revs eq {}} {
350 return 0
352 set args [concat $vflags($view) $revs]
353 } else {
354 set args $vorigargs($view)
357 if {[catch {
358 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
359 --boundary $args "--" $files] r]
360 } err]} {
361 error_popup "[mc "Error executing git log:"] $err"
362 return 0
364 set i [reg_instance $fd]
365 set viewinstances($view) [list $i]
366 set viewmainheadid($view) $mainheadid
367 set viewmainheadid_orig($view) $mainheadid
368 if {$files ne {} && $mainheadid ne {}} {
369 get_viewmainhead $view
371 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
372 interestedin $viewmainheadid($view) dodiffindex
374 fconfigure $fd -blocking 0 -translation lf -eofchar {}
375 if {$tclencoding != {}} {
376 fconfigure $fd -encoding $tclencoding
378 filerun $fd [list getcommitlines $fd $i $view 0]
379 nowbusy $view [mc "Reading"]
380 set viewcomplete($view) 0
381 set viewactive($view) 1
382 return 1
385 proc stop_instance {inst} {
386 global commfd leftover
388 set fd $commfd($inst)
389 catch {
390 set pid [pid $fd]
392 if {$::tcl_platform(platform) eq {windows}} {
393 exec kill -f $pid
394 } else {
395 exec kill $pid
398 catch {close $fd}
399 nukefile $fd
400 unset commfd($inst)
401 unset leftover($inst)
404 proc stop_backends {} {
405 global commfd
407 foreach inst [array names commfd] {
408 stop_instance $inst
412 proc stop_rev_list {view} {
413 global viewinstances
415 foreach inst $viewinstances($view) {
416 stop_instance $inst
418 set viewinstances($view) {}
421 proc reset_pending_select {selid} {
422 global pending_select mainheadid selectheadid
424 if {$selid ne {}} {
425 set pending_select $selid
426 } elseif {$selectheadid ne {}} {
427 set pending_select $selectheadid
428 } else {
429 set pending_select $mainheadid
433 proc getcommits {selid} {
434 global canv curview need_redisplay viewactive
436 initlayout
437 if {[start_rev_list $curview]} {
438 reset_pending_select $selid
439 show_status [mc "Reading commits..."]
440 set need_redisplay 1
441 } else {
442 show_status [mc "No commits selected"]
446 proc updatecommits {} {
447 global curview vcanopt vorigargs vfilelimit viewinstances
448 global viewactive viewcomplete tclencoding
449 global startmsecs showneartags showlocalchanges
450 global mainheadid viewmainheadid viewmainheadid_orig pending_select
451 global isworktree
452 global varcid vposids vnegids vflags vrevs
454 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
455 rereadrefs
456 set view $curview
457 if {$mainheadid ne $viewmainheadid_orig($view)} {
458 if {$showlocalchanges} {
459 dohidelocalchanges
461 set viewmainheadid($view) $mainheadid
462 set viewmainheadid_orig($view) $mainheadid
463 if {$vfilelimit($view) ne {}} {
464 get_viewmainhead $view
467 if {$showlocalchanges} {
468 doshowlocalchanges
470 if {$vcanopt($view)} {
471 set oldpos $vposids($view)
472 set oldneg $vnegids($view)
473 set revs [parseviewrevs $view $vrevs($view)]
474 if {$revs eq {}} {
475 return
477 # note: getting the delta when negative refs change is hard,
478 # and could require multiple git log invocations, so in that
479 # case we ask git log for all the commits (not just the delta)
480 if {$oldneg eq $vnegids($view)} {
481 set newrevs {}
482 set npos 0
483 # take out positive refs that we asked for before or
484 # that we have already seen
485 foreach rev $revs {
486 if {[string length $rev] == 40} {
487 if {[lsearch -exact $oldpos $rev] < 0
488 && ![info exists varcid($view,$rev)]} {
489 lappend newrevs $rev
490 incr npos
492 } else {
493 lappend $newrevs $rev
496 if {$npos == 0} return
497 set revs $newrevs
498 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
500 set args [concat $vflags($view) $revs --not $oldpos]
501 } else {
502 set args $vorigargs($view)
504 if {[catch {
505 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
506 --boundary $args "--" $vfilelimit($view)] r]
507 } err]} {
508 error_popup "[mc "Error executing git log:"] $err"
509 return
511 if {$viewactive($view) == 0} {
512 set startmsecs [clock clicks -milliseconds]
514 set i [reg_instance $fd]
515 lappend viewinstances($view) $i
516 fconfigure $fd -blocking 0 -translation lf -eofchar {}
517 if {$tclencoding != {}} {
518 fconfigure $fd -encoding $tclencoding
520 filerun $fd [list getcommitlines $fd $i $view 1]
521 incr viewactive($view)
522 set viewcomplete($view) 0
523 reset_pending_select {}
524 nowbusy $view "Reading"
525 if {$showneartags} {
526 getallcommits
530 proc reloadcommits {} {
531 global curview viewcomplete selectedline currentid thickerline
532 global showneartags treediffs commitinterest cached_commitrow
533 global targetid
535 set selid {}
536 if {$selectedline ne {}} {
537 set selid $currentid
540 if {!$viewcomplete($curview)} {
541 stop_rev_list $curview
543 resetvarcs $curview
544 set selectedline {}
545 catch {unset currentid}
546 catch {unset thickerline}
547 catch {unset treediffs}
548 readrefs
549 changedrefs
550 if {$showneartags} {
551 getallcommits
553 clear_display
554 catch {unset commitinterest}
555 catch {unset cached_commitrow}
556 catch {unset targetid}
557 setcanvscroll
558 getcommits $selid
559 return 0
562 # This makes a string representation of a positive integer which
563 # sorts as a string in numerical order
564 proc strrep {n} {
565 if {$n < 16} {
566 return [format "%x" $n]
567 } elseif {$n < 256} {
568 return [format "x%.2x" $n]
569 } elseif {$n < 65536} {
570 return [format "y%.4x" $n]
572 return [format "z%.8x" $n]
575 # Procedures used in reordering commits from git log (without
576 # --topo-order) into the order for display.
578 proc varcinit {view} {
579 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
580 global vtokmod varcmod vrowmod varcix vlastins
582 set varcstart($view) {{}}
583 set vupptr($view) {0}
584 set vdownptr($view) {0}
585 set vleftptr($view) {0}
586 set vbackptr($view) {0}
587 set varctok($view) {{}}
588 set varcrow($view) {{}}
589 set vtokmod($view) {}
590 set varcmod($view) 0
591 set vrowmod($view) 0
592 set varcix($view) {{}}
593 set vlastins($view) {0}
596 proc resetvarcs {view} {
597 global varcid varccommits parents children vseedcount ordertok
599 foreach vid [array names varcid $view,*] {
600 unset varcid($vid)
601 unset children($vid)
602 unset parents($vid)
604 # some commits might have children but haven't been seen yet
605 foreach vid [array names children $view,*] {
606 unset children($vid)
608 foreach va [array names varccommits $view,*] {
609 unset varccommits($va)
611 foreach vd [array names vseedcount $view,*] {
612 unset vseedcount($vd)
614 catch {unset ordertok}
617 # returns a list of the commits with no children
618 proc seeds {v} {
619 global vdownptr vleftptr varcstart
621 set ret {}
622 set a [lindex $vdownptr($v) 0]
623 while {$a != 0} {
624 lappend ret [lindex $varcstart($v) $a]
625 set a [lindex $vleftptr($v) $a]
627 return $ret
630 proc newvarc {view id} {
631 global varcid varctok parents children vdatemode
632 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
633 global commitdata commitinfo vseedcount varccommits vlastins
635 set a [llength $varctok($view)]
636 set vid $view,$id
637 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
638 if {![info exists commitinfo($id)]} {
639 parsecommit $id $commitdata($id) 1
641 set cdate [lindex $commitinfo($id) 4]
642 if {![string is integer -strict $cdate]} {
643 set cdate 0
645 if {![info exists vseedcount($view,$cdate)]} {
646 set vseedcount($view,$cdate) -1
648 set c [incr vseedcount($view,$cdate)]
649 set cdate [expr {$cdate ^ 0xffffffff}]
650 set tok "s[strrep $cdate][strrep $c]"
651 } else {
652 set tok {}
654 set ka 0
655 if {[llength $children($vid)] > 0} {
656 set kid [lindex $children($vid) end]
657 set k $varcid($view,$kid)
658 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
659 set ki $kid
660 set ka $k
661 set tok [lindex $varctok($view) $k]
664 if {$ka != 0} {
665 set i [lsearch -exact $parents($view,$ki) $id]
666 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
667 append tok [strrep $j]
669 set c [lindex $vlastins($view) $ka]
670 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
671 set c $ka
672 set b [lindex $vdownptr($view) $ka]
673 } else {
674 set b [lindex $vleftptr($view) $c]
676 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
677 set c $b
678 set b [lindex $vleftptr($view) $c]
680 if {$c == $ka} {
681 lset vdownptr($view) $ka $a
682 lappend vbackptr($view) 0
683 } else {
684 lset vleftptr($view) $c $a
685 lappend vbackptr($view) $c
687 lset vlastins($view) $ka $a
688 lappend vupptr($view) $ka
689 lappend vleftptr($view) $b
690 if {$b != 0} {
691 lset vbackptr($view) $b $a
693 lappend varctok($view) $tok
694 lappend varcstart($view) $id
695 lappend vdownptr($view) 0
696 lappend varcrow($view) {}
697 lappend varcix($view) {}
698 set varccommits($view,$a) {}
699 lappend vlastins($view) 0
700 return $a
703 proc splitvarc {p v} {
704 global varcid varcstart varccommits varctok vtokmod
705 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707 set oa $varcid($v,$p)
708 set otok [lindex $varctok($v) $oa]
709 set ac $varccommits($v,$oa)
710 set i [lsearch -exact $varccommits($v,$oa) $p]
711 if {$i <= 0} return
712 set na [llength $varctok($v)]
713 # "%" sorts before "0"...
714 set tok "$otok%[strrep $i]"
715 lappend varctok($v) $tok
716 lappend varcrow($v) {}
717 lappend varcix($v) {}
718 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
719 set varccommits($v,$na) [lrange $ac $i end]
720 lappend varcstart($v) $p
721 foreach id $varccommits($v,$na) {
722 set varcid($v,$id) $na
724 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
725 lappend vlastins($v) [lindex $vlastins($v) $oa]
726 lset vdownptr($v) $oa $na
727 lset vlastins($v) $oa 0
728 lappend vupptr($v) $oa
729 lappend vleftptr($v) 0
730 lappend vbackptr($v) 0
731 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
732 lset vupptr($v) $b $na
734 if {[string compare $otok $vtokmod($v)] <= 0} {
735 modify_arc $v $oa
739 proc renumbervarc {a v} {
740 global parents children varctok varcstart varccommits
741 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
743 set t1 [clock clicks -milliseconds]
744 set todo {}
745 set isrelated($a) 1
746 set kidchanged($a) 1
747 set ntot 0
748 while {$a != 0} {
749 if {[info exists isrelated($a)]} {
750 lappend todo $a
751 set id [lindex $varccommits($v,$a) end]
752 foreach p $parents($v,$id) {
753 if {[info exists varcid($v,$p)]} {
754 set isrelated($varcid($v,$p)) 1
758 incr ntot
759 set b [lindex $vdownptr($v) $a]
760 if {$b == 0} {
761 while {$a != 0} {
762 set b [lindex $vleftptr($v) $a]
763 if {$b != 0} break
764 set a [lindex $vupptr($v) $a]
767 set a $b
769 foreach a $todo {
770 if {![info exists kidchanged($a)]} continue
771 set id [lindex $varcstart($v) $a]
772 if {[llength $children($v,$id)] > 1} {
773 set children($v,$id) [lsort -command [list vtokcmp $v] \
774 $children($v,$id)]
776 set oldtok [lindex $varctok($v) $a]
777 if {!$vdatemode($v)} {
778 set tok {}
779 } else {
780 set tok $oldtok
782 set ka 0
783 set kid [last_real_child $v,$id]
784 if {$kid ne {}} {
785 set k $varcid($v,$kid)
786 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
787 set ki $kid
788 set ka $k
789 set tok [lindex $varctok($v) $k]
792 if {$ka != 0} {
793 set i [lsearch -exact $parents($v,$ki) $id]
794 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
795 append tok [strrep $j]
797 if {$tok eq $oldtok} {
798 continue
800 set id [lindex $varccommits($v,$a) end]
801 foreach p $parents($v,$id) {
802 if {[info exists varcid($v,$p)]} {
803 set kidchanged($varcid($v,$p)) 1
804 } else {
805 set sortkids($p) 1
808 lset varctok($v) $a $tok
809 set b [lindex $vupptr($v) $a]
810 if {$b != $ka} {
811 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
812 modify_arc $v $ka
814 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
815 modify_arc $v $b
817 set c [lindex $vbackptr($v) $a]
818 set d [lindex $vleftptr($v) $a]
819 if {$c == 0} {
820 lset vdownptr($v) $b $d
821 } else {
822 lset vleftptr($v) $c $d
824 if {$d != 0} {
825 lset vbackptr($v) $d $c
827 if {[lindex $vlastins($v) $b] == $a} {
828 lset vlastins($v) $b $c
830 lset vupptr($v) $a $ka
831 set c [lindex $vlastins($v) $ka]
832 if {$c == 0 || \
833 [string compare $tok [lindex $varctok($v) $c]] < 0} {
834 set c $ka
835 set b [lindex $vdownptr($v) $ka]
836 } else {
837 set b [lindex $vleftptr($v) $c]
839 while {$b != 0 && \
840 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
841 set c $b
842 set b [lindex $vleftptr($v) $c]
844 if {$c == $ka} {
845 lset vdownptr($v) $ka $a
846 lset vbackptr($v) $a 0
847 } else {
848 lset vleftptr($v) $c $a
849 lset vbackptr($v) $a $c
851 lset vleftptr($v) $a $b
852 if {$b != 0} {
853 lset vbackptr($v) $b $a
855 lset vlastins($v) $ka $a
858 foreach id [array names sortkids] {
859 if {[llength $children($v,$id)] > 1} {
860 set children($v,$id) [lsort -command [list vtokcmp $v] \
861 $children($v,$id)]
864 set t2 [clock clicks -milliseconds]
865 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
868 # Fix up the graph after we have found out that in view $v,
869 # $p (a commit that we have already seen) is actually the parent
870 # of the last commit in arc $a.
871 proc fix_reversal {p a v} {
872 global varcid varcstart varctok vupptr
874 set pa $varcid($v,$p)
875 if {$p ne [lindex $varcstart($v) $pa]} {
876 splitvarc $p $v
877 set pa $varcid($v,$p)
879 # seeds always need to be renumbered
880 if {[lindex $vupptr($v) $pa] == 0 ||
881 [string compare [lindex $varctok($v) $a] \
882 [lindex $varctok($v) $pa]] > 0} {
883 renumbervarc $pa $v
887 proc insertrow {id p v} {
888 global cmitlisted children parents varcid varctok vtokmod
889 global varccommits ordertok commitidx numcommits curview
890 global targetid targetrow
892 readcommit $id
893 set vid $v,$id
894 set cmitlisted($vid) 1
895 set children($vid) {}
896 set parents($vid) [list $p]
897 set a [newvarc $v $id]
898 set varcid($vid) $a
899 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
900 modify_arc $v $a
902 lappend varccommits($v,$a) $id
903 set vp $v,$p
904 if {[llength [lappend children($vp) $id]] > 1} {
905 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
906 catch {unset ordertok}
908 fix_reversal $p $a $v
909 incr commitidx($v)
910 if {$v == $curview} {
911 set numcommits $commitidx($v)
912 setcanvscroll
913 if {[info exists targetid]} {
914 if {![comes_before $targetid $p]} {
915 incr targetrow
921 proc insertfakerow {id p} {
922 global varcid varccommits parents children cmitlisted
923 global commitidx varctok vtokmod targetid targetrow curview numcommits
925 set v $curview
926 set a $varcid($v,$p)
927 set i [lsearch -exact $varccommits($v,$a) $p]
928 if {$i < 0} {
929 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
930 return
932 set children($v,$id) {}
933 set parents($v,$id) [list $p]
934 set varcid($v,$id) $a
935 lappend children($v,$p) $id
936 set cmitlisted($v,$id) 1
937 set numcommits [incr commitidx($v)]
938 # note we deliberately don't update varcstart($v) even if $i == 0
939 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
940 modify_arc $v $a $i
941 if {[info exists targetid]} {
942 if {![comes_before $targetid $p]} {
943 incr targetrow
946 setcanvscroll
947 drawvisible
950 proc removefakerow {id} {
951 global varcid varccommits parents children commitidx
952 global varctok vtokmod cmitlisted currentid selectedline
953 global targetid curview numcommits
955 set v $curview
956 if {[llength $parents($v,$id)] != 1} {
957 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
958 return
960 set p [lindex $parents($v,$id) 0]
961 set a $varcid($v,$id)
962 set i [lsearch -exact $varccommits($v,$a) $id]
963 if {$i < 0} {
964 puts "oops: removefakerow can't find [shortids $id] on arc $a"
965 return
967 unset varcid($v,$id)
968 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
969 unset parents($v,$id)
970 unset children($v,$id)
971 unset cmitlisted($v,$id)
972 set numcommits [incr commitidx($v) -1]
973 set j [lsearch -exact $children($v,$p) $id]
974 if {$j >= 0} {
975 set children($v,$p) [lreplace $children($v,$p) $j $j]
977 modify_arc $v $a $i
978 if {[info exist currentid] && $id eq $currentid} {
979 unset currentid
980 set selectedline {}
982 if {[info exists targetid] && $targetid eq $id} {
983 set targetid $p
985 setcanvscroll
986 drawvisible
989 proc first_real_child {vp} {
990 global children nullid nullid2
992 foreach id $children($vp) {
993 if {$id ne $nullid && $id ne $nullid2} {
994 return $id
997 return {}
1000 proc last_real_child {vp} {
1001 global children nullid nullid2
1003 set kids $children($vp)
1004 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1005 set id [lindex $kids $i]
1006 if {$id ne $nullid && $id ne $nullid2} {
1007 return $id
1010 return {}
1013 proc vtokcmp {v a b} {
1014 global varctok varcid
1016 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1017 [lindex $varctok($v) $varcid($v,$b)]]
1020 # This assumes that if lim is not given, the caller has checked that
1021 # arc a's token is less than $vtokmod($v)
1022 proc modify_arc {v a {lim {}}} {
1023 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1025 if {$lim ne {}} {
1026 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1027 if {$c > 0} return
1028 if {$c == 0} {
1029 set r [lindex $varcrow($v) $a]
1030 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1033 set vtokmod($v) [lindex $varctok($v) $a]
1034 set varcmod($v) $a
1035 if {$v == $curview} {
1036 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1037 set a [lindex $vupptr($v) $a]
1038 set lim {}
1040 set r 0
1041 if {$a != 0} {
1042 if {$lim eq {}} {
1043 set lim [llength $varccommits($v,$a)]
1045 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1047 set vrowmod($v) $r
1048 undolayout $r
1052 proc update_arcrows {v} {
1053 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1054 global varcid vrownum varcorder varcix varccommits
1055 global vupptr vdownptr vleftptr varctok
1056 global displayorder parentlist curview cached_commitrow
1058 if {$vrowmod($v) == $commitidx($v)} return
1059 if {$v == $curview} {
1060 if {[llength $displayorder] > $vrowmod($v)} {
1061 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1062 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1064 catch {unset cached_commitrow}
1066 set narctot [expr {[llength $varctok($v)] - 1}]
1067 set a $varcmod($v)
1068 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1069 # go up the tree until we find something that has a row number,
1070 # or we get to a seed
1071 set a [lindex $vupptr($v) $a]
1073 if {$a == 0} {
1074 set a [lindex $vdownptr($v) 0]
1075 if {$a == 0} return
1076 set vrownum($v) {0}
1077 set varcorder($v) [list $a]
1078 lset varcix($v) $a 0
1079 lset varcrow($v) $a 0
1080 set arcn 0
1081 set row 0
1082 } else {
1083 set arcn [lindex $varcix($v) $a]
1084 if {[llength $vrownum($v)] > $arcn + 1} {
1085 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1086 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1088 set row [lindex $varcrow($v) $a]
1090 while {1} {
1091 set p $a
1092 incr row [llength $varccommits($v,$a)]
1093 # go down if possible
1094 set b [lindex $vdownptr($v) $a]
1095 if {$b == 0} {
1096 # if not, go left, or go up until we can go left
1097 while {$a != 0} {
1098 set b [lindex $vleftptr($v) $a]
1099 if {$b != 0} break
1100 set a [lindex $vupptr($v) $a]
1102 if {$a == 0} break
1104 set a $b
1105 incr arcn
1106 lappend vrownum($v) $row
1107 lappend varcorder($v) $a
1108 lset varcix($v) $a $arcn
1109 lset varcrow($v) $a $row
1111 set vtokmod($v) [lindex $varctok($v) $p]
1112 set varcmod($v) $p
1113 set vrowmod($v) $row
1114 if {[info exists currentid]} {
1115 set selectedline [rowofcommit $currentid]
1119 # Test whether view $v contains commit $id
1120 proc commitinview {id v} {
1121 global varcid
1123 return [info exists varcid($v,$id)]
1126 # Return the row number for commit $id in the current view
1127 proc rowofcommit {id} {
1128 global varcid varccommits varcrow curview cached_commitrow
1129 global varctok vtokmod
1131 set v $curview
1132 if {![info exists varcid($v,$id)]} {
1133 puts "oops rowofcommit no arc for [shortids $id]"
1134 return {}
1136 set a $varcid($v,$id)
1137 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1138 update_arcrows $v
1140 if {[info exists cached_commitrow($id)]} {
1141 return $cached_commitrow($id)
1143 set i [lsearch -exact $varccommits($v,$a) $id]
1144 if {$i < 0} {
1145 puts "oops didn't find commit [shortids $id] in arc $a"
1146 return {}
1148 incr i [lindex $varcrow($v) $a]
1149 set cached_commitrow($id) $i
1150 return $i
1153 # Returns 1 if a is on an earlier row than b, otherwise 0
1154 proc comes_before {a b} {
1155 global varcid varctok curview
1157 set v $curview
1158 if {$a eq $b || ![info exists varcid($v,$a)] || \
1159 ![info exists varcid($v,$b)]} {
1160 return 0
1162 if {$varcid($v,$a) != $varcid($v,$b)} {
1163 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1164 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1166 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1169 proc bsearch {l elt} {
1170 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1171 return 0
1173 set lo 0
1174 set hi [llength $l]
1175 while {$hi - $lo > 1} {
1176 set mid [expr {int(($lo + $hi) / 2)}]
1177 set t [lindex $l $mid]
1178 if {$elt < $t} {
1179 set hi $mid
1180 } elseif {$elt > $t} {
1181 set lo $mid
1182 } else {
1183 return $mid
1186 return $lo
1189 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1190 proc make_disporder {start end} {
1191 global vrownum curview commitidx displayorder parentlist
1192 global varccommits varcorder parents vrowmod varcrow
1193 global d_valid_start d_valid_end
1195 if {$end > $vrowmod($curview)} {
1196 update_arcrows $curview
1198 set ai [bsearch $vrownum($curview) $start]
1199 set start [lindex $vrownum($curview) $ai]
1200 set narc [llength $vrownum($curview)]
1201 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1202 set a [lindex $varcorder($curview) $ai]
1203 set l [llength $displayorder]
1204 set al [llength $varccommits($curview,$a)]
1205 if {$l < $r + $al} {
1206 if {$l < $r} {
1207 set pad [ntimes [expr {$r - $l}] {}]
1208 set displayorder [concat $displayorder $pad]
1209 set parentlist [concat $parentlist $pad]
1210 } elseif {$l > $r} {
1211 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1212 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1214 foreach id $varccommits($curview,$a) {
1215 lappend displayorder $id
1216 lappend parentlist $parents($curview,$id)
1218 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1219 set i $r
1220 foreach id $varccommits($curview,$a) {
1221 lset displayorder $i $id
1222 lset parentlist $i $parents($curview,$id)
1223 incr i
1226 incr r $al
1230 proc commitonrow {row} {
1231 global displayorder
1233 set id [lindex $displayorder $row]
1234 if {$id eq {}} {
1235 make_disporder $row [expr {$row + 1}]
1236 set id [lindex $displayorder $row]
1238 return $id
1241 proc closevarcs {v} {
1242 global varctok varccommits varcid parents children
1243 global cmitlisted commitidx vtokmod
1245 set missing_parents 0
1246 set scripts {}
1247 set narcs [llength $varctok($v)]
1248 for {set a 1} {$a < $narcs} {incr a} {
1249 set id [lindex $varccommits($v,$a) end]
1250 foreach p $parents($v,$id) {
1251 if {[info exists varcid($v,$p)]} continue
1252 # add p as a new commit
1253 incr missing_parents
1254 set cmitlisted($v,$p) 0
1255 set parents($v,$p) {}
1256 if {[llength $children($v,$p)] == 1 &&
1257 [llength $parents($v,$id)] == 1} {
1258 set b $a
1259 } else {
1260 set b [newvarc $v $p]
1262 set varcid($v,$p) $b
1263 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1264 modify_arc $v $b
1266 lappend varccommits($v,$b) $p
1267 incr commitidx($v)
1268 set scripts [check_interest $p $scripts]
1271 if {$missing_parents > 0} {
1272 foreach s $scripts {
1273 eval $s
1278 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1279 # Assumes we already have an arc for $rwid.
1280 proc rewrite_commit {v id rwid} {
1281 global children parents varcid varctok vtokmod varccommits
1283 foreach ch $children($v,$id) {
1284 # make $rwid be $ch's parent in place of $id
1285 set i [lsearch -exact $parents($v,$ch) $id]
1286 if {$i < 0} {
1287 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1289 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1290 # add $ch to $rwid's children and sort the list if necessary
1291 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1292 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1293 $children($v,$rwid)]
1295 # fix the graph after joining $id to $rwid
1296 set a $varcid($v,$ch)
1297 fix_reversal $rwid $a $v
1298 # parentlist is wrong for the last element of arc $a
1299 # even if displayorder is right, hence the 3rd arg here
1300 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1304 # Mechanism for registering a command to be executed when we come
1305 # across a particular commit. To handle the case when only the
1306 # prefix of the commit is known, the commitinterest array is now
1307 # indexed by the first 4 characters of the ID. Each element is a
1308 # list of id, cmd pairs.
1309 proc interestedin {id cmd} {
1310 global commitinterest
1312 lappend commitinterest([string range $id 0 3]) $id $cmd
1315 proc check_interest {id scripts} {
1316 global commitinterest
1318 set prefix [string range $id 0 3]
1319 if {[info exists commitinterest($prefix)]} {
1320 set newlist {}
1321 foreach {i script} $commitinterest($prefix) {
1322 if {[string match "$i*" $id]} {
1323 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1324 } else {
1325 lappend newlist $i $script
1328 if {$newlist ne {}} {
1329 set commitinterest($prefix) $newlist
1330 } else {
1331 unset commitinterest($prefix)
1334 return $scripts
1337 proc getcommitlines {fd inst view updating} {
1338 global cmitlisted leftover
1339 global commitidx commitdata vdatemode
1340 global parents children curview hlview
1341 global idpending ordertok
1342 global varccommits varcid varctok vtokmod vfilelimit
1344 set stuff [read $fd 500000]
1345 # git log doesn't terminate the last commit with a null...
1346 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1347 set stuff "\0"
1349 if {$stuff == {}} {
1350 if {![eof $fd]} {
1351 return 1
1353 global commfd viewcomplete viewactive viewname
1354 global viewinstances
1355 unset commfd($inst)
1356 set i [lsearch -exact $viewinstances($view) $inst]
1357 if {$i >= 0} {
1358 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1360 # set it blocking so we wait for the process to terminate
1361 fconfigure $fd -blocking 1
1362 if {[catch {close $fd} err]} {
1363 set fv {}
1364 if {$view != $curview} {
1365 set fv " for the \"$viewname($view)\" view"
1367 if {[string range $err 0 4] == "usage"} {
1368 set err "Gitk: error reading commits$fv:\
1369 bad arguments to git log."
1370 if {$viewname($view) eq "Command line"} {
1371 append err \
1372 " (Note: arguments to gitk are passed to git log\
1373 to allow selection of commits to be displayed.)"
1375 } else {
1376 set err "Error reading commits$fv: $err"
1378 error_popup $err
1380 if {[incr viewactive($view) -1] <= 0} {
1381 set viewcomplete($view) 1
1382 # Check if we have seen any ids listed as parents that haven't
1383 # appeared in the list
1384 closevarcs $view
1385 notbusy $view
1387 if {$view == $curview} {
1388 run chewcommits
1390 return 0
1392 set start 0
1393 set gotsome 0
1394 set scripts {}
1395 while 1 {
1396 set i [string first "\0" $stuff $start]
1397 if {$i < 0} {
1398 append leftover($inst) [string range $stuff $start end]
1399 break
1401 if {$start == 0} {
1402 set cmit $leftover($inst)
1403 append cmit [string range $stuff 0 [expr {$i - 1}]]
1404 set leftover($inst) {}
1405 } else {
1406 set cmit [string range $stuff $start [expr {$i - 1}]]
1408 set start [expr {$i + 1}]
1409 set j [string first "\n" $cmit]
1410 set ok 0
1411 set listed 1
1412 if {$j >= 0 && [string match "commit *" $cmit]} {
1413 set ids [string range $cmit 7 [expr {$j - 1}]]
1414 if {[string match {[-^<>]*} $ids]} {
1415 switch -- [string index $ids 0] {
1416 "-" {set listed 0}
1417 "^" {set listed 2}
1418 "<" {set listed 3}
1419 ">" {set listed 4}
1421 set ids [string range $ids 1 end]
1423 set ok 1
1424 foreach id $ids {
1425 if {[string length $id] != 40} {
1426 set ok 0
1427 break
1431 if {!$ok} {
1432 set shortcmit $cmit
1433 if {[string length $shortcmit] > 80} {
1434 set shortcmit "[string range $shortcmit 0 80]..."
1436 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1437 exit 1
1439 set id [lindex $ids 0]
1440 set vid $view,$id
1442 if {!$listed && $updating && ![info exists varcid($vid)] &&
1443 $vfilelimit($view) ne {}} {
1444 # git log doesn't rewrite parents for unlisted commits
1445 # when doing path limiting, so work around that here
1446 # by working out the rewritten parent with git rev-list
1447 # and if we already know about it, using the rewritten
1448 # parent as a substitute parent for $id's children.
1449 if {![catch {
1450 set rwid [exec git rev-list --first-parent --max-count=1 \
1451 $id -- $vfilelimit($view)]
1452 }]} {
1453 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1454 # use $rwid in place of $id
1455 rewrite_commit $view $id $rwid
1456 continue
1461 set a 0
1462 if {[info exists varcid($vid)]} {
1463 if {$cmitlisted($vid) || !$listed} continue
1464 set a $varcid($vid)
1466 if {$listed} {
1467 set olds [lrange $ids 1 end]
1468 } else {
1469 set olds {}
1471 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1472 set cmitlisted($vid) $listed
1473 set parents($vid) $olds
1474 if {![info exists children($vid)]} {
1475 set children($vid) {}
1476 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1477 set k [lindex $children($vid) 0]
1478 if {[llength $parents($view,$k)] == 1 &&
1479 (!$vdatemode($view) ||
1480 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1481 set a $varcid($view,$k)
1484 if {$a == 0} {
1485 # new arc
1486 set a [newvarc $view $id]
1488 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1489 modify_arc $view $a
1491 if {![info exists varcid($vid)]} {
1492 set varcid($vid) $a
1493 lappend varccommits($view,$a) $id
1494 incr commitidx($view)
1497 set i 0
1498 foreach p $olds {
1499 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1500 set vp $view,$p
1501 if {[llength [lappend children($vp) $id]] > 1 &&
1502 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1503 set children($vp) [lsort -command [list vtokcmp $view] \
1504 $children($vp)]
1505 catch {unset ordertok}
1507 if {[info exists varcid($view,$p)]} {
1508 fix_reversal $p $a $view
1511 incr i
1514 set scripts [check_interest $id $scripts]
1515 set gotsome 1
1517 if {$gotsome} {
1518 global numcommits hlview
1520 if {$view == $curview} {
1521 set numcommits $commitidx($view)
1522 run chewcommits
1524 if {[info exists hlview] && $view == $hlview} {
1525 # we never actually get here...
1526 run vhighlightmore
1528 foreach s $scripts {
1529 eval $s
1532 return 2
1535 proc chewcommits {} {
1536 global curview hlview viewcomplete
1537 global pending_select
1539 layoutmore
1540 if {$viewcomplete($curview)} {
1541 global commitidx varctok
1542 global numcommits startmsecs
1544 if {[info exists pending_select]} {
1545 update
1546 reset_pending_select {}
1548 if {[commitinview $pending_select $curview]} {
1549 selectline [rowofcommit $pending_select] 1
1550 } else {
1551 set row [first_real_row]
1552 selectline $row 1
1555 if {$commitidx($curview) > 0} {
1556 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1557 #puts "overall $ms ms for $numcommits commits"
1558 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1559 } else {
1560 show_status [mc "No commits selected"]
1562 notbusy layout
1564 return 0
1567 proc do_readcommit {id} {
1568 global tclencoding
1570 # Invoke git-log to handle automatic encoding conversion
1571 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1572 # Read the results using i18n.logoutputencoding
1573 fconfigure $fd -translation lf -eofchar {}
1574 if {$tclencoding != {}} {
1575 fconfigure $fd -encoding $tclencoding
1577 set contents [read $fd]
1578 close $fd
1579 # Remove the heading line
1580 regsub {^commit [0-9a-f]+\n} $contents {} contents
1582 return $contents
1585 proc readcommit {id} {
1586 if {[catch {set contents [do_readcommit $id]}]} return
1587 parsecommit $id $contents 1
1590 proc parsecommit {id contents listed} {
1591 global commitinfo cdate
1593 set inhdr 1
1594 set comment {}
1595 set headline {}
1596 set auname {}
1597 set audate {}
1598 set comname {}
1599 set comdate {}
1600 set hdrend [string first "\n\n" $contents]
1601 if {$hdrend < 0} {
1602 # should never happen...
1603 set hdrend [string length $contents]
1605 set header [string range $contents 0 [expr {$hdrend - 1}]]
1606 set comment [string range $contents [expr {$hdrend + 2}] end]
1607 foreach line [split $header "\n"] {
1608 set line [split $line " "]
1609 set tag [lindex $line 0]
1610 if {$tag == "author"} {
1611 set audate [lindex $line end-1]
1612 set auname [join [lrange $line 1 end-2] " "]
1613 } elseif {$tag == "committer"} {
1614 set comdate [lindex $line end-1]
1615 set comname [join [lrange $line 1 end-2] " "]
1618 set headline {}
1619 # take the first non-blank line of the comment as the headline
1620 set headline [string trimleft $comment]
1621 set i [string first "\n" $headline]
1622 if {$i >= 0} {
1623 set headline [string range $headline 0 $i]
1625 set headline [string trimright $headline]
1626 set i [string first "\r" $headline]
1627 if {$i >= 0} {
1628 set headline [string trimright [string range $headline 0 $i]]
1630 if {!$listed} {
1631 # git log indents the comment by 4 spaces;
1632 # if we got this via git cat-file, add the indentation
1633 set newcomment {}
1634 foreach line [split $comment "\n"] {
1635 append newcomment " "
1636 append newcomment $line
1637 append newcomment "\n"
1639 set comment $newcomment
1641 if {$comdate != {}} {
1642 set cdate($id) $comdate
1644 set commitinfo($id) [list $headline $auname $audate \
1645 $comname $comdate $comment]
1648 proc getcommit {id} {
1649 global commitdata commitinfo
1651 if {[info exists commitdata($id)]} {
1652 parsecommit $id $commitdata($id) 1
1653 } else {
1654 readcommit $id
1655 if {![info exists commitinfo($id)]} {
1656 set commitinfo($id) [list [mc "No commit information available"]]
1659 return 1
1662 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1663 # and are present in the current view.
1664 # This is fairly slow...
1665 proc longid {prefix} {
1666 global varcid curview
1668 set ids {}
1669 foreach match [array names varcid "$curview,$prefix*"] {
1670 lappend ids [lindex [split $match ","] 1]
1672 return $ids
1675 proc readrefs {} {
1676 global tagids idtags headids idheads tagobjid
1677 global otherrefids idotherrefs mainhead mainheadid
1678 global selecthead selectheadid
1680 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1681 catch {unset $v}
1683 set refd [open [list | git show-ref -d] r]
1684 while {[gets $refd line] >= 0} {
1685 if {[string index $line 40] ne " "} continue
1686 set id [string range $line 0 39]
1687 set ref [string range $line 41 end]
1688 if {![string match "refs/*" $ref]} continue
1689 set name [string range $ref 5 end]
1690 if {[string match "remotes/*" $name]} {
1691 if {![string match "*/HEAD" $name]} {
1692 set headids($name) $id
1693 lappend idheads($id) $name
1695 } elseif {[string match "heads/*" $name]} {
1696 set name [string range $name 6 end]
1697 set headids($name) $id
1698 lappend idheads($id) $name
1699 } elseif {[string match "tags/*" $name]} {
1700 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1701 # which is what we want since the former is the commit ID
1702 set name [string range $name 5 end]
1703 if {[string match "*^{}" $name]} {
1704 set name [string range $name 0 end-3]
1705 } else {
1706 set tagobjid($name) $id
1708 set tagids($name) $id
1709 lappend idtags($id) $name
1710 } else {
1711 set otherrefids($name) $id
1712 lappend idotherrefs($id) $name
1715 catch {close $refd}
1716 set mainhead {}
1717 set mainheadid {}
1718 catch {
1719 set mainheadid [exec git rev-parse HEAD]
1720 set thehead [exec git symbolic-ref HEAD]
1721 if {[string match "refs/heads/*" $thehead]} {
1722 set mainhead [string range $thehead 11 end]
1725 set selectheadid {}
1726 if {$selecthead ne {}} {
1727 catch {
1728 set selectheadid [exec git rev-parse --verify $selecthead]
1733 # skip over fake commits
1734 proc first_real_row {} {
1735 global nullid nullid2 numcommits
1737 for {set row 0} {$row < $numcommits} {incr row} {
1738 set id [commitonrow $row]
1739 if {$id ne $nullid && $id ne $nullid2} {
1740 break
1743 return $row
1746 # update things for a head moved to a child of its previous location
1747 proc movehead {id name} {
1748 global headids idheads
1750 removehead $headids($name) $name
1751 set headids($name) $id
1752 lappend idheads($id) $name
1755 # update things when a head has been removed
1756 proc removehead {id name} {
1757 global headids idheads
1759 if {$idheads($id) eq $name} {
1760 unset idheads($id)
1761 } else {
1762 set i [lsearch -exact $idheads($id) $name]
1763 if {$i >= 0} {
1764 set idheads($id) [lreplace $idheads($id) $i $i]
1767 unset headids($name)
1770 proc make_transient {window origin} {
1771 global have_tk85
1773 # In MacOS Tk 8.4 transient appears to work by setting
1774 # overrideredirect, which is utterly useless, since the
1775 # windows get no border, and are not even kept above
1776 # the parent.
1777 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1779 wm transient $window $origin
1781 # Windows fails to place transient windows normally, so
1782 # schedule a callback to center them on the parent.
1783 if {[tk windowingsystem] eq {win32}} {
1784 after idle [list tk::PlaceWindow $window widget $origin]
1788 proc show_error {w top msg} {
1789 message $w.m -text $msg -justify center -aspect 400
1790 pack $w.m -side top -fill x -padx 20 -pady 20
1791 button $w.ok -text [mc OK] -command "destroy $top"
1792 pack $w.ok -side bottom -fill x
1793 bind $top <Visibility> "grab $top; focus $top"
1794 bind $top <Key-Return> "destroy $top"
1795 bind $top <Key-space> "destroy $top"
1796 bind $top <Key-Escape> "destroy $top"
1797 tkwait window $top
1800 proc error_popup {msg {owner .}} {
1801 set w .error
1802 toplevel $w
1803 make_transient $w $owner
1804 show_error $w $w $msg
1807 proc confirm_popup {msg {owner .}} {
1808 global confirm_ok
1809 set confirm_ok 0
1810 set w .confirm
1811 toplevel $w
1812 make_transient $w $owner
1813 message $w.m -text $msg -justify center -aspect 400
1814 pack $w.m -side top -fill x -padx 20 -pady 20
1815 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1816 pack $w.ok -side left -fill x
1817 button $w.cancel -text [mc Cancel] -command "destroy $w"
1818 pack $w.cancel -side right -fill x
1819 bind $w <Visibility> "grab $w; focus $w"
1820 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1821 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1822 bind $w <Key-Escape> "destroy $w"
1823 tkwait window $w
1824 return $confirm_ok
1827 proc setoptions {} {
1828 option add *Panedwindow.showHandle 1 startupFile
1829 option add *Panedwindow.sashRelief raised startupFile
1830 option add *Button.font uifont startupFile
1831 option add *Checkbutton.font uifont startupFile
1832 option add *Radiobutton.font uifont startupFile
1833 option add *Menu.font uifont startupFile
1834 option add *Menubutton.font uifont startupFile
1835 option add *Label.font uifont startupFile
1836 option add *Message.font uifont startupFile
1837 option add *Entry.font uifont startupFile
1840 # Make a menu and submenus.
1841 # m is the window name for the menu, items is the list of menu items to add.
1842 # Each item is a list {mc label type description options...}
1843 # mc is ignored; it's so we can put mc there to alert xgettext
1844 # label is the string that appears in the menu
1845 # type is cascade, command or radiobutton (should add checkbutton)
1846 # description depends on type; it's the sublist for cascade, the
1847 # command to invoke for command, or {variable value} for radiobutton
1848 proc makemenu {m items} {
1849 menu $m
1850 if {[tk windowingsystem] eq {aqua}} {
1851 set Meta1 Cmd
1852 } else {
1853 set Meta1 Ctrl
1855 foreach i $items {
1856 set name [mc [lindex $i 1]]
1857 set type [lindex $i 2]
1858 set thing [lindex $i 3]
1859 set params [list $type]
1860 if {$name ne {}} {
1861 set u [string first "&" [string map {&& x} $name]]
1862 lappend params -label [string map {&& & & {}} $name]
1863 if {$u >= 0} {
1864 lappend params -underline $u
1867 switch -- $type {
1868 "cascade" {
1869 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1870 lappend params -menu $m.$submenu
1872 "command" {
1873 lappend params -command $thing
1875 "radiobutton" {
1876 lappend params -variable [lindex $thing 0] \
1877 -value [lindex $thing 1]
1880 set tail [lrange $i 4 end]
1881 regsub -all {\yMeta1\y} $tail $Meta1 tail
1882 eval $m add $params $tail
1883 if {$type eq "cascade"} {
1884 makemenu $m.$submenu $thing
1889 # translate string and remove ampersands
1890 proc mca {str} {
1891 return [string map {&& & & {}} [mc $str]]
1894 proc makewindow {} {
1895 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1896 global tabstop
1897 global findtype findtypemenu findloc findstring fstring geometry
1898 global entries sha1entry sha1string sha1but
1899 global diffcontextstring diffcontext
1900 global ignorespace
1901 global maincursor textcursor curtextcursor
1902 global rowctxmenu fakerowmenu mergemax wrapcomment
1903 global highlight_files gdttype
1904 global searchstring sstring
1905 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1906 global headctxmenu progresscanv progressitem progresscoords statusw
1907 global fprogitem fprogcoord lastprogupdate progupdatepending
1908 global rprogitem rprogcoord rownumsel numcommits
1909 global have_tk85
1911 # The "mc" arguments here are purely so that xgettext
1912 # sees the following string as needing to be translated
1913 makemenu .bar {
1914 {mc "File" cascade {
1915 {mc "Update" command updatecommits -accelerator F5}
1916 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1917 {mc "Reread references" command rereadrefs}
1918 {mc "List references" command showrefs -accelerator F2}
1919 {xx "" separator}
1920 {mc "Start git gui" command {exec git gui &}}
1921 {xx "" separator}
1922 {mc "Quit" command doquit -accelerator Meta1-Q}
1924 {mc "Edit" cascade {
1925 {mc "Preferences" command doprefs}
1927 {mc "View" cascade {
1928 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1929 {mc "Edit view..." command editview -state disabled -accelerator F4}
1930 {mc "Delete view" command delview -state disabled}
1931 {xx "" separator}
1932 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1934 {mc "Help" cascade {
1935 {mc "About gitk" command about}
1936 {mc "Key bindings" command keys}
1939 . configure -menu .bar
1941 # the gui has upper and lower half, parts of a paned window.
1942 panedwindow .ctop -orient vertical
1944 # possibly use assumed geometry
1945 if {![info exists geometry(pwsash0)]} {
1946 set geometry(topheight) [expr {15 * $linespc}]
1947 set geometry(topwidth) [expr {80 * $charspc}]
1948 set geometry(botheight) [expr {15 * $linespc}]
1949 set geometry(botwidth) [expr {50 * $charspc}]
1950 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1951 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1954 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1955 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1956 frame .tf.histframe
1957 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1959 # create three canvases
1960 set cscroll .tf.histframe.csb
1961 set canv .tf.histframe.pwclist.canv
1962 canvas $canv \
1963 -selectbackground $selectbgcolor \
1964 -background $bgcolor -bd 0 \
1965 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1966 .tf.histframe.pwclist add $canv
1967 set canv2 .tf.histframe.pwclist.canv2
1968 canvas $canv2 \
1969 -selectbackground $selectbgcolor \
1970 -background $bgcolor -bd 0 -yscrollincr $linespc
1971 .tf.histframe.pwclist add $canv2
1972 set canv3 .tf.histframe.pwclist.canv3
1973 canvas $canv3 \
1974 -selectbackground $selectbgcolor \
1975 -background $bgcolor -bd 0 -yscrollincr $linespc
1976 .tf.histframe.pwclist add $canv3
1977 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1978 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1980 # a scroll bar to rule them
1981 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1982 pack $cscroll -side right -fill y
1983 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1984 lappend bglist $canv $canv2 $canv3
1985 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1987 # we have two button bars at bottom of top frame. Bar 1
1988 frame .tf.bar
1989 frame .tf.lbar -height 15
1991 set sha1entry .tf.bar.sha1
1992 set entries $sha1entry
1993 set sha1but .tf.bar.sha1label
1994 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1995 -command gotocommit -width 8
1996 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1997 pack .tf.bar.sha1label -side left
1998 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1999 trace add variable sha1string write sha1change
2000 pack $sha1entry -side left -pady 2
2002 image create bitmap bm-left -data {
2003 #define left_width 16
2004 #define left_height 16
2005 static unsigned char left_bits[] = {
2006 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2007 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2008 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2010 image create bitmap bm-right -data {
2011 #define right_width 16
2012 #define right_height 16
2013 static unsigned char right_bits[] = {
2014 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2015 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2016 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2018 button .tf.bar.leftbut -image bm-left -command goback \
2019 -state disabled -width 26
2020 pack .tf.bar.leftbut -side left -fill y
2021 button .tf.bar.rightbut -image bm-right -command goforw \
2022 -state disabled -width 26
2023 pack .tf.bar.rightbut -side left -fill y
2025 label .tf.bar.rowlabel -text [mc "Row"]
2026 set rownumsel {}
2027 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2028 -relief sunken -anchor e
2029 label .tf.bar.rowlabel2 -text "/"
2030 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2031 -relief sunken -anchor e
2032 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2033 -side left
2034 global selectedline
2035 trace add variable selectedline write selectedline_change
2037 # Status label and progress bar
2038 set statusw .tf.bar.status
2039 label $statusw -width 15 -relief sunken
2040 pack $statusw -side left -padx 5
2041 set h [expr {[font metrics uifont -linespace] + 2}]
2042 set progresscanv .tf.bar.progress
2043 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2044 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2045 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2046 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2047 pack $progresscanv -side right -expand 1 -fill x
2048 set progresscoords {0 0}
2049 set fprogcoord 0
2050 set rprogcoord 0
2051 bind $progresscanv <Configure> adjustprogress
2052 set lastprogupdate [clock clicks -milliseconds]
2053 set progupdatepending 0
2055 # build up the bottom bar of upper window
2056 label .tf.lbar.flabel -text "[mc "Find"] "
2057 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2058 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2059 label .tf.lbar.flab2 -text " [mc "commit"] "
2060 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2061 -side left -fill y
2062 set gdttype [mc "containing:"]
2063 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2064 [mc "containing:"] \
2065 [mc "touching paths:"] \
2066 [mc "adding/removing string:"]]
2067 trace add variable gdttype write gdttype_change
2068 pack .tf.lbar.gdttype -side left -fill y
2070 set findstring {}
2071 set fstring .tf.lbar.findstring
2072 lappend entries $fstring
2073 entry $fstring -width 30 -font textfont -textvariable findstring
2074 trace add variable findstring write find_change
2075 set findtype [mc "Exact"]
2076 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2077 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2078 trace add variable findtype write findcom_change
2079 set findloc [mc "All fields"]
2080 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2081 [mc "Comments"] [mc "Author"] [mc "Committer"]
2082 trace add variable findloc write find_change
2083 pack .tf.lbar.findloc -side right
2084 pack .tf.lbar.findtype -side right
2085 pack $fstring -side left -expand 1 -fill x
2087 # Finish putting the upper half of the viewer together
2088 pack .tf.lbar -in .tf -side bottom -fill x
2089 pack .tf.bar -in .tf -side bottom -fill x
2090 pack .tf.histframe -fill both -side top -expand 1
2091 .ctop add .tf
2092 .ctop paneconfigure .tf -height $geometry(topheight)
2093 .ctop paneconfigure .tf -width $geometry(topwidth)
2095 # now build up the bottom
2096 panedwindow .pwbottom -orient horizontal
2098 # lower left, a text box over search bar, scroll bar to the right
2099 # if we know window height, then that will set the lower text height, otherwise
2100 # we set lower text height which will drive window height
2101 if {[info exists geometry(main)]} {
2102 frame .bleft -width $geometry(botwidth)
2103 } else {
2104 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2106 frame .bleft.top
2107 frame .bleft.mid
2108 frame .bleft.bottom
2110 button .bleft.top.search -text [mc "Search"] -command dosearch
2111 pack .bleft.top.search -side left -padx 5
2112 set sstring .bleft.top.sstring
2113 entry $sstring -width 20 -font textfont -textvariable searchstring
2114 lappend entries $sstring
2115 trace add variable searchstring write incrsearch
2116 pack $sstring -side left -expand 1 -fill x
2117 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2118 -command changediffdisp -variable diffelide -value {0 0}
2119 radiobutton .bleft.mid.old -text [mc "Old version"] \
2120 -command changediffdisp -variable diffelide -value {0 1}
2121 radiobutton .bleft.mid.new -text [mc "New version"] \
2122 -command changediffdisp -variable diffelide -value {1 0}
2123 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2124 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2125 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2126 -from 1 -increment 1 -to 10000000 \
2127 -validate all -validatecommand "diffcontextvalidate %P" \
2128 -textvariable diffcontextstring
2129 .bleft.mid.diffcontext set $diffcontext
2130 trace add variable diffcontextstring write diffcontextchange
2131 lappend entries .bleft.mid.diffcontext
2132 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2133 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2134 -command changeignorespace -variable ignorespace
2135 pack .bleft.mid.ignspace -side left -padx 5
2136 set ctext .bleft.bottom.ctext
2137 text $ctext -background $bgcolor -foreground $fgcolor \
2138 -state disabled -font textfont \
2139 -yscrollcommand scrolltext -wrap none \
2140 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2141 if {$have_tk85} {
2142 $ctext conf -tabstyle wordprocessor
2144 scrollbar .bleft.bottom.sb -command "$ctext yview"
2145 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2146 -width 10
2147 pack .bleft.top -side top -fill x
2148 pack .bleft.mid -side top -fill x
2149 grid $ctext .bleft.bottom.sb -sticky nsew
2150 grid .bleft.bottom.sbhorizontal -sticky ew
2151 grid columnconfigure .bleft.bottom 0 -weight 1
2152 grid rowconfigure .bleft.bottom 0 -weight 1
2153 grid rowconfigure .bleft.bottom 1 -weight 0
2154 pack .bleft.bottom -side top -fill both -expand 1
2155 lappend bglist $ctext
2156 lappend fglist $ctext
2158 $ctext tag conf comment -wrap $wrapcomment
2159 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2160 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2161 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2162 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2163 $ctext tag conf m0 -fore red
2164 $ctext tag conf m1 -fore blue
2165 $ctext tag conf m2 -fore green
2166 $ctext tag conf m3 -fore purple
2167 $ctext tag conf m4 -fore brown
2168 $ctext tag conf m5 -fore "#009090"
2169 $ctext tag conf m6 -fore magenta
2170 $ctext tag conf m7 -fore "#808000"
2171 $ctext tag conf m8 -fore "#009000"
2172 $ctext tag conf m9 -fore "#ff0080"
2173 $ctext tag conf m10 -fore cyan
2174 $ctext tag conf m11 -fore "#b07070"
2175 $ctext tag conf m12 -fore "#70b0f0"
2176 $ctext tag conf m13 -fore "#70f0b0"
2177 $ctext tag conf m14 -fore "#f0b070"
2178 $ctext tag conf m15 -fore "#ff70b0"
2179 $ctext tag conf mmax -fore darkgrey
2180 set mergemax 16
2181 $ctext tag conf mresult -font textfontbold
2182 $ctext tag conf msep -font textfontbold
2183 $ctext tag conf found -back yellow
2185 .pwbottom add .bleft
2186 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2188 # lower right
2189 frame .bright
2190 frame .bright.mode
2191 radiobutton .bright.mode.patch -text [mc "Patch"] \
2192 -command reselectline -variable cmitmode -value "patch"
2193 radiobutton .bright.mode.tree -text [mc "Tree"] \
2194 -command reselectline -variable cmitmode -value "tree"
2195 grid .bright.mode.patch .bright.mode.tree -sticky ew
2196 pack .bright.mode -side top -fill x
2197 set cflist .bright.cfiles
2198 set indent [font measure mainfont "nn"]
2199 text $cflist \
2200 -selectbackground $selectbgcolor \
2201 -background $bgcolor -foreground $fgcolor \
2202 -font mainfont \
2203 -tabs [list $indent [expr {2 * $indent}]] \
2204 -yscrollcommand ".bright.sb set" \
2205 -cursor [. cget -cursor] \
2206 -spacing1 1 -spacing3 1
2207 lappend bglist $cflist
2208 lappend fglist $cflist
2209 scrollbar .bright.sb -command "$cflist yview"
2210 pack .bright.sb -side right -fill y
2211 pack $cflist -side left -fill both -expand 1
2212 $cflist tag configure highlight \
2213 -background [$cflist cget -selectbackground]
2214 $cflist tag configure bold -font mainfontbold
2216 .pwbottom add .bright
2217 .ctop add .pwbottom
2219 # restore window width & height if known
2220 if {[info exists geometry(main)]} {
2221 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2222 if {$w > [winfo screenwidth .]} {
2223 set w [winfo screenwidth .]
2225 if {$h > [winfo screenheight .]} {
2226 set h [winfo screenheight .]
2228 wm geometry . "${w}x$h"
2232 if {[tk windowingsystem] eq {aqua}} {
2233 set M1B M1
2234 } else {
2235 set M1B Control
2238 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2239 pack .ctop -fill both -expand 1
2240 bindall <1> {selcanvline %W %x %y}
2241 #bindall <B1-Motion> {selcanvline %W %x %y}
2242 if {[tk windowingsystem] == "win32"} {
2243 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2244 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2245 } else {
2246 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2247 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2248 if {[tk windowingsystem] eq "aqua"} {
2249 bindall <MouseWheel> {
2250 set delta [expr {- (%D)}]
2251 allcanvs yview scroll $delta units
2255 bindall <2> "canvscan mark %W %x %y"
2256 bindall <B2-Motion> "canvscan dragto %W %x %y"
2257 bindkey <Home> selfirstline
2258 bindkey <End> sellastline
2259 bind . <Key-Up> "selnextline -1"
2260 bind . <Key-Down> "selnextline 1"
2261 bind . <Shift-Key-Up> "dofind -1 0"
2262 bind . <Shift-Key-Down> "dofind 1 0"
2263 bindkey <Key-Right> "goforw"
2264 bindkey <Key-Left> "goback"
2265 bind . <Key-Prior> "selnextpage -1"
2266 bind . <Key-Next> "selnextpage 1"
2267 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2268 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2269 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2270 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2271 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2272 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2273 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2274 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2275 bindkey <Key-space> "$ctext yview scroll 1 pages"
2276 bindkey p "selnextline -1"
2277 bindkey n "selnextline 1"
2278 bindkey z "goback"
2279 bindkey x "goforw"
2280 bindkey i "selnextline -1"
2281 bindkey k "selnextline 1"
2282 bindkey j "goback"
2283 bindkey l "goforw"
2284 bindkey b prevfile
2285 bindkey d "$ctext yview scroll 18 units"
2286 bindkey u "$ctext yview scroll -18 units"
2287 bindkey / {focus $fstring}
2288 bindkey <Key-Return> {dofind 1 1}
2289 bindkey ? {dofind -1 1}
2290 bindkey f nextfile
2291 bind . <F5> updatecommits
2292 bind . <$M1B-F5> reloadcommits
2293 bind . <F2> showrefs
2294 bind . <Shift-F4> {newview 0}
2295 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2296 bind . <F4> edit_or_newview
2297 bind . <$M1B-q> doquit
2298 bind . <$M1B-f> {dofind 1 1}
2299 bind . <$M1B-g> {dofind 1 0}
2300 bind . <$M1B-r> dosearchback
2301 bind . <$M1B-s> dosearch
2302 bind . <$M1B-equal> {incrfont 1}
2303 bind . <$M1B-plus> {incrfont 1}
2304 bind . <$M1B-KP_Add> {incrfont 1}
2305 bind . <$M1B-minus> {incrfont -1}
2306 bind . <$M1B-KP_Subtract> {incrfont -1}
2307 wm protocol . WM_DELETE_WINDOW doquit
2308 bind . <Destroy> {stop_backends}
2309 bind . <Button-1> "click %W"
2310 bind $fstring <Key-Return> {dofind 1 1}
2311 bind $sha1entry <Key-Return> {gotocommit; break}
2312 bind $sha1entry <<PasteSelection>> clearsha1
2313 bind $cflist <1> {sel_flist %W %x %y; break}
2314 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2315 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2316 global ctxbut
2317 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2318 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2320 set maincursor [. cget -cursor]
2321 set textcursor [$ctext cget -cursor]
2322 set curtextcursor $textcursor
2324 set rowctxmenu .rowctxmenu
2325 makemenu $rowctxmenu {
2326 {mc "Diff this -> selected" command {diffvssel 0}}
2327 {mc "Diff selected -> this" command {diffvssel 1}}
2328 {mc "Make patch" command mkpatch}
2329 {mc "Create tag" command mktag}
2330 {mc "Write commit to file" command writecommit}
2331 {mc "Create new branch" command mkbranch}
2332 {mc "Cherry-pick this commit" command cherrypick}
2333 {mc "Reset HEAD branch to here" command resethead}
2335 $rowctxmenu configure -tearoff 0
2337 set fakerowmenu .fakerowmenu
2338 makemenu $fakerowmenu {
2339 {mc "Diff this -> selected" command {diffvssel 0}}
2340 {mc "Diff selected -> this" command {diffvssel 1}}
2341 {mc "Make patch" command mkpatch}
2343 $fakerowmenu configure -tearoff 0
2345 set headctxmenu .headctxmenu
2346 makemenu $headctxmenu {
2347 {mc "Check out this branch" command cobranch}
2348 {mc "Remove this branch" command rmbranch}
2350 $headctxmenu configure -tearoff 0
2352 global flist_menu
2353 set flist_menu .flistctxmenu
2354 makemenu $flist_menu {
2355 {mc "Highlight this too" command {flist_hl 0}}
2356 {mc "Highlight this only" command {flist_hl 1}}
2357 {mc "External diff" command {external_diff}}
2358 {mc "Blame parent commit" command {external_blame 1}}
2360 $flist_menu configure -tearoff 0
2362 global diff_menu
2363 set diff_menu .diffctxmenu
2364 makemenu $diff_menu {
2365 {mc "Show origin of this line" command show_line_source}
2366 {mc "Run git gui blame on this line" command {external_blame_diff}}
2368 $diff_menu configure -tearoff 0
2371 # Windows sends all mouse wheel events to the current focused window, not
2372 # the one where the mouse hovers, so bind those events here and redirect
2373 # to the correct window
2374 proc windows_mousewheel_redirector {W X Y D} {
2375 global canv canv2 canv3
2376 set w [winfo containing -displayof $W $X $Y]
2377 if {$w ne ""} {
2378 set u [expr {$D < 0 ? 5 : -5}]
2379 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2380 allcanvs yview scroll $u units
2381 } else {
2382 catch {
2383 $w yview scroll $u units
2389 # Update row number label when selectedline changes
2390 proc selectedline_change {n1 n2 op} {
2391 global selectedline rownumsel
2393 if {$selectedline eq {}} {
2394 set rownumsel {}
2395 } else {
2396 set rownumsel [expr {$selectedline + 1}]
2400 # mouse-2 makes all windows scan vertically, but only the one
2401 # the cursor is in scans horizontally
2402 proc canvscan {op w x y} {
2403 global canv canv2 canv3
2404 foreach c [list $canv $canv2 $canv3] {
2405 if {$c == $w} {
2406 $c scan $op $x $y
2407 } else {
2408 $c scan $op 0 $y
2413 proc scrollcanv {cscroll f0 f1} {
2414 $cscroll set $f0 $f1
2415 drawvisible
2416 flushhighlights
2419 # when we make a key binding for the toplevel, make sure
2420 # it doesn't get triggered when that key is pressed in the
2421 # find string entry widget.
2422 proc bindkey {ev script} {
2423 global entries
2424 bind . $ev $script
2425 set escript [bind Entry $ev]
2426 if {$escript == {}} {
2427 set escript [bind Entry <Key>]
2429 foreach e $entries {
2430 bind $e $ev "$escript; break"
2434 # set the focus back to the toplevel for any click outside
2435 # the entry widgets
2436 proc click {w} {
2437 global ctext entries
2438 foreach e [concat $entries $ctext] {
2439 if {$w == $e} return
2441 focus .
2444 # Adjust the progress bar for a change in requested extent or canvas size
2445 proc adjustprogress {} {
2446 global progresscanv progressitem progresscoords
2447 global fprogitem fprogcoord lastprogupdate progupdatepending
2448 global rprogitem rprogcoord
2450 set w [expr {[winfo width $progresscanv] - 4}]
2451 set x0 [expr {$w * [lindex $progresscoords 0]}]
2452 set x1 [expr {$w * [lindex $progresscoords 1]}]
2453 set h [winfo height $progresscanv]
2454 $progresscanv coords $progressitem $x0 0 $x1 $h
2455 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2456 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2457 set now [clock clicks -milliseconds]
2458 if {$now >= $lastprogupdate + 100} {
2459 set progupdatepending 0
2460 update
2461 } elseif {!$progupdatepending} {
2462 set progupdatepending 1
2463 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2467 proc doprogupdate {} {
2468 global lastprogupdate progupdatepending
2470 if {$progupdatepending} {
2471 set progupdatepending 0
2472 set lastprogupdate [clock clicks -milliseconds]
2473 update
2477 proc savestuff {w} {
2478 global canv canv2 canv3 mainfont textfont uifont tabstop
2479 global stuffsaved findmergefiles maxgraphpct
2480 global maxwidth showneartags showlocalchanges
2481 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2482 global cmitmode wrapcomment datetimeformat limitdiffs
2483 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2484 global autoselect extdifftool perfile_attrs markbgcolor
2486 if {$stuffsaved} return
2487 if {![winfo viewable .]} return
2488 catch {
2489 set f [open "~/.gitk-new" w]
2490 puts $f [list set mainfont $mainfont]
2491 puts $f [list set textfont $textfont]
2492 puts $f [list set uifont $uifont]
2493 puts $f [list set tabstop $tabstop]
2494 puts $f [list set findmergefiles $findmergefiles]
2495 puts $f [list set maxgraphpct $maxgraphpct]
2496 puts $f [list set maxwidth $maxwidth]
2497 puts $f [list set cmitmode $cmitmode]
2498 puts $f [list set wrapcomment $wrapcomment]
2499 puts $f [list set autoselect $autoselect]
2500 puts $f [list set showneartags $showneartags]
2501 puts $f [list set showlocalchanges $showlocalchanges]
2502 puts $f [list set datetimeformat $datetimeformat]
2503 puts $f [list set limitdiffs $limitdiffs]
2504 puts $f [list set bgcolor $bgcolor]
2505 puts $f [list set fgcolor $fgcolor]
2506 puts $f [list set colors $colors]
2507 puts $f [list set diffcolors $diffcolors]
2508 puts $f [list set markbgcolor $markbgcolor]
2509 puts $f [list set diffcontext $diffcontext]
2510 puts $f [list set selectbgcolor $selectbgcolor]
2511 puts $f [list set extdifftool $extdifftool]
2512 puts $f [list set perfile_attrs $perfile_attrs]
2514 puts $f "set geometry(main) [wm geometry .]"
2515 puts $f "set geometry(topwidth) [winfo width .tf]"
2516 puts $f "set geometry(topheight) [winfo height .tf]"
2517 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2518 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2519 puts $f "set geometry(botwidth) [winfo width .bleft]"
2520 puts $f "set geometry(botheight) [winfo height .bleft]"
2522 puts -nonewline $f "set permviews {"
2523 for {set v 0} {$v < $nextviewnum} {incr v} {
2524 if {$viewperm($v)} {
2525 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2528 puts $f "}"
2529 close $f
2530 catch {file delete "~/.gitk"}
2531 file rename -force "~/.gitk-new" "~/.gitk"
2533 set stuffsaved 1
2536 proc resizeclistpanes {win w} {
2537 global oldwidth
2538 if {[info exists oldwidth($win)]} {
2539 set s0 [$win sash coord 0]
2540 set s1 [$win sash coord 1]
2541 if {$w < 60} {
2542 set sash0 [expr {int($w/2 - 2)}]
2543 set sash1 [expr {int($w*5/6 - 2)}]
2544 } else {
2545 set factor [expr {1.0 * $w / $oldwidth($win)}]
2546 set sash0 [expr {int($factor * [lindex $s0 0])}]
2547 set sash1 [expr {int($factor * [lindex $s1 0])}]
2548 if {$sash0 < 30} {
2549 set sash0 30
2551 if {$sash1 < $sash0 + 20} {
2552 set sash1 [expr {$sash0 + 20}]
2554 if {$sash1 > $w - 10} {
2555 set sash1 [expr {$w - 10}]
2556 if {$sash0 > $sash1 - 20} {
2557 set sash0 [expr {$sash1 - 20}]
2561 $win sash place 0 $sash0 [lindex $s0 1]
2562 $win sash place 1 $sash1 [lindex $s1 1]
2564 set oldwidth($win) $w
2567 proc resizecdetpanes {win w} {
2568 global oldwidth
2569 if {[info exists oldwidth($win)]} {
2570 set s0 [$win sash coord 0]
2571 if {$w < 60} {
2572 set sash0 [expr {int($w*3/4 - 2)}]
2573 } else {
2574 set factor [expr {1.0 * $w / $oldwidth($win)}]
2575 set sash0 [expr {int($factor * [lindex $s0 0])}]
2576 if {$sash0 < 45} {
2577 set sash0 45
2579 if {$sash0 > $w - 15} {
2580 set sash0 [expr {$w - 15}]
2583 $win sash place 0 $sash0 [lindex $s0 1]
2585 set oldwidth($win) $w
2588 proc allcanvs args {
2589 global canv canv2 canv3
2590 eval $canv $args
2591 eval $canv2 $args
2592 eval $canv3 $args
2595 proc bindall {event action} {
2596 global canv canv2 canv3
2597 bind $canv $event $action
2598 bind $canv2 $event $action
2599 bind $canv3 $event $action
2602 proc about {} {
2603 global uifont
2604 set w .about
2605 if {[winfo exists $w]} {
2606 raise $w
2607 return
2609 toplevel $w
2610 wm title $w [mc "About gitk"]
2611 make_transient $w .
2612 message $w.m -text [mc "
2613 Gitk - a commit viewer for git
2615 Copyright © 2005-2008 Paul Mackerras
2617 Use and redistribute under the terms of the GNU General Public License"] \
2618 -justify center -aspect 400 -border 2 -bg white -relief groove
2619 pack $w.m -side top -fill x -padx 2 -pady 2
2620 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2621 pack $w.ok -side bottom
2622 bind $w <Visibility> "focus $w.ok"
2623 bind $w <Key-Escape> "destroy $w"
2624 bind $w <Key-Return> "destroy $w"
2627 proc keys {} {
2628 set w .keys
2629 if {[winfo exists $w]} {
2630 raise $w
2631 return
2633 if {[tk windowingsystem] eq {aqua}} {
2634 set M1T Cmd
2635 } else {
2636 set M1T Ctrl
2638 toplevel $w
2639 wm title $w [mc "Gitk key bindings"]
2640 make_transient $w .
2641 message $w.m -text "
2642 [mc "Gitk key bindings:"]
2644 [mc "<%s-Q> Quit" $M1T]
2645 [mc "<Home> Move to first commit"]
2646 [mc "<End> Move to last commit"]
2647 [mc "<Up>, p, i Move up one commit"]
2648 [mc "<Down>, n, k Move down one commit"]
2649 [mc "<Left>, z, j Go back in history list"]
2650 [mc "<Right>, x, l Go forward in history list"]
2651 [mc "<PageUp> Move up one page in commit list"]
2652 [mc "<PageDown> Move down one page in commit list"]
2653 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2654 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2655 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2656 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2657 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2658 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2659 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2660 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2661 [mc "<Delete>, b Scroll diff view up one page"]
2662 [mc "<Backspace> Scroll diff view up one page"]
2663 [mc "<Space> Scroll diff view down one page"]
2664 [mc "u Scroll diff view up 18 lines"]
2665 [mc "d Scroll diff view down 18 lines"]
2666 [mc "<%s-F> Find" $M1T]
2667 [mc "<%s-G> Move to next find hit" $M1T]
2668 [mc "<Return> Move to next find hit"]
2669 [mc "/ Focus the search box"]
2670 [mc "? Move to previous find hit"]
2671 [mc "f Scroll diff view to next file"]
2672 [mc "<%s-S> Search for next hit in diff view" $M1T]
2673 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2674 [mc "<%s-KP+> Increase font size" $M1T]
2675 [mc "<%s-plus> Increase font size" $M1T]
2676 [mc "<%s-KP-> Decrease font size" $M1T]
2677 [mc "<%s-minus> Decrease font size" $M1T]
2678 [mc "<F5> Update"]
2680 -justify left -bg white -border 2 -relief groove
2681 pack $w.m -side top -fill both -padx 2 -pady 2
2682 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2683 bind $w <Key-Escape> [list destroy $w]
2684 pack $w.ok -side bottom
2685 bind $w <Visibility> "focus $w.ok"
2686 bind $w <Key-Escape> "destroy $w"
2687 bind $w <Key-Return> "destroy $w"
2690 # Procedures for manipulating the file list window at the
2691 # bottom right of the overall window.
2693 proc treeview {w l openlevs} {
2694 global treecontents treediropen treeheight treeparent treeindex
2696 set ix 0
2697 set treeindex() 0
2698 set lev 0
2699 set prefix {}
2700 set prefixend -1
2701 set prefendstack {}
2702 set htstack {}
2703 set ht 0
2704 set treecontents() {}
2705 $w conf -state normal
2706 foreach f $l {
2707 while {[string range $f 0 $prefixend] ne $prefix} {
2708 if {$lev <= $openlevs} {
2709 $w mark set e:$treeindex($prefix) "end -1c"
2710 $w mark gravity e:$treeindex($prefix) left
2712 set treeheight($prefix) $ht
2713 incr ht [lindex $htstack end]
2714 set htstack [lreplace $htstack end end]
2715 set prefixend [lindex $prefendstack end]
2716 set prefendstack [lreplace $prefendstack end end]
2717 set prefix [string range $prefix 0 $prefixend]
2718 incr lev -1
2720 set tail [string range $f [expr {$prefixend+1}] end]
2721 while {[set slash [string first "/" $tail]] >= 0} {
2722 lappend htstack $ht
2723 set ht 0
2724 lappend prefendstack $prefixend
2725 incr prefixend [expr {$slash + 1}]
2726 set d [string range $tail 0 $slash]
2727 lappend treecontents($prefix) $d
2728 set oldprefix $prefix
2729 append prefix $d
2730 set treecontents($prefix) {}
2731 set treeindex($prefix) [incr ix]
2732 set treeparent($prefix) $oldprefix
2733 set tail [string range $tail [expr {$slash+1}] end]
2734 if {$lev <= $openlevs} {
2735 set ht 1
2736 set treediropen($prefix) [expr {$lev < $openlevs}]
2737 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2738 $w mark set d:$ix "end -1c"
2739 $w mark gravity d:$ix left
2740 set str "\n"
2741 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2742 $w insert end $str
2743 $w image create end -align center -image $bm -padx 1 \
2744 -name a:$ix
2745 $w insert end $d [highlight_tag $prefix]
2746 $w mark set s:$ix "end -1c"
2747 $w mark gravity s:$ix left
2749 incr lev
2751 if {$tail ne {}} {
2752 if {$lev <= $openlevs} {
2753 incr ht
2754 set str "\n"
2755 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2756 $w insert end $str
2757 $w insert end $tail [highlight_tag $f]
2759 lappend treecontents($prefix) $tail
2762 while {$htstack ne {}} {
2763 set treeheight($prefix) $ht
2764 incr ht [lindex $htstack end]
2765 set htstack [lreplace $htstack end end]
2766 set prefixend [lindex $prefendstack end]
2767 set prefendstack [lreplace $prefendstack end end]
2768 set prefix [string range $prefix 0 $prefixend]
2770 $w conf -state disabled
2773 proc linetoelt {l} {
2774 global treeheight treecontents
2776 set y 2
2777 set prefix {}
2778 while {1} {
2779 foreach e $treecontents($prefix) {
2780 if {$y == $l} {
2781 return "$prefix$e"
2783 set n 1
2784 if {[string index $e end] eq "/"} {
2785 set n $treeheight($prefix$e)
2786 if {$y + $n > $l} {
2787 append prefix $e
2788 incr y
2789 break
2792 incr y $n
2797 proc highlight_tree {y prefix} {
2798 global treeheight treecontents cflist
2800 foreach e $treecontents($prefix) {
2801 set path $prefix$e
2802 if {[highlight_tag $path] ne {}} {
2803 $cflist tag add bold $y.0 "$y.0 lineend"
2805 incr y
2806 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2807 set y [highlight_tree $y $path]
2810 return $y
2813 proc treeclosedir {w dir} {
2814 global treediropen treeheight treeparent treeindex
2816 set ix $treeindex($dir)
2817 $w conf -state normal
2818 $w delete s:$ix e:$ix
2819 set treediropen($dir) 0
2820 $w image configure a:$ix -image tri-rt
2821 $w conf -state disabled
2822 set n [expr {1 - $treeheight($dir)}]
2823 while {$dir ne {}} {
2824 incr treeheight($dir) $n
2825 set dir $treeparent($dir)
2829 proc treeopendir {w dir} {
2830 global treediropen treeheight treeparent treecontents treeindex
2832 set ix $treeindex($dir)
2833 $w conf -state normal
2834 $w image configure a:$ix -image tri-dn
2835 $w mark set e:$ix s:$ix
2836 $w mark gravity e:$ix right
2837 set lev 0
2838 set str "\n"
2839 set n [llength $treecontents($dir)]
2840 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2841 incr lev
2842 append str "\t"
2843 incr treeheight($x) $n
2845 foreach e $treecontents($dir) {
2846 set de $dir$e
2847 if {[string index $e end] eq "/"} {
2848 set iy $treeindex($de)
2849 $w mark set d:$iy e:$ix
2850 $w mark gravity d:$iy left
2851 $w insert e:$ix $str
2852 set treediropen($de) 0
2853 $w image create e:$ix -align center -image tri-rt -padx 1 \
2854 -name a:$iy
2855 $w insert e:$ix $e [highlight_tag $de]
2856 $w mark set s:$iy e:$ix
2857 $w mark gravity s:$iy left
2858 set treeheight($de) 1
2859 } else {
2860 $w insert e:$ix $str
2861 $w insert e:$ix $e [highlight_tag $de]
2864 $w mark gravity e:$ix right
2865 $w conf -state disabled
2866 set treediropen($dir) 1
2867 set top [lindex [split [$w index @0,0] .] 0]
2868 set ht [$w cget -height]
2869 set l [lindex [split [$w index s:$ix] .] 0]
2870 if {$l < $top} {
2871 $w yview $l.0
2872 } elseif {$l + $n + 1 > $top + $ht} {
2873 set top [expr {$l + $n + 2 - $ht}]
2874 if {$l < $top} {
2875 set top $l
2877 $w yview $top.0
2881 proc treeclick {w x y} {
2882 global treediropen cmitmode ctext cflist cflist_top
2884 if {$cmitmode ne "tree"} return
2885 if {![info exists cflist_top]} return
2886 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2887 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2888 $cflist tag add highlight $l.0 "$l.0 lineend"
2889 set cflist_top $l
2890 if {$l == 1} {
2891 $ctext yview 1.0
2892 return
2894 set e [linetoelt $l]
2895 if {[string index $e end] ne "/"} {
2896 showfile $e
2897 } elseif {$treediropen($e)} {
2898 treeclosedir $w $e
2899 } else {
2900 treeopendir $w $e
2904 proc setfilelist {id} {
2905 global treefilelist cflist jump_to_here
2907 treeview $cflist $treefilelist($id) 0
2908 if {$jump_to_here ne {}} {
2909 set f [lindex $jump_to_here 0]
2910 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2911 showfile $f
2916 image create bitmap tri-rt -background black -foreground blue -data {
2917 #define tri-rt_width 13
2918 #define tri-rt_height 13
2919 static unsigned char tri-rt_bits[] = {
2920 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2921 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2922 0x00, 0x00};
2923 } -maskdata {
2924 #define tri-rt-mask_width 13
2925 #define tri-rt-mask_height 13
2926 static unsigned char tri-rt-mask_bits[] = {
2927 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2928 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2929 0x08, 0x00};
2931 image create bitmap tri-dn -background black -foreground blue -data {
2932 #define tri-dn_width 13
2933 #define tri-dn_height 13
2934 static unsigned char tri-dn_bits[] = {
2935 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2936 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2937 0x00, 0x00};
2938 } -maskdata {
2939 #define tri-dn-mask_width 13
2940 #define tri-dn-mask_height 13
2941 static unsigned char tri-dn-mask_bits[] = {
2942 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2943 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2944 0x00, 0x00};
2947 image create bitmap reficon-T -background black -foreground yellow -data {
2948 #define tagicon_width 13
2949 #define tagicon_height 9
2950 static unsigned char tagicon_bits[] = {
2951 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2952 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2953 } -maskdata {
2954 #define tagicon-mask_width 13
2955 #define tagicon-mask_height 9
2956 static unsigned char tagicon-mask_bits[] = {
2957 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2958 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2960 set rectdata {
2961 #define headicon_width 13
2962 #define headicon_height 9
2963 static unsigned char headicon_bits[] = {
2964 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2965 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2967 set rectmask {
2968 #define headicon-mask_width 13
2969 #define headicon-mask_height 9
2970 static unsigned char headicon-mask_bits[] = {
2971 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2972 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2974 image create bitmap reficon-H -background black -foreground green \
2975 -data $rectdata -maskdata $rectmask
2976 image create bitmap reficon-o -background black -foreground "#ddddff" \
2977 -data $rectdata -maskdata $rectmask
2979 proc init_flist {first} {
2980 global cflist cflist_top difffilestart
2982 $cflist conf -state normal
2983 $cflist delete 0.0 end
2984 if {$first ne {}} {
2985 $cflist insert end $first
2986 set cflist_top 1
2987 $cflist tag add highlight 1.0 "1.0 lineend"
2988 } else {
2989 catch {unset cflist_top}
2991 $cflist conf -state disabled
2992 set difffilestart {}
2995 proc highlight_tag {f} {
2996 global highlight_paths
2998 foreach p $highlight_paths {
2999 if {[string match $p $f]} {
3000 return "bold"
3003 return {}
3006 proc highlight_filelist {} {
3007 global cmitmode cflist
3009 $cflist conf -state normal
3010 if {$cmitmode ne "tree"} {
3011 set end [lindex [split [$cflist index end] .] 0]
3012 for {set l 2} {$l < $end} {incr l} {
3013 set line [$cflist get $l.0 "$l.0 lineend"]
3014 if {[highlight_tag $line] ne {}} {
3015 $cflist tag add bold $l.0 "$l.0 lineend"
3018 } else {
3019 highlight_tree 2 {}
3021 $cflist conf -state disabled
3024 proc unhighlight_filelist {} {
3025 global cflist
3027 $cflist conf -state normal
3028 $cflist tag remove bold 1.0 end
3029 $cflist conf -state disabled
3032 proc add_flist {fl} {
3033 global cflist
3035 $cflist conf -state normal
3036 foreach f $fl {
3037 $cflist insert end "\n"
3038 $cflist insert end $f [highlight_tag $f]
3040 $cflist conf -state disabled
3043 proc sel_flist {w x y} {
3044 global ctext difffilestart cflist cflist_top cmitmode
3046 if {$cmitmode eq "tree"} return
3047 if {![info exists cflist_top]} return
3048 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3049 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3050 $cflist tag add highlight $l.0 "$l.0 lineend"
3051 set cflist_top $l
3052 if {$l == 1} {
3053 $ctext yview 1.0
3054 } else {
3055 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3059 proc pop_flist_menu {w X Y x y} {
3060 global ctext cflist cmitmode flist_menu flist_menu_file
3061 global treediffs diffids
3063 stopfinding
3064 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3065 if {$l <= 1} return
3066 if {$cmitmode eq "tree"} {
3067 set e [linetoelt $l]
3068 if {[string index $e end] eq "/"} return
3069 } else {
3070 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3072 set flist_menu_file $e
3073 set xdiffstate "normal"
3074 if {$cmitmode eq "tree"} {
3075 set xdiffstate "disabled"
3077 # Disable "External diff" item in tree mode
3078 $flist_menu entryconf 2 -state $xdiffstate
3079 tk_popup $flist_menu $X $Y
3082 proc find_ctext_fileinfo {line} {
3083 global ctext_file_names ctext_file_lines
3085 set ok [bsearch $ctext_file_lines $line]
3086 set tline [lindex $ctext_file_lines $ok]
3088 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3089 return {}
3090 } else {
3091 return [list [lindex $ctext_file_names $ok] $tline]
3095 proc pop_diff_menu {w X Y x y} {
3096 global ctext diff_menu flist_menu_file
3097 global diff_menu_txtpos diff_menu_line
3098 global diff_menu_filebase
3100 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3101 set diff_menu_line [lindex $diff_menu_txtpos 0]
3102 # don't pop up the menu on hunk-separator or file-separator lines
3103 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3104 return
3106 stopfinding
3107 set f [find_ctext_fileinfo $diff_menu_line]
3108 if {$f eq {}} return
3109 set flist_menu_file [lindex $f 0]
3110 set diff_menu_filebase [lindex $f 1]
3111 tk_popup $diff_menu $X $Y
3114 proc flist_hl {only} {
3115 global flist_menu_file findstring gdttype
3117 set x [shellquote $flist_menu_file]
3118 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3119 set findstring $x
3120 } else {
3121 append findstring " " $x
3123 set gdttype [mc "touching paths:"]
3126 proc save_file_from_commit {filename output what} {
3127 global nullfile
3129 if {[catch {exec git show $filename -- > $output} err]} {
3130 if {[string match "fatal: bad revision *" $err]} {
3131 return $nullfile
3133 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3134 return {}
3136 return $output
3139 proc external_diff_get_one_file {diffid filename diffdir} {
3140 global nullid nullid2 nullfile
3141 global gitdir
3143 if {$diffid == $nullid} {
3144 set difffile [file join [file dirname $gitdir] $filename]
3145 if {[file exists $difffile]} {
3146 return $difffile
3148 return $nullfile
3150 if {$diffid == $nullid2} {
3151 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3152 return [save_file_from_commit :$filename $difffile index]
3154 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3155 return [save_file_from_commit $diffid:$filename $difffile \
3156 "revision $diffid"]
3159 proc external_diff {} {
3160 global gitktmpdir nullid nullid2
3161 global flist_menu_file
3162 global diffids
3163 global diffnum
3164 global gitdir extdifftool
3166 if {[llength $diffids] == 1} {
3167 # no reference commit given
3168 set diffidto [lindex $diffids 0]
3169 if {$diffidto eq $nullid} {
3170 # diffing working copy with index
3171 set diffidfrom $nullid2
3172 } elseif {$diffidto eq $nullid2} {
3173 # diffing index with HEAD
3174 set diffidfrom "HEAD"
3175 } else {
3176 # use first parent commit
3177 global parentlist selectedline
3178 set diffidfrom [lindex $parentlist $selectedline 0]
3180 } else {
3181 set diffidfrom [lindex $diffids 0]
3182 set diffidto [lindex $diffids 1]
3185 # make sure that several diffs wont collide
3186 if {![info exists gitktmpdir]} {
3187 set gitktmpdir [file join [file dirname $gitdir] \
3188 [format ".gitk-tmp.%s" [pid]]]
3189 if {[catch {file mkdir $gitktmpdir} err]} {
3190 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3191 unset gitktmpdir
3192 return
3194 set diffnum 0
3196 incr diffnum
3197 set diffdir [file join $gitktmpdir $diffnum]
3198 if {[catch {file mkdir $diffdir} err]} {
3199 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3200 return
3203 # gather files to diff
3204 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3205 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3207 if {$difffromfile ne {} && $difftofile ne {}} {
3208 set cmd [concat | [shellsplit $extdifftool] \
3209 [list $difffromfile $difftofile]]
3210 if {[catch {set fl [open $cmd r]} err]} {
3211 file delete -force $diffdir
3212 error_popup "$extdifftool: [mc "command failed:"] $err"
3213 } else {
3214 fconfigure $fl -blocking 0
3215 filerun $fl [list delete_at_eof $fl $diffdir]
3220 proc find_hunk_blamespec {base line} {
3221 global ctext
3223 # Find and parse the hunk header
3224 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3225 if {$s_lix eq {}} return
3227 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3228 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3229 s_line old_specs osz osz1 new_line nsz]} {
3230 return
3233 # base lines for the parents
3234 set base_lines [list $new_line]
3235 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3236 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3237 old_spec old_line osz]} {
3238 return
3240 lappend base_lines $old_line
3243 # Now scan the lines to determine offset within the hunk
3244 set max_parent [expr {[llength $base_lines]-2}]
3245 set dline 0
3246 set s_lno [lindex [split $s_lix "."] 0]
3248 # Determine if the line is removed
3249 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3250 if {[string match {[-+ ]*} $chunk]} {
3251 set removed_idx [string first "-" $chunk]
3252 # Choose a parent index
3253 if {$removed_idx >= 0} {
3254 set parent $removed_idx
3255 } else {
3256 set unchanged_idx [string first " " $chunk]
3257 if {$unchanged_idx >= 0} {
3258 set parent $unchanged_idx
3259 } else {
3260 # blame the current commit
3261 set parent -1
3264 # then count other lines that belong to it
3265 for {set i $line} {[incr i -1] > $s_lno} {} {
3266 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3267 # Determine if the line is removed
3268 set removed_idx [string first "-" $chunk]
3269 if {$parent >= 0} {
3270 set code [string index $chunk $parent]
3271 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3272 incr dline
3274 } else {
3275 if {$removed_idx < 0} {
3276 incr dline
3280 incr parent
3281 } else {
3282 set parent 0
3285 incr dline [lindex $base_lines $parent]
3286 return [list $parent $dline]
3289 proc external_blame_diff {} {
3290 global currentid cmitmode
3291 global diff_menu_txtpos diff_menu_line
3292 global diff_menu_filebase flist_menu_file
3294 if {$cmitmode eq "tree"} {
3295 set parent_idx 0
3296 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3297 } else {
3298 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3299 if {$hinfo ne {}} {
3300 set parent_idx [lindex $hinfo 0]
3301 set line [lindex $hinfo 1]
3302 } else {
3303 set parent_idx 0
3304 set line 0
3308 external_blame $parent_idx $line
3311 # Find the SHA1 ID of the blob for file $fname in the index
3312 # at stage 0 or 2
3313 proc index_sha1 {fname} {
3314 set f [open [list | git ls-files -s $fname] r]
3315 while {[gets $f line] >= 0} {
3316 set info [lindex [split $line "\t"] 0]
3317 set stage [lindex $info 2]
3318 if {$stage eq "0" || $stage eq "2"} {
3319 close $f
3320 return [lindex $info 1]
3323 close $f
3324 return {}
3327 # Turn an absolute path into one relative to the current directory
3328 proc make_relative {f} {
3329 set elts [file split $f]
3330 set here [file split [pwd]]
3331 set ei 0
3332 set hi 0
3333 set res {}
3334 foreach d $here {
3335 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3336 lappend res ".."
3337 } else {
3338 incr ei
3340 incr hi
3342 set elts [concat $res [lrange $elts $ei end]]
3343 return [eval file join $elts]
3346 proc external_blame {parent_idx {line {}}} {
3347 global flist_menu_file gitdir
3348 global nullid nullid2
3349 global parentlist selectedline currentid
3351 if {$parent_idx > 0} {
3352 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3353 } else {
3354 set base_commit $currentid
3357 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3358 error_popup [mc "No such commit"]
3359 return
3362 set cmdline [list git gui blame]
3363 if {$line ne {} && $line > 1} {
3364 lappend cmdline "--line=$line"
3366 set f [file join [file dirname $gitdir] $flist_menu_file]
3367 # Unfortunately it seems git gui blame doesn't like
3368 # being given an absolute path...
3369 set f [make_relative $f]
3370 lappend cmdline $base_commit $f
3371 if {[catch {eval exec $cmdline &} err]} {
3372 error_popup "[mc "git gui blame: command failed:"] $err"
3376 proc show_line_source {} {
3377 global cmitmode currentid parents curview blamestuff blameinst
3378 global diff_menu_line diff_menu_filebase flist_menu_file
3379 global nullid nullid2 gitdir
3381 set from_index {}
3382 if {$cmitmode eq "tree"} {
3383 set id $currentid
3384 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3385 } else {
3386 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3387 if {$h eq {}} return
3388 set pi [lindex $h 0]
3389 if {$pi == 0} {
3390 mark_ctext_line $diff_menu_line
3391 return
3393 incr pi -1
3394 if {$currentid eq $nullid} {
3395 if {$pi > 0} {
3396 # must be a merge in progress...
3397 if {[catch {
3398 # get the last line from .git/MERGE_HEAD
3399 set f [open [file join $gitdir MERGE_HEAD] r]
3400 set id [lindex [split [read $f] "\n"] end-1]
3401 close $f
3402 } err]} {
3403 error_popup [mc "Couldn't read merge head: %s" $err]
3404 return
3406 } elseif {$parents($curview,$currentid) eq $nullid2} {
3407 # need to do the blame from the index
3408 if {[catch {
3409 set from_index [index_sha1 $flist_menu_file]
3410 } err]} {
3411 error_popup [mc "Error reading index: %s" $err]
3412 return
3414 } else {
3415 set id $parents($curview,$currentid)
3417 } else {
3418 set id [lindex $parents($curview,$currentid) $pi]
3420 set line [lindex $h 1]
3422 set blameargs {}
3423 if {$from_index ne {}} {
3424 lappend blameargs | git cat-file blob $from_index
3426 lappend blameargs | git blame -p -L$line,+1
3427 if {$from_index ne {}} {
3428 lappend blameargs --contents -
3429 } else {
3430 lappend blameargs $id
3432 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3433 if {[catch {
3434 set f [open $blameargs r]
3435 } err]} {
3436 error_popup [mc "Couldn't start git blame: %s" $err]
3437 return
3439 nowbusy blaming [mc "Searching"]
3440 fconfigure $f -blocking 0
3441 set i [reg_instance $f]
3442 set blamestuff($i) {}
3443 set blameinst $i
3444 filerun $f [list read_line_source $f $i]
3447 proc stopblaming {} {
3448 global blameinst
3450 if {[info exists blameinst]} {
3451 stop_instance $blameinst
3452 unset blameinst
3453 notbusy blaming
3457 proc read_line_source {fd inst} {
3458 global blamestuff curview commfd blameinst nullid nullid2
3460 while {[gets $fd line] >= 0} {
3461 lappend blamestuff($inst) $line
3463 if {![eof $fd]} {
3464 return 1
3466 unset commfd($inst)
3467 unset blameinst
3468 notbusy blaming
3469 fconfigure $fd -blocking 1
3470 if {[catch {close $fd} err]} {
3471 error_popup [mc "Error running git blame: %s" $err]
3472 return 0
3475 set fname {}
3476 set line [split [lindex $blamestuff($inst) 0] " "]
3477 set id [lindex $line 0]
3478 set lnum [lindex $line 1]
3479 if {[string length $id] == 40 && [string is xdigit $id] &&
3480 [string is digit -strict $lnum]} {
3481 # look for "filename" line
3482 foreach l $blamestuff($inst) {
3483 if {[string match "filename *" $l]} {
3484 set fname [string range $l 9 end]
3485 break
3489 if {$fname ne {}} {
3490 # all looks good, select it
3491 if {$id eq $nullid} {
3492 # blame uses all-zeroes to mean not committed,
3493 # which would mean a change in the index
3494 set id $nullid2
3496 if {[commitinview $id $curview]} {
3497 selectline [rowofcommit $id] 1 [list $fname $lnum]
3498 } else {
3499 error_popup [mc "That line comes from commit %s, \
3500 which is not in this view" [shortids $id]]
3502 } else {
3503 puts "oops couldn't parse git blame output"
3505 return 0
3508 # delete $dir when we see eof on $f (presumably because the child has exited)
3509 proc delete_at_eof {f dir} {
3510 while {[gets $f line] >= 0} {}
3511 if {[eof $f]} {
3512 if {[catch {close $f} err]} {
3513 error_popup "[mc "External diff viewer failed:"] $err"
3515 file delete -force $dir
3516 return 0
3518 return 1
3521 # Functions for adding and removing shell-type quoting
3523 proc shellquote {str} {
3524 if {![string match "*\['\"\\ \t]*" $str]} {
3525 return $str
3527 if {![string match "*\['\"\\]*" $str]} {
3528 return "\"$str\""
3530 if {![string match "*'*" $str]} {
3531 return "'$str'"
3533 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3536 proc shellarglist {l} {
3537 set str {}
3538 foreach a $l {
3539 if {$str ne {}} {
3540 append str " "
3542 append str [shellquote $a]
3544 return $str
3547 proc shelldequote {str} {
3548 set ret {}
3549 set used -1
3550 while {1} {
3551 incr used
3552 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3553 append ret [string range $str $used end]
3554 set used [string length $str]
3555 break
3557 set first [lindex $first 0]
3558 set ch [string index $str $first]
3559 if {$first > $used} {
3560 append ret [string range $str $used [expr {$first - 1}]]
3561 set used $first
3563 if {$ch eq " " || $ch eq "\t"} break
3564 incr used
3565 if {$ch eq "'"} {
3566 set first [string first "'" $str $used]
3567 if {$first < 0} {
3568 error "unmatched single-quote"
3570 append ret [string range $str $used [expr {$first - 1}]]
3571 set used $first
3572 continue
3574 if {$ch eq "\\"} {
3575 if {$used >= [string length $str]} {
3576 error "trailing backslash"
3578 append ret [string index $str $used]
3579 continue
3581 # here ch == "\""
3582 while {1} {
3583 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3584 error "unmatched double-quote"
3586 set first [lindex $first 0]
3587 set ch [string index $str $first]
3588 if {$first > $used} {
3589 append ret [string range $str $used [expr {$first - 1}]]
3590 set used $first
3592 if {$ch eq "\""} break
3593 incr used
3594 append ret [string index $str $used]
3595 incr used
3598 return [list $used $ret]
3601 proc shellsplit {str} {
3602 set l {}
3603 while {1} {
3604 set str [string trimleft $str]
3605 if {$str eq {}} break
3606 set dq [shelldequote $str]
3607 set n [lindex $dq 0]
3608 set word [lindex $dq 1]
3609 set str [string range $str $n end]
3610 lappend l $word
3612 return $l
3615 # Code to implement multiple views
3617 proc newview {ishighlight} {
3618 global nextviewnum newviewname newishighlight
3619 global revtreeargs viewargscmd newviewopts curview
3621 set newishighlight $ishighlight
3622 set top .gitkview
3623 if {[winfo exists $top]} {
3624 raise $top
3625 return
3627 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3628 set newviewopts($nextviewnum,perm) 0
3629 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3630 decode_view_opts $nextviewnum $revtreeargs
3631 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3634 set known_view_options {
3635 {perm b . {} {mc "Remember this view"}}
3636 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3637 {all b * "--all" {mc "Use all refs"}}
3638 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3639 {lright b . "--left-right" {mc "Mark branch sides"}}
3640 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3641 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3642 {limit t10 + "--max-count=*" {mc "Max count:"}}
3643 {skip t10 . "--skip=*" {mc "Skip:"}}
3644 {first b . "--first-parent" {mc "Limit to first parent"}}
3645 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3648 proc encode_view_opts {n} {
3649 global known_view_options newviewopts
3651 set rargs [list]
3652 foreach opt $known_view_options {
3653 set patterns [lindex $opt 3]
3654 if {$patterns eq {}} continue
3655 set pattern [lindex $patterns 0]
3657 set val $newviewopts($n,[lindex $opt 0])
3659 if {[lindex $opt 1] eq "b"} {
3660 if {$val} {
3661 lappend rargs $pattern
3663 } else {
3664 set val [string trim $val]
3665 if {$val ne {}} {
3666 set pfix [string range $pattern 0 end-1]
3667 lappend rargs $pfix$val
3671 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3674 proc decode_view_opts {n view_args} {
3675 global known_view_options newviewopts
3677 foreach opt $known_view_options {
3678 if {[lindex $opt 1] eq "b"} {
3679 set val 0
3680 } else {
3681 set val {}
3683 set newviewopts($n,[lindex $opt 0]) $val
3685 set oargs [list]
3686 foreach arg $view_args {
3687 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3688 && ![info exists found(limit)]} {
3689 set newviewopts($n,limit) $cnt
3690 set found(limit) 1
3691 continue
3693 catch { unset val }
3694 foreach opt $known_view_options {
3695 set id [lindex $opt 0]
3696 if {[info exists found($id)]} continue
3697 foreach pattern [lindex $opt 3] {
3698 if {![string match $pattern $arg]} continue
3699 if {[lindex $opt 1] ne "b"} {
3700 set size [string length $pattern]
3701 set val [string range $arg [expr {$size-1}] end]
3702 } else {
3703 set val 1
3705 set newviewopts($n,$id) $val
3706 set found($id) 1
3707 break
3709 if {[info exists val]} break
3711 if {[info exists val]} continue
3712 lappend oargs $arg
3714 set newviewopts($n,args) [shellarglist $oargs]
3717 proc edit_or_newview {} {
3718 global curview
3720 if {$curview > 0} {
3721 editview
3722 } else {
3723 newview 0
3727 proc editview {} {
3728 global curview
3729 global viewname viewperm newviewname newviewopts
3730 global viewargs viewargscmd
3732 set top .gitkvedit-$curview
3733 if {[winfo exists $top]} {
3734 raise $top
3735 return
3737 set newviewname($curview) $viewname($curview)
3738 set newviewopts($curview,perm) $viewperm($curview)
3739 set newviewopts($curview,cmd) $viewargscmd($curview)
3740 decode_view_opts $curview $viewargs($curview)
3741 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3744 proc vieweditor {top n title} {
3745 global newviewname newviewopts viewfiles bgcolor
3746 global known_view_options
3748 toplevel $top
3749 wm title $top $title
3750 make_transient $top .
3752 # View name
3753 frame $top.nfr
3754 label $top.nl -text [mc "Name"]
3755 entry $top.name -width 20 -textvariable newviewname($n)
3756 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3757 pack $top.nl -in $top.nfr -side left -padx {0 30}
3758 pack $top.name -in $top.nfr -side left
3760 # View options
3761 set cframe $top.nfr
3762 set cexpand 0
3763 set cnt 0
3764 foreach opt $known_view_options {
3765 set id [lindex $opt 0]
3766 set type [lindex $opt 1]
3767 set flags [lindex $opt 2]
3768 set title [eval [lindex $opt 4]]
3769 set lxpad 0
3771 if {$flags eq "+" || $flags eq "*"} {
3772 set cframe $top.fr$cnt
3773 incr cnt
3774 frame $cframe
3775 pack $cframe -in $top -fill x -pady 3 -padx 3
3776 set cexpand [expr {$flags eq "*"}]
3777 } else {
3778 set lxpad 5
3781 if {$type eq "b"} {
3782 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3783 pack $cframe.c_$id -in $cframe -side left \
3784 -padx [list $lxpad 0] -expand $cexpand -anchor w
3785 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3786 message $cframe.l_$id -aspect 1500 -text $title
3787 entry $cframe.e_$id -width $sz -background $bgcolor \
3788 -textvariable newviewopts($n,$id)
3789 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3790 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3791 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3792 message $cframe.l_$id -aspect 1500 -text $title
3793 entry $cframe.e_$id -width $sz -background $bgcolor \
3794 -textvariable newviewopts($n,$id)
3795 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3796 pack $cframe.e_$id -in $cframe -side top -fill x
3800 # Path list
3801 message $top.l -aspect 1500 \
3802 -text [mc "Enter files and directories to include, one per line:"]
3803 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3804 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3805 if {[info exists viewfiles($n)]} {
3806 foreach f $viewfiles($n) {
3807 $top.t insert end $f
3808 $top.t insert end "\n"
3810 $top.t delete {end - 1c} end
3811 $top.t mark set insert 0.0
3813 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3814 frame $top.buts
3815 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3816 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3817 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3818 bind $top <Control-Return> [list newviewok $top $n]
3819 bind $top <F5> [list newviewok $top $n 1]
3820 bind $top <Escape> [list destroy $top]
3821 grid $top.buts.ok $top.buts.apply $top.buts.can
3822 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3823 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3824 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3825 pack $top.buts -in $top -side top -fill x
3826 focus $top.t
3829 proc doviewmenu {m first cmd op argv} {
3830 set nmenu [$m index end]
3831 for {set i $first} {$i <= $nmenu} {incr i} {
3832 if {[$m entrycget $i -command] eq $cmd} {
3833 eval $m $op $i $argv
3834 break
3839 proc allviewmenus {n op args} {
3840 # global viewhlmenu
3842 doviewmenu .bar.view 5 [list showview $n] $op $args
3843 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3846 proc newviewok {top n {apply 0}} {
3847 global nextviewnum newviewperm newviewname newishighlight
3848 global viewname viewfiles viewperm selectedview curview
3849 global viewargs viewargscmd newviewopts viewhlmenu
3851 if {[catch {
3852 set newargs [encode_view_opts $n]
3853 } err]} {
3854 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3855 return
3857 set files {}
3858 foreach f [split [$top.t get 0.0 end] "\n"] {
3859 set ft [string trim $f]
3860 if {$ft ne {}} {
3861 lappend files $ft
3864 if {![info exists viewfiles($n)]} {
3865 # creating a new view
3866 incr nextviewnum
3867 set viewname($n) $newviewname($n)
3868 set viewperm($n) $newviewopts($n,perm)
3869 set viewfiles($n) $files
3870 set viewargs($n) $newargs
3871 set viewargscmd($n) $newviewopts($n,cmd)
3872 addviewmenu $n
3873 if {!$newishighlight} {
3874 run showview $n
3875 } else {
3876 run addvhighlight $n
3878 } else {
3879 # editing an existing view
3880 set viewperm($n) $newviewopts($n,perm)
3881 if {$newviewname($n) ne $viewname($n)} {
3882 set viewname($n) $newviewname($n)
3883 doviewmenu .bar.view 5 [list showview $n] \
3884 entryconf [list -label $viewname($n)]
3885 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3886 # entryconf [list -label $viewname($n) -value $viewname($n)]
3888 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3889 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3890 set viewfiles($n) $files
3891 set viewargs($n) $newargs
3892 set viewargscmd($n) $newviewopts($n,cmd)
3893 if {$curview == $n} {
3894 run reloadcommits
3898 if {$apply} return
3899 catch {destroy $top}
3902 proc delview {} {
3903 global curview viewperm hlview selectedhlview
3905 if {$curview == 0} return
3906 if {[info exists hlview] && $hlview == $curview} {
3907 set selectedhlview [mc "None"]
3908 unset hlview
3910 allviewmenus $curview delete
3911 set viewperm($curview) 0
3912 showview 0
3915 proc addviewmenu {n} {
3916 global viewname viewhlmenu
3918 .bar.view add radiobutton -label $viewname($n) \
3919 -command [list showview $n] -variable selectedview -value $n
3920 #$viewhlmenu add radiobutton -label $viewname($n) \
3921 # -command [list addvhighlight $n] -variable selectedhlview
3924 proc showview {n} {
3925 global curview cached_commitrow ordertok
3926 global displayorder parentlist rowidlist rowisopt rowfinal
3927 global colormap rowtextx nextcolor canvxmax
3928 global numcommits viewcomplete
3929 global selectedline currentid canv canvy0
3930 global treediffs
3931 global pending_select mainheadid
3932 global commitidx
3933 global selectedview
3934 global hlview selectedhlview commitinterest
3936 if {$n == $curview} return
3937 set selid {}
3938 set ymax [lindex [$canv cget -scrollregion] 3]
3939 set span [$canv yview]
3940 set ytop [expr {[lindex $span 0] * $ymax}]
3941 set ybot [expr {[lindex $span 1] * $ymax}]
3942 set yscreen [expr {($ybot - $ytop) / 2}]
3943 if {$selectedline ne {}} {
3944 set selid $currentid
3945 set y [yc $selectedline]
3946 if {$ytop < $y && $y < $ybot} {
3947 set yscreen [expr {$y - $ytop}]
3949 } elseif {[info exists pending_select]} {
3950 set selid $pending_select
3951 unset pending_select
3953 unselectline
3954 normalline
3955 catch {unset treediffs}
3956 clear_display
3957 if {[info exists hlview] && $hlview == $n} {
3958 unset hlview
3959 set selectedhlview [mc "None"]
3961 catch {unset commitinterest}
3962 catch {unset cached_commitrow}
3963 catch {unset ordertok}
3965 set curview $n
3966 set selectedview $n
3967 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3968 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3970 run refill_reflist
3971 if {![info exists viewcomplete($n)]} {
3972 getcommits $selid
3973 return
3976 set displayorder {}
3977 set parentlist {}
3978 set rowidlist {}
3979 set rowisopt {}
3980 set rowfinal {}
3981 set numcommits $commitidx($n)
3983 catch {unset colormap}
3984 catch {unset rowtextx}
3985 set nextcolor 0
3986 set canvxmax [$canv cget -width]
3987 set curview $n
3988 set row 0
3989 setcanvscroll
3990 set yf 0
3991 set row {}
3992 if {$selid ne {} && [commitinview $selid $n]} {
3993 set row [rowofcommit $selid]
3994 # try to get the selected row in the same position on the screen
3995 set ymax [lindex [$canv cget -scrollregion] 3]
3996 set ytop [expr {[yc $row] - $yscreen}]
3997 if {$ytop < 0} {
3998 set ytop 0
4000 set yf [expr {$ytop * 1.0 / $ymax}]
4002 allcanvs yview moveto $yf
4003 drawvisible
4004 if {$row ne {}} {
4005 selectline $row 0
4006 } elseif {!$viewcomplete($n)} {
4007 reset_pending_select $selid
4008 } else {
4009 reset_pending_select {}
4011 if {[commitinview $pending_select $curview]} {
4012 selectline [rowofcommit $pending_select] 1
4013 } else {
4014 set row [first_real_row]
4015 if {$row < $numcommits} {
4016 selectline $row 0
4020 if {!$viewcomplete($n)} {
4021 if {$numcommits == 0} {
4022 show_status [mc "Reading commits..."]
4024 } elseif {$numcommits == 0} {
4025 show_status [mc "No commits selected"]
4029 # Stuff relating to the highlighting facility
4031 proc ishighlighted {id} {
4032 global vhighlights fhighlights nhighlights rhighlights
4034 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4035 return $nhighlights($id)
4037 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4038 return $vhighlights($id)
4040 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4041 return $fhighlights($id)
4043 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4044 return $rhighlights($id)
4046 return 0
4049 proc bolden {id font} {
4050 global canv linehtag currentid boldids need_redisplay
4052 # need_redisplay = 1 means the display is stale and about to be redrawn
4053 if {$need_redisplay} return
4054 lappend boldids $id
4055 $canv itemconf $linehtag($id) -font $font
4056 if {[info exists currentid] && $id eq $currentid} {
4057 $canv delete secsel
4058 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4059 -outline {{}} -tags secsel \
4060 -fill [$canv cget -selectbackground]]
4061 $canv lower $t
4065 proc bolden_name {id font} {
4066 global canv2 linentag currentid boldnameids need_redisplay
4068 if {$need_redisplay} return
4069 lappend boldnameids $id
4070 $canv2 itemconf $linentag($id) -font $font
4071 if {[info exists currentid] && $id eq $currentid} {
4072 $canv2 delete secsel
4073 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4074 -outline {{}} -tags secsel \
4075 -fill [$canv2 cget -selectbackground]]
4076 $canv2 lower $t
4080 proc unbolden {} {
4081 global boldids
4083 set stillbold {}
4084 foreach id $boldids {
4085 if {![ishighlighted $id]} {
4086 bolden $id mainfont
4087 } else {
4088 lappend stillbold $id
4091 set boldids $stillbold
4094 proc addvhighlight {n} {
4095 global hlview viewcomplete curview vhl_done commitidx
4097 if {[info exists hlview]} {
4098 delvhighlight
4100 set hlview $n
4101 if {$n != $curview && ![info exists viewcomplete($n)]} {
4102 start_rev_list $n
4104 set vhl_done $commitidx($hlview)
4105 if {$vhl_done > 0} {
4106 drawvisible
4110 proc delvhighlight {} {
4111 global hlview vhighlights
4113 if {![info exists hlview]} return
4114 unset hlview
4115 catch {unset vhighlights}
4116 unbolden
4119 proc vhighlightmore {} {
4120 global hlview vhl_done commitidx vhighlights curview
4122 set max $commitidx($hlview)
4123 set vr [visiblerows]
4124 set r0 [lindex $vr 0]
4125 set r1 [lindex $vr 1]
4126 for {set i $vhl_done} {$i < $max} {incr i} {
4127 set id [commitonrow $i $hlview]
4128 if {[commitinview $id $curview]} {
4129 set row [rowofcommit $id]
4130 if {$r0 <= $row && $row <= $r1} {
4131 if {![highlighted $row]} {
4132 bolden $id mainfontbold
4134 set vhighlights($id) 1
4138 set vhl_done $max
4139 return 0
4142 proc askvhighlight {row id} {
4143 global hlview vhighlights iddrawn
4145 if {[commitinview $id $hlview]} {
4146 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4147 bolden $id mainfontbold
4149 set vhighlights($id) 1
4150 } else {
4151 set vhighlights($id) 0
4155 proc hfiles_change {} {
4156 global highlight_files filehighlight fhighlights fh_serial
4157 global highlight_paths
4159 if {[info exists filehighlight]} {
4160 # delete previous highlights
4161 catch {close $filehighlight}
4162 unset filehighlight
4163 catch {unset fhighlights}
4164 unbolden
4165 unhighlight_filelist
4167 set highlight_paths {}
4168 after cancel do_file_hl $fh_serial
4169 incr fh_serial
4170 if {$highlight_files ne {}} {
4171 after 300 do_file_hl $fh_serial
4175 proc gdttype_change {name ix op} {
4176 global gdttype highlight_files findstring findpattern
4178 stopfinding
4179 if {$findstring ne {}} {
4180 if {$gdttype eq [mc "containing:"]} {
4181 if {$highlight_files ne {}} {
4182 set highlight_files {}
4183 hfiles_change
4185 findcom_change
4186 } else {
4187 if {$findpattern ne {}} {
4188 set findpattern {}
4189 findcom_change
4191 set highlight_files $findstring
4192 hfiles_change
4194 drawvisible
4196 # enable/disable findtype/findloc menus too
4199 proc find_change {name ix op} {
4200 global gdttype findstring highlight_files
4202 stopfinding
4203 if {$gdttype eq [mc "containing:"]} {
4204 findcom_change
4205 } else {
4206 if {$highlight_files ne $findstring} {
4207 set highlight_files $findstring
4208 hfiles_change
4211 drawvisible
4214 proc findcom_change args {
4215 global nhighlights boldnameids
4216 global findpattern findtype findstring gdttype
4218 stopfinding
4219 # delete previous highlights, if any
4220 foreach id $boldnameids {
4221 bolden_name $id mainfont
4223 set boldnameids {}
4224 catch {unset nhighlights}
4225 unbolden
4226 unmarkmatches
4227 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4228 set findpattern {}
4229 } elseif {$findtype eq [mc "Regexp"]} {
4230 set findpattern $findstring
4231 } else {
4232 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4233 $findstring]
4234 set findpattern "*$e*"
4238 proc makepatterns {l} {
4239 set ret {}
4240 foreach e $l {
4241 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4242 if {[string index $ee end] eq "/"} {
4243 lappend ret "$ee*"
4244 } else {
4245 lappend ret $ee
4246 lappend ret "$ee/*"
4249 return $ret
4252 proc do_file_hl {serial} {
4253 global highlight_files filehighlight highlight_paths gdttype fhl_list
4255 if {$gdttype eq [mc "touching paths:"]} {
4256 if {[catch {set paths [shellsplit $highlight_files]}]} return
4257 set highlight_paths [makepatterns $paths]
4258 highlight_filelist
4259 set gdtargs [concat -- $paths]
4260 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4261 set gdtargs [list "-S$highlight_files"]
4262 } else {
4263 # must be "containing:", i.e. we're searching commit info
4264 return
4266 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4267 set filehighlight [open $cmd r+]
4268 fconfigure $filehighlight -blocking 0
4269 filerun $filehighlight readfhighlight
4270 set fhl_list {}
4271 drawvisible
4272 flushhighlights
4275 proc flushhighlights {} {
4276 global filehighlight fhl_list
4278 if {[info exists filehighlight]} {
4279 lappend fhl_list {}
4280 puts $filehighlight ""
4281 flush $filehighlight
4285 proc askfilehighlight {row id} {
4286 global filehighlight fhighlights fhl_list
4288 lappend fhl_list $id
4289 set fhighlights($id) -1
4290 puts $filehighlight $id
4293 proc readfhighlight {} {
4294 global filehighlight fhighlights curview iddrawn
4295 global fhl_list find_dirn
4297 if {![info exists filehighlight]} {
4298 return 0
4300 set nr 0
4301 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4302 set line [string trim $line]
4303 set i [lsearch -exact $fhl_list $line]
4304 if {$i < 0} continue
4305 for {set j 0} {$j < $i} {incr j} {
4306 set id [lindex $fhl_list $j]
4307 set fhighlights($id) 0
4309 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4310 if {$line eq {}} continue
4311 if {![commitinview $line $curview]} continue
4312 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4313 bolden $line mainfontbold
4315 set fhighlights($line) 1
4317 if {[eof $filehighlight]} {
4318 # strange...
4319 puts "oops, git diff-tree died"
4320 catch {close $filehighlight}
4321 unset filehighlight
4322 return 0
4324 if {[info exists find_dirn]} {
4325 run findmore
4327 return 1
4330 proc doesmatch {f} {
4331 global findtype findpattern
4333 if {$findtype eq [mc "Regexp"]} {
4334 return [regexp $findpattern $f]
4335 } elseif {$findtype eq [mc "IgnCase"]} {
4336 return [string match -nocase $findpattern $f]
4337 } else {
4338 return [string match $findpattern $f]
4342 proc askfindhighlight {row id} {
4343 global nhighlights commitinfo iddrawn
4344 global findloc
4345 global markingmatches
4347 if {![info exists commitinfo($id)]} {
4348 getcommit $id
4350 set info $commitinfo($id)
4351 set isbold 0
4352 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4353 foreach f $info ty $fldtypes {
4354 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4355 [doesmatch $f]} {
4356 if {$ty eq [mc "Author"]} {
4357 set isbold 2
4358 break
4360 set isbold 1
4363 if {$isbold && [info exists iddrawn($id)]} {
4364 if {![ishighlighted $id]} {
4365 bolden $id mainfontbold
4366 if {$isbold > 1} {
4367 bolden_name $id mainfontbold
4370 if {$markingmatches} {
4371 markrowmatches $row $id
4374 set nhighlights($id) $isbold
4377 proc markrowmatches {row id} {
4378 global canv canv2 linehtag linentag commitinfo findloc
4380 set headline [lindex $commitinfo($id) 0]
4381 set author [lindex $commitinfo($id) 1]
4382 $canv delete match$row
4383 $canv2 delete match$row
4384 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4385 set m [findmatches $headline]
4386 if {$m ne {}} {
4387 markmatches $canv $row $headline $linehtag($id) $m \
4388 [$canv itemcget $linehtag($id) -font] $row
4391 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4392 set m [findmatches $author]
4393 if {$m ne {}} {
4394 markmatches $canv2 $row $author $linentag($id) $m \
4395 [$canv2 itemcget $linentag($id) -font] $row
4400 proc vrel_change {name ix op} {
4401 global highlight_related
4403 rhighlight_none
4404 if {$highlight_related ne [mc "None"]} {
4405 run drawvisible
4409 # prepare for testing whether commits are descendents or ancestors of a
4410 proc rhighlight_sel {a} {
4411 global descendent desc_todo ancestor anc_todo
4412 global highlight_related
4414 catch {unset descendent}
4415 set desc_todo [list $a]
4416 catch {unset ancestor}
4417 set anc_todo [list $a]
4418 if {$highlight_related ne [mc "None"]} {
4419 rhighlight_none
4420 run drawvisible
4424 proc rhighlight_none {} {
4425 global rhighlights
4427 catch {unset rhighlights}
4428 unbolden
4431 proc is_descendent {a} {
4432 global curview children descendent desc_todo
4434 set v $curview
4435 set la [rowofcommit $a]
4436 set todo $desc_todo
4437 set leftover {}
4438 set done 0
4439 for {set i 0} {$i < [llength $todo]} {incr i} {
4440 set do [lindex $todo $i]
4441 if {[rowofcommit $do] < $la} {
4442 lappend leftover $do
4443 continue
4445 foreach nk $children($v,$do) {
4446 if {![info exists descendent($nk)]} {
4447 set descendent($nk) 1
4448 lappend todo $nk
4449 if {$nk eq $a} {
4450 set done 1
4454 if {$done} {
4455 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4456 return
4459 set descendent($a) 0
4460 set desc_todo $leftover
4463 proc is_ancestor {a} {
4464 global curview parents ancestor anc_todo
4466 set v $curview
4467 set la [rowofcommit $a]
4468 set todo $anc_todo
4469 set leftover {}
4470 set done 0
4471 for {set i 0} {$i < [llength $todo]} {incr i} {
4472 set do [lindex $todo $i]
4473 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4474 lappend leftover $do
4475 continue
4477 foreach np $parents($v,$do) {
4478 if {![info exists ancestor($np)]} {
4479 set ancestor($np) 1
4480 lappend todo $np
4481 if {$np eq $a} {
4482 set done 1
4486 if {$done} {
4487 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4488 return
4491 set ancestor($a) 0
4492 set anc_todo $leftover
4495 proc askrelhighlight {row id} {
4496 global descendent highlight_related iddrawn rhighlights
4497 global selectedline ancestor
4499 if {$selectedline eq {}} return
4500 set isbold 0
4501 if {$highlight_related eq [mc "Descendant"] ||
4502 $highlight_related eq [mc "Not descendant"]} {
4503 if {![info exists descendent($id)]} {
4504 is_descendent $id
4506 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4507 set isbold 1
4509 } elseif {$highlight_related eq [mc "Ancestor"] ||
4510 $highlight_related eq [mc "Not ancestor"]} {
4511 if {![info exists ancestor($id)]} {
4512 is_ancestor $id
4514 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4515 set isbold 1
4518 if {[info exists iddrawn($id)]} {
4519 if {$isbold && ![ishighlighted $id]} {
4520 bolden $id mainfontbold
4523 set rhighlights($id) $isbold
4526 # Graph layout functions
4528 proc shortids {ids} {
4529 set res {}
4530 foreach id $ids {
4531 if {[llength $id] > 1} {
4532 lappend res [shortids $id]
4533 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4534 lappend res [string range $id 0 7]
4535 } else {
4536 lappend res $id
4539 return $res
4542 proc ntimes {n o} {
4543 set ret {}
4544 set o [list $o]
4545 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4546 if {($n & $mask) != 0} {
4547 set ret [concat $ret $o]
4549 set o [concat $o $o]
4551 return $ret
4554 proc ordertoken {id} {
4555 global ordertok curview varcid varcstart varctok curview parents children
4556 global nullid nullid2
4558 if {[info exists ordertok($id)]} {
4559 return $ordertok($id)
4561 set origid $id
4562 set todo {}
4563 while {1} {
4564 if {[info exists varcid($curview,$id)]} {
4565 set a $varcid($curview,$id)
4566 set p [lindex $varcstart($curview) $a]
4567 } else {
4568 set p [lindex $children($curview,$id) 0]
4570 if {[info exists ordertok($p)]} {
4571 set tok $ordertok($p)
4572 break
4574 set id [first_real_child $curview,$p]
4575 if {$id eq {}} {
4576 # it's a root
4577 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4578 break
4580 if {[llength $parents($curview,$id)] == 1} {
4581 lappend todo [list $p {}]
4582 } else {
4583 set j [lsearch -exact $parents($curview,$id) $p]
4584 if {$j < 0} {
4585 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4587 lappend todo [list $p [strrep $j]]
4590 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4591 set p [lindex $todo $i 0]
4592 append tok [lindex $todo $i 1]
4593 set ordertok($p) $tok
4595 set ordertok($origid) $tok
4596 return $tok
4599 # Work out where id should go in idlist so that order-token
4600 # values increase from left to right
4601 proc idcol {idlist id {i 0}} {
4602 set t [ordertoken $id]
4603 if {$i < 0} {
4604 set i 0
4606 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4607 if {$i > [llength $idlist]} {
4608 set i [llength $idlist]
4610 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4611 incr i
4612 } else {
4613 if {$t > [ordertoken [lindex $idlist $i]]} {
4614 while {[incr i] < [llength $idlist] &&
4615 $t >= [ordertoken [lindex $idlist $i]]} {}
4618 return $i
4621 proc initlayout {} {
4622 global rowidlist rowisopt rowfinal displayorder parentlist
4623 global numcommits canvxmax canv
4624 global nextcolor
4625 global colormap rowtextx
4627 set numcommits 0
4628 set displayorder {}
4629 set parentlist {}
4630 set nextcolor 0
4631 set rowidlist {}
4632 set rowisopt {}
4633 set rowfinal {}
4634 set canvxmax [$canv cget -width]
4635 catch {unset colormap}
4636 catch {unset rowtextx}
4637 setcanvscroll
4640 proc setcanvscroll {} {
4641 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4642 global lastscrollset lastscrollrows
4644 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4645 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4646 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4647 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4648 set lastscrollset [clock clicks -milliseconds]
4649 set lastscrollrows $numcommits
4652 proc visiblerows {} {
4653 global canv numcommits linespc
4655 set ymax [lindex [$canv cget -scrollregion] 3]
4656 if {$ymax eq {} || $ymax == 0} return
4657 set f [$canv yview]
4658 set y0 [expr {int([lindex $f 0] * $ymax)}]
4659 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4660 if {$r0 < 0} {
4661 set r0 0
4663 set y1 [expr {int([lindex $f 1] * $ymax)}]
4664 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4665 if {$r1 >= $numcommits} {
4666 set r1 [expr {$numcommits - 1}]
4668 return [list $r0 $r1]
4671 proc layoutmore {} {
4672 global commitidx viewcomplete curview
4673 global numcommits pending_select curview
4674 global lastscrollset lastscrollrows
4676 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4677 [clock clicks -milliseconds] - $lastscrollset > 500} {
4678 setcanvscroll
4680 if {[info exists pending_select] &&
4681 [commitinview $pending_select $curview]} {
4682 update
4683 selectline [rowofcommit $pending_select] 1
4685 drawvisible
4688 # With path limiting, we mightn't get the actual HEAD commit,
4689 # so ask git rev-list what is the first ancestor of HEAD that
4690 # touches a file in the path limit.
4691 proc get_viewmainhead {view} {
4692 global viewmainheadid vfilelimit viewinstances mainheadid
4694 catch {
4695 set rfd [open [concat | git rev-list -1 $mainheadid \
4696 -- $vfilelimit($view)] r]
4697 set j [reg_instance $rfd]
4698 lappend viewinstances($view) $j
4699 fconfigure $rfd -blocking 0
4700 filerun $rfd [list getviewhead $rfd $j $view]
4701 set viewmainheadid($curview) {}
4705 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4706 proc getviewhead {fd inst view} {
4707 global viewmainheadid commfd curview viewinstances showlocalchanges
4709 set id {}
4710 if {[gets $fd line] < 0} {
4711 if {![eof $fd]} {
4712 return 1
4714 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4715 set id $line
4717 set viewmainheadid($view) $id
4718 close $fd
4719 unset commfd($inst)
4720 set i [lsearch -exact $viewinstances($view) $inst]
4721 if {$i >= 0} {
4722 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4724 if {$showlocalchanges && $id ne {} && $view == $curview} {
4725 doshowlocalchanges
4727 return 0
4730 proc doshowlocalchanges {} {
4731 global curview viewmainheadid
4733 if {$viewmainheadid($curview) eq {}} return
4734 if {[commitinview $viewmainheadid($curview) $curview]} {
4735 dodiffindex
4736 } else {
4737 interestedin $viewmainheadid($curview) dodiffindex
4741 proc dohidelocalchanges {} {
4742 global nullid nullid2 lserial curview
4744 if {[commitinview $nullid $curview]} {
4745 removefakerow $nullid
4747 if {[commitinview $nullid2 $curview]} {
4748 removefakerow $nullid2
4750 incr lserial
4753 # spawn off a process to do git diff-index --cached HEAD
4754 proc dodiffindex {} {
4755 global lserial showlocalchanges vfilelimit curview
4756 global isworktree
4758 if {!$showlocalchanges || !$isworktree} return
4759 incr lserial
4760 set cmd "|git diff-index --cached HEAD"
4761 if {$vfilelimit($curview) ne {}} {
4762 set cmd [concat $cmd -- $vfilelimit($curview)]
4764 set fd [open $cmd r]
4765 fconfigure $fd -blocking 0
4766 set i [reg_instance $fd]
4767 filerun $fd [list readdiffindex $fd $lserial $i]
4770 proc readdiffindex {fd serial inst} {
4771 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4772 global vfilelimit
4774 set isdiff 1
4775 if {[gets $fd line] < 0} {
4776 if {![eof $fd]} {
4777 return 1
4779 set isdiff 0
4781 # we only need to see one line and we don't really care what it says...
4782 stop_instance $inst
4784 if {$serial != $lserial} {
4785 return 0
4788 # now see if there are any local changes not checked in to the index
4789 set cmd "|git diff-files"
4790 if {$vfilelimit($curview) ne {}} {
4791 set cmd [concat $cmd -- $vfilelimit($curview)]
4793 set fd [open $cmd r]
4794 fconfigure $fd -blocking 0
4795 set i [reg_instance $fd]
4796 filerun $fd [list readdifffiles $fd $serial $i]
4798 if {$isdiff && ![commitinview $nullid2 $curview]} {
4799 # add the line for the changes in the index to the graph
4800 set hl [mc "Local changes checked in to index but not committed"]
4801 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4802 set commitdata($nullid2) "\n $hl\n"
4803 if {[commitinview $nullid $curview]} {
4804 removefakerow $nullid
4806 insertfakerow $nullid2 $viewmainheadid($curview)
4807 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4808 if {[commitinview $nullid $curview]} {
4809 removefakerow $nullid
4811 removefakerow $nullid2
4813 return 0
4816 proc readdifffiles {fd serial inst} {
4817 global viewmainheadid nullid nullid2 curview
4818 global commitinfo commitdata lserial
4820 set isdiff 1
4821 if {[gets $fd line] < 0} {
4822 if {![eof $fd]} {
4823 return 1
4825 set isdiff 0
4827 # we only need to see one line and we don't really care what it says...
4828 stop_instance $inst
4830 if {$serial != $lserial} {
4831 return 0
4834 if {$isdiff && ![commitinview $nullid $curview]} {
4835 # add the line for the local diff to the graph
4836 set hl [mc "Local uncommitted changes, not checked in to index"]
4837 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4838 set commitdata($nullid) "\n $hl\n"
4839 if {[commitinview $nullid2 $curview]} {
4840 set p $nullid2
4841 } else {
4842 set p $viewmainheadid($curview)
4844 insertfakerow $nullid $p
4845 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4846 removefakerow $nullid
4848 return 0
4851 proc nextuse {id row} {
4852 global curview children
4854 if {[info exists children($curview,$id)]} {
4855 foreach kid $children($curview,$id) {
4856 if {![commitinview $kid $curview]} {
4857 return -1
4859 if {[rowofcommit $kid] > $row} {
4860 return [rowofcommit $kid]
4864 if {[commitinview $id $curview]} {
4865 return [rowofcommit $id]
4867 return -1
4870 proc prevuse {id row} {
4871 global curview children
4873 set ret -1
4874 if {[info exists children($curview,$id)]} {
4875 foreach kid $children($curview,$id) {
4876 if {![commitinview $kid $curview]} break
4877 if {[rowofcommit $kid] < $row} {
4878 set ret [rowofcommit $kid]
4882 return $ret
4885 proc make_idlist {row} {
4886 global displayorder parentlist uparrowlen downarrowlen mingaplen
4887 global commitidx curview children
4889 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4890 if {$r < 0} {
4891 set r 0
4893 set ra [expr {$row - $downarrowlen}]
4894 if {$ra < 0} {
4895 set ra 0
4897 set rb [expr {$row + $uparrowlen}]
4898 if {$rb > $commitidx($curview)} {
4899 set rb $commitidx($curview)
4901 make_disporder $r [expr {$rb + 1}]
4902 set ids {}
4903 for {} {$r < $ra} {incr r} {
4904 set nextid [lindex $displayorder [expr {$r + 1}]]
4905 foreach p [lindex $parentlist $r] {
4906 if {$p eq $nextid} continue
4907 set rn [nextuse $p $r]
4908 if {$rn >= $row &&
4909 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4910 lappend ids [list [ordertoken $p] $p]
4914 for {} {$r < $row} {incr r} {
4915 set nextid [lindex $displayorder [expr {$r + 1}]]
4916 foreach p [lindex $parentlist $r] {
4917 if {$p eq $nextid} continue
4918 set rn [nextuse $p $r]
4919 if {$rn < 0 || $rn >= $row} {
4920 lappend ids [list [ordertoken $p] $p]
4924 set id [lindex $displayorder $row]
4925 lappend ids [list [ordertoken $id] $id]
4926 while {$r < $rb} {
4927 foreach p [lindex $parentlist $r] {
4928 set firstkid [lindex $children($curview,$p) 0]
4929 if {[rowofcommit $firstkid] < $row} {
4930 lappend ids [list [ordertoken $p] $p]
4933 incr r
4934 set id [lindex $displayorder $r]
4935 if {$id ne {}} {
4936 set firstkid [lindex $children($curview,$id) 0]
4937 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4938 lappend ids [list [ordertoken $id] $id]
4942 set idlist {}
4943 foreach idx [lsort -unique $ids] {
4944 lappend idlist [lindex $idx 1]
4946 return $idlist
4949 proc rowsequal {a b} {
4950 while {[set i [lsearch -exact $a {}]] >= 0} {
4951 set a [lreplace $a $i $i]
4953 while {[set i [lsearch -exact $b {}]] >= 0} {
4954 set b [lreplace $b $i $i]
4956 return [expr {$a eq $b}]
4959 proc makeupline {id row rend col} {
4960 global rowidlist uparrowlen downarrowlen mingaplen
4962 for {set r $rend} {1} {set r $rstart} {
4963 set rstart [prevuse $id $r]
4964 if {$rstart < 0} return
4965 if {$rstart < $row} break
4967 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4968 set rstart [expr {$rend - $uparrowlen - 1}]
4970 for {set r $rstart} {[incr r] <= $row} {} {
4971 set idlist [lindex $rowidlist $r]
4972 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4973 set col [idcol $idlist $id $col]
4974 lset rowidlist $r [linsert $idlist $col $id]
4975 changedrow $r
4980 proc layoutrows {row endrow} {
4981 global rowidlist rowisopt rowfinal displayorder
4982 global uparrowlen downarrowlen maxwidth mingaplen
4983 global children parentlist
4984 global commitidx viewcomplete curview
4986 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4987 set idlist {}
4988 if {$row > 0} {
4989 set rm1 [expr {$row - 1}]
4990 foreach id [lindex $rowidlist $rm1] {
4991 if {$id ne {}} {
4992 lappend idlist $id
4995 set final [lindex $rowfinal $rm1]
4997 for {} {$row < $endrow} {incr row} {
4998 set rm1 [expr {$row - 1}]
4999 if {$rm1 < 0 || $idlist eq {}} {
5000 set idlist [make_idlist $row]
5001 set final 1
5002 } else {
5003 set id [lindex $displayorder $rm1]
5004 set col [lsearch -exact $idlist $id]
5005 set idlist [lreplace $idlist $col $col]
5006 foreach p [lindex $parentlist $rm1] {
5007 if {[lsearch -exact $idlist $p] < 0} {
5008 set col [idcol $idlist $p $col]
5009 set idlist [linsert $idlist $col $p]
5010 # if not the first child, we have to insert a line going up
5011 if {$id ne [lindex $children($curview,$p) 0]} {
5012 makeupline $p $rm1 $row $col
5016 set id [lindex $displayorder $row]
5017 if {$row > $downarrowlen} {
5018 set termrow [expr {$row - $downarrowlen - 1}]
5019 foreach p [lindex $parentlist $termrow] {
5020 set i [lsearch -exact $idlist $p]
5021 if {$i < 0} continue
5022 set nr [nextuse $p $termrow]
5023 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5024 set idlist [lreplace $idlist $i $i]
5028 set col [lsearch -exact $idlist $id]
5029 if {$col < 0} {
5030 set col [idcol $idlist $id]
5031 set idlist [linsert $idlist $col $id]
5032 if {$children($curview,$id) ne {}} {
5033 makeupline $id $rm1 $row $col
5036 set r [expr {$row + $uparrowlen - 1}]
5037 if {$r < $commitidx($curview)} {
5038 set x $col
5039 foreach p [lindex $parentlist $r] {
5040 if {[lsearch -exact $idlist $p] >= 0} continue
5041 set fk [lindex $children($curview,$p) 0]
5042 if {[rowofcommit $fk] < $row} {
5043 set x [idcol $idlist $p $x]
5044 set idlist [linsert $idlist $x $p]
5047 if {[incr r] < $commitidx($curview)} {
5048 set p [lindex $displayorder $r]
5049 if {[lsearch -exact $idlist $p] < 0} {
5050 set fk [lindex $children($curview,$p) 0]
5051 if {$fk ne {} && [rowofcommit $fk] < $row} {
5052 set x [idcol $idlist $p $x]
5053 set idlist [linsert $idlist $x $p]
5059 if {$final && !$viewcomplete($curview) &&
5060 $row + $uparrowlen + $mingaplen + $downarrowlen
5061 >= $commitidx($curview)} {
5062 set final 0
5064 set l [llength $rowidlist]
5065 if {$row == $l} {
5066 lappend rowidlist $idlist
5067 lappend rowisopt 0
5068 lappend rowfinal $final
5069 } elseif {$row < $l} {
5070 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5071 lset rowidlist $row $idlist
5072 changedrow $row
5074 lset rowfinal $row $final
5075 } else {
5076 set pad [ntimes [expr {$row - $l}] {}]
5077 set rowidlist [concat $rowidlist $pad]
5078 lappend rowidlist $idlist
5079 set rowfinal [concat $rowfinal $pad]
5080 lappend rowfinal $final
5081 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5084 return $row
5087 proc changedrow {row} {
5088 global displayorder iddrawn rowisopt need_redisplay
5090 set l [llength $rowisopt]
5091 if {$row < $l} {
5092 lset rowisopt $row 0
5093 if {$row + 1 < $l} {
5094 lset rowisopt [expr {$row + 1}] 0
5095 if {$row + 2 < $l} {
5096 lset rowisopt [expr {$row + 2}] 0
5100 set id [lindex $displayorder $row]
5101 if {[info exists iddrawn($id)]} {
5102 set need_redisplay 1
5106 proc insert_pad {row col npad} {
5107 global rowidlist
5109 set pad [ntimes $npad {}]
5110 set idlist [lindex $rowidlist $row]
5111 set bef [lrange $idlist 0 [expr {$col - 1}]]
5112 set aft [lrange $idlist $col end]
5113 set i [lsearch -exact $aft {}]
5114 if {$i > 0} {
5115 set aft [lreplace $aft $i $i]
5117 lset rowidlist $row [concat $bef $pad $aft]
5118 changedrow $row
5121 proc optimize_rows {row col endrow} {
5122 global rowidlist rowisopt displayorder curview children
5124 if {$row < 1} {
5125 set row 1
5127 for {} {$row < $endrow} {incr row; set col 0} {
5128 if {[lindex $rowisopt $row]} continue
5129 set haspad 0
5130 set y0 [expr {$row - 1}]
5131 set ym [expr {$row - 2}]
5132 set idlist [lindex $rowidlist $row]
5133 set previdlist [lindex $rowidlist $y0]
5134 if {$idlist eq {} || $previdlist eq {}} continue
5135 if {$ym >= 0} {
5136 set pprevidlist [lindex $rowidlist $ym]
5137 if {$pprevidlist eq {}} continue
5138 } else {
5139 set pprevidlist {}
5141 set x0 -1
5142 set xm -1
5143 for {} {$col < [llength $idlist]} {incr col} {
5144 set id [lindex $idlist $col]
5145 if {[lindex $previdlist $col] eq $id} continue
5146 if {$id eq {}} {
5147 set haspad 1
5148 continue
5150 set x0 [lsearch -exact $previdlist $id]
5151 if {$x0 < 0} continue
5152 set z [expr {$x0 - $col}]
5153 set isarrow 0
5154 set z0 {}
5155 if {$ym >= 0} {
5156 set xm [lsearch -exact $pprevidlist $id]
5157 if {$xm >= 0} {
5158 set z0 [expr {$xm - $x0}]
5161 if {$z0 eq {}} {
5162 # if row y0 is the first child of $id then it's not an arrow
5163 if {[lindex $children($curview,$id) 0] ne
5164 [lindex $displayorder $y0]} {
5165 set isarrow 1
5168 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5169 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5170 set isarrow 1
5172 # Looking at lines from this row to the previous row,
5173 # make them go straight up if they end in an arrow on
5174 # the previous row; otherwise make them go straight up
5175 # or at 45 degrees.
5176 if {$z < -1 || ($z < 0 && $isarrow)} {
5177 # Line currently goes left too much;
5178 # insert pads in the previous row, then optimize it
5179 set npad [expr {-1 - $z + $isarrow}]
5180 insert_pad $y0 $x0 $npad
5181 if {$y0 > 0} {
5182 optimize_rows $y0 $x0 $row
5184 set previdlist [lindex $rowidlist $y0]
5185 set x0 [lsearch -exact $previdlist $id]
5186 set z [expr {$x0 - $col}]
5187 if {$z0 ne {}} {
5188 set pprevidlist [lindex $rowidlist $ym]
5189 set xm [lsearch -exact $pprevidlist $id]
5190 set z0 [expr {$xm - $x0}]
5192 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5193 # Line currently goes right too much;
5194 # insert pads in this line
5195 set npad [expr {$z - 1 + $isarrow}]
5196 insert_pad $row $col $npad
5197 set idlist [lindex $rowidlist $row]
5198 incr col $npad
5199 set z [expr {$x0 - $col}]
5200 set haspad 1
5202 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5203 # this line links to its first child on row $row-2
5204 set id [lindex $displayorder $ym]
5205 set xc [lsearch -exact $pprevidlist $id]
5206 if {$xc >= 0} {
5207 set z0 [expr {$xc - $x0}]
5210 # avoid lines jigging left then immediately right
5211 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5212 insert_pad $y0 $x0 1
5213 incr x0
5214 optimize_rows $y0 $x0 $row
5215 set previdlist [lindex $rowidlist $y0]
5218 if {!$haspad} {
5219 # Find the first column that doesn't have a line going right
5220 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5221 set id [lindex $idlist $col]
5222 if {$id eq {}} break
5223 set x0 [lsearch -exact $previdlist $id]
5224 if {$x0 < 0} {
5225 # check if this is the link to the first child
5226 set kid [lindex $displayorder $y0]
5227 if {[lindex $children($curview,$id) 0] eq $kid} {
5228 # it is, work out offset to child
5229 set x0 [lsearch -exact $previdlist $kid]
5232 if {$x0 <= $col} break
5234 # Insert a pad at that column as long as it has a line and
5235 # isn't the last column
5236 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5237 set idlist [linsert $idlist $col {}]
5238 lset rowidlist $row $idlist
5239 changedrow $row
5245 proc xc {row col} {
5246 global canvx0 linespc
5247 return [expr {$canvx0 + $col * $linespc}]
5250 proc yc {row} {
5251 global canvy0 linespc
5252 return [expr {$canvy0 + $row * $linespc}]
5255 proc linewidth {id} {
5256 global thickerline lthickness
5258 set wid $lthickness
5259 if {[info exists thickerline] && $id eq $thickerline} {
5260 set wid [expr {2 * $lthickness}]
5262 return $wid
5265 proc rowranges {id} {
5266 global curview children uparrowlen downarrowlen
5267 global rowidlist
5269 set kids $children($curview,$id)
5270 if {$kids eq {}} {
5271 return {}
5273 set ret {}
5274 lappend kids $id
5275 foreach child $kids {
5276 if {![commitinview $child $curview]} break
5277 set row [rowofcommit $child]
5278 if {![info exists prev]} {
5279 lappend ret [expr {$row + 1}]
5280 } else {
5281 if {$row <= $prevrow} {
5282 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5284 # see if the line extends the whole way from prevrow to row
5285 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5286 [lsearch -exact [lindex $rowidlist \
5287 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5288 # it doesn't, see where it ends
5289 set r [expr {$prevrow + $downarrowlen}]
5290 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5291 while {[incr r -1] > $prevrow &&
5292 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5293 } else {
5294 while {[incr r] <= $row &&
5295 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5296 incr r -1
5298 lappend ret $r
5299 # see where it starts up again
5300 set r [expr {$row - $uparrowlen}]
5301 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5302 while {[incr r] < $row &&
5303 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5304 } else {
5305 while {[incr r -1] >= $prevrow &&
5306 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5307 incr r
5309 lappend ret $r
5312 if {$child eq $id} {
5313 lappend ret $row
5315 set prev $child
5316 set prevrow $row
5318 return $ret
5321 proc drawlineseg {id row endrow arrowlow} {
5322 global rowidlist displayorder iddrawn linesegs
5323 global canv colormap linespc curview maxlinelen parentlist
5325 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5326 set le [expr {$row + 1}]
5327 set arrowhigh 1
5328 while {1} {
5329 set c [lsearch -exact [lindex $rowidlist $le] $id]
5330 if {$c < 0} {
5331 incr le -1
5332 break
5334 lappend cols $c
5335 set x [lindex $displayorder $le]
5336 if {$x eq $id} {
5337 set arrowhigh 0
5338 break
5340 if {[info exists iddrawn($x)] || $le == $endrow} {
5341 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5342 if {$c >= 0} {
5343 lappend cols $c
5344 set arrowhigh 0
5346 break
5348 incr le
5350 if {$le <= $row} {
5351 return $row
5354 set lines {}
5355 set i 0
5356 set joinhigh 0
5357 if {[info exists linesegs($id)]} {
5358 set lines $linesegs($id)
5359 foreach li $lines {
5360 set r0 [lindex $li 0]
5361 if {$r0 > $row} {
5362 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5363 set joinhigh 1
5365 break
5367 incr i
5370 set joinlow 0
5371 if {$i > 0} {
5372 set li [lindex $lines [expr {$i-1}]]
5373 set r1 [lindex $li 1]
5374 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5375 set joinlow 1
5379 set x [lindex $cols [expr {$le - $row}]]
5380 set xp [lindex $cols [expr {$le - 1 - $row}]]
5381 set dir [expr {$xp - $x}]
5382 if {$joinhigh} {
5383 set ith [lindex $lines $i 2]
5384 set coords [$canv coords $ith]
5385 set ah [$canv itemcget $ith -arrow]
5386 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5387 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5388 if {$x2 ne {} && $x - $x2 == $dir} {
5389 set coords [lrange $coords 0 end-2]
5391 } else {
5392 set coords [list [xc $le $x] [yc $le]]
5394 if {$joinlow} {
5395 set itl [lindex $lines [expr {$i-1}] 2]
5396 set al [$canv itemcget $itl -arrow]
5397 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5398 } elseif {$arrowlow} {
5399 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5400 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5401 set arrowlow 0
5404 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5405 for {set y $le} {[incr y -1] > $row} {} {
5406 set x $xp
5407 set xp [lindex $cols [expr {$y - 1 - $row}]]
5408 set ndir [expr {$xp - $x}]
5409 if {$dir != $ndir || $xp < 0} {
5410 lappend coords [xc $y $x] [yc $y]
5412 set dir $ndir
5414 if {!$joinlow} {
5415 if {$xp < 0} {
5416 # join parent line to first child
5417 set ch [lindex $displayorder $row]
5418 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5419 if {$xc < 0} {
5420 puts "oops: drawlineseg: child $ch not on row $row"
5421 } elseif {$xc != $x} {
5422 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5423 set d [expr {int(0.5 * $linespc)}]
5424 set x1 [xc $row $x]
5425 if {$xc < $x} {
5426 set x2 [expr {$x1 - $d}]
5427 } else {
5428 set x2 [expr {$x1 + $d}]
5430 set y2 [yc $row]
5431 set y1 [expr {$y2 + $d}]
5432 lappend coords $x1 $y1 $x2 $y2
5433 } elseif {$xc < $x - 1} {
5434 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5435 } elseif {$xc > $x + 1} {
5436 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5438 set x $xc
5440 lappend coords [xc $row $x] [yc $row]
5441 } else {
5442 set xn [xc $row $xp]
5443 set yn [yc $row]
5444 lappend coords $xn $yn
5446 if {!$joinhigh} {
5447 assigncolor $id
5448 set t [$canv create line $coords -width [linewidth $id] \
5449 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5450 $canv lower $t
5451 bindline $t $id
5452 set lines [linsert $lines $i [list $row $le $t]]
5453 } else {
5454 $canv coords $ith $coords
5455 if {$arrow ne $ah} {
5456 $canv itemconf $ith -arrow $arrow
5458 lset lines $i 0 $row
5460 } else {
5461 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5462 set ndir [expr {$xo - $xp}]
5463 set clow [$canv coords $itl]
5464 if {$dir == $ndir} {
5465 set clow [lrange $clow 2 end]
5467 set coords [concat $coords $clow]
5468 if {!$joinhigh} {
5469 lset lines [expr {$i-1}] 1 $le
5470 } else {
5471 # coalesce two pieces
5472 $canv delete $ith
5473 set b [lindex $lines [expr {$i-1}] 0]
5474 set e [lindex $lines $i 1]
5475 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5477 $canv coords $itl $coords
5478 if {$arrow ne $al} {
5479 $canv itemconf $itl -arrow $arrow
5483 set linesegs($id) $lines
5484 return $le
5487 proc drawparentlinks {id row} {
5488 global rowidlist canv colormap curview parentlist
5489 global idpos linespc
5491 set rowids [lindex $rowidlist $row]
5492 set col [lsearch -exact $rowids $id]
5493 if {$col < 0} return
5494 set olds [lindex $parentlist $row]
5495 set row2 [expr {$row + 1}]
5496 set x [xc $row $col]
5497 set y [yc $row]
5498 set y2 [yc $row2]
5499 set d [expr {int(0.5 * $linespc)}]
5500 set ymid [expr {$y + $d}]
5501 set ids [lindex $rowidlist $row2]
5502 # rmx = right-most X coord used
5503 set rmx 0
5504 foreach p $olds {
5505 set i [lsearch -exact $ids $p]
5506 if {$i < 0} {
5507 puts "oops, parent $p of $id not in list"
5508 continue
5510 set x2 [xc $row2 $i]
5511 if {$x2 > $rmx} {
5512 set rmx $x2
5514 set j [lsearch -exact $rowids $p]
5515 if {$j < 0} {
5516 # drawlineseg will do this one for us
5517 continue
5519 assigncolor $p
5520 # should handle duplicated parents here...
5521 set coords [list $x $y]
5522 if {$i != $col} {
5523 # if attaching to a vertical segment, draw a smaller
5524 # slant for visual distinctness
5525 if {$i == $j} {
5526 if {$i < $col} {
5527 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5528 } else {
5529 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5531 } elseif {$i < $col && $i < $j} {
5532 # segment slants towards us already
5533 lappend coords [xc $row $j] $y
5534 } else {
5535 if {$i < $col - 1} {
5536 lappend coords [expr {$x2 + $linespc}] $y
5537 } elseif {$i > $col + 1} {
5538 lappend coords [expr {$x2 - $linespc}] $y
5540 lappend coords $x2 $y2
5542 } else {
5543 lappend coords $x2 $y2
5545 set t [$canv create line $coords -width [linewidth $p] \
5546 -fill $colormap($p) -tags lines.$p]
5547 $canv lower $t
5548 bindline $t $p
5550 if {$rmx > [lindex $idpos($id) 1]} {
5551 lset idpos($id) 1 $rmx
5552 redrawtags $id
5556 proc drawlines {id} {
5557 global canv
5559 $canv itemconf lines.$id -width [linewidth $id]
5562 proc drawcmittext {id row col} {
5563 global linespc canv canv2 canv3 fgcolor curview
5564 global cmitlisted commitinfo rowidlist parentlist
5565 global rowtextx idpos idtags idheads idotherrefs
5566 global linehtag linentag linedtag selectedline
5567 global canvxmax boldids boldnameids fgcolor
5568 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5570 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5571 set listed $cmitlisted($curview,$id)
5572 if {$id eq $nullid} {
5573 set ofill red
5574 } elseif {$id eq $nullid2} {
5575 set ofill green
5576 } elseif {$id eq $mainheadid} {
5577 set ofill yellow
5578 } else {
5579 set ofill [lindex $circlecolors $listed]
5581 set x [xc $row $col]
5582 set y [yc $row]
5583 set orad [expr {$linespc / 3}]
5584 if {$listed <= 2} {
5585 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5586 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5587 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5588 } elseif {$listed == 3} {
5589 # triangle pointing left for left-side commits
5590 set t [$canv create polygon \
5591 [expr {$x - $orad}] $y \
5592 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5593 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5594 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5595 } else {
5596 # triangle pointing right for right-side commits
5597 set t [$canv create polygon \
5598 [expr {$x + $orad - 1}] $y \
5599 [expr {$x - $orad}] [expr {$y - $orad}] \
5600 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5601 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5603 set circleitem($row) $t
5604 $canv raise $t
5605 $canv bind $t <1> {selcanvline {} %x %y}
5606 set rmx [llength [lindex $rowidlist $row]]
5607 set olds [lindex $parentlist $row]
5608 if {$olds ne {}} {
5609 set nextids [lindex $rowidlist [expr {$row + 1}]]
5610 foreach p $olds {
5611 set i [lsearch -exact $nextids $p]
5612 if {$i > $rmx} {
5613 set rmx $i
5617 set xt [xc $row $rmx]
5618 set rowtextx($row) $xt
5619 set idpos($id) [list $x $xt $y]
5620 if {[info exists idtags($id)] || [info exists idheads($id)]
5621 || [info exists idotherrefs($id)]} {
5622 set xt [drawtags $id $x $xt $y]
5624 set headline [lindex $commitinfo($id) 0]
5625 set name [lindex $commitinfo($id) 1]
5626 set date [lindex $commitinfo($id) 2]
5627 set date [formatdate $date]
5628 set font mainfont
5629 set nfont mainfont
5630 set isbold [ishighlighted $id]
5631 if {$isbold > 0} {
5632 lappend boldids $id
5633 set font mainfontbold
5634 if {$isbold > 1} {
5635 lappend boldnameids $id
5636 set nfont mainfontbold
5639 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5640 -text $headline -font $font -tags text]
5641 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5642 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5643 -text $name -font $nfont -tags text]
5644 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5645 -text $date -font mainfont -tags text]
5646 if {$selectedline == $row} {
5647 make_secsel $id
5649 set xr [expr {$xt + [font measure $font $headline]}]
5650 if {$xr > $canvxmax} {
5651 set canvxmax $xr
5652 setcanvscroll
5656 proc drawcmitrow {row} {
5657 global displayorder rowidlist nrows_drawn
5658 global iddrawn markingmatches
5659 global commitinfo numcommits
5660 global filehighlight fhighlights findpattern nhighlights
5661 global hlview vhighlights
5662 global highlight_related rhighlights
5664 if {$row >= $numcommits} return
5666 set id [lindex $displayorder $row]
5667 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5668 askvhighlight $row $id
5670 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5671 askfilehighlight $row $id
5673 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5674 askfindhighlight $row $id
5676 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5677 askrelhighlight $row $id
5679 if {![info exists iddrawn($id)]} {
5680 set col [lsearch -exact [lindex $rowidlist $row] $id]
5681 if {$col < 0} {
5682 puts "oops, row $row id $id not in list"
5683 return
5685 if {![info exists commitinfo($id)]} {
5686 getcommit $id
5688 assigncolor $id
5689 drawcmittext $id $row $col
5690 set iddrawn($id) 1
5691 incr nrows_drawn
5693 if {$markingmatches} {
5694 markrowmatches $row $id
5698 proc drawcommits {row {endrow {}}} {
5699 global numcommits iddrawn displayorder curview need_redisplay
5700 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5702 if {$row < 0} {
5703 set row 0
5705 if {$endrow eq {}} {
5706 set endrow $row
5708 if {$endrow >= $numcommits} {
5709 set endrow [expr {$numcommits - 1}]
5712 set rl1 [expr {$row - $downarrowlen - 3}]
5713 if {$rl1 < 0} {
5714 set rl1 0
5716 set ro1 [expr {$row - 3}]
5717 if {$ro1 < 0} {
5718 set ro1 0
5720 set r2 [expr {$endrow + $uparrowlen + 3}]
5721 if {$r2 > $numcommits} {
5722 set r2 $numcommits
5724 for {set r $rl1} {$r < $r2} {incr r} {
5725 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5726 if {$rl1 < $r} {
5727 layoutrows $rl1 $r
5729 set rl1 [expr {$r + 1}]
5732 if {$rl1 < $r} {
5733 layoutrows $rl1 $r
5735 optimize_rows $ro1 0 $r2
5736 if {$need_redisplay || $nrows_drawn > 2000} {
5737 clear_display
5740 # make the lines join to already-drawn rows either side
5741 set r [expr {$row - 1}]
5742 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5743 set r $row
5745 set er [expr {$endrow + 1}]
5746 if {$er >= $numcommits ||
5747 ![info exists iddrawn([lindex $displayorder $er])]} {
5748 set er $endrow
5750 for {} {$r <= $er} {incr r} {
5751 set id [lindex $displayorder $r]
5752 set wasdrawn [info exists iddrawn($id)]
5753 drawcmitrow $r
5754 if {$r == $er} break
5755 set nextid [lindex $displayorder [expr {$r + 1}]]
5756 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5757 drawparentlinks $id $r
5759 set rowids [lindex $rowidlist $r]
5760 foreach lid $rowids {
5761 if {$lid eq {}} continue
5762 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5763 if {$lid eq $id} {
5764 # see if this is the first child of any of its parents
5765 foreach p [lindex $parentlist $r] {
5766 if {[lsearch -exact $rowids $p] < 0} {
5767 # make this line extend up to the child
5768 set lineend($p) [drawlineseg $p $r $er 0]
5771 } else {
5772 set lineend($lid) [drawlineseg $lid $r $er 1]
5778 proc undolayout {row} {
5779 global uparrowlen mingaplen downarrowlen
5780 global rowidlist rowisopt rowfinal need_redisplay
5782 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5783 if {$r < 0} {
5784 set r 0
5786 if {[llength $rowidlist] > $r} {
5787 incr r -1
5788 set rowidlist [lrange $rowidlist 0 $r]
5789 set rowfinal [lrange $rowfinal 0 $r]
5790 set rowisopt [lrange $rowisopt 0 $r]
5791 set need_redisplay 1
5792 run drawvisible
5796 proc drawvisible {} {
5797 global canv linespc curview vrowmod selectedline targetrow targetid
5798 global need_redisplay cscroll numcommits
5800 set fs [$canv yview]
5801 set ymax [lindex [$canv cget -scrollregion] 3]
5802 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5803 set f0 [lindex $fs 0]
5804 set f1 [lindex $fs 1]
5805 set y0 [expr {int($f0 * $ymax)}]
5806 set y1 [expr {int($f1 * $ymax)}]
5808 if {[info exists targetid]} {
5809 if {[commitinview $targetid $curview]} {
5810 set r [rowofcommit $targetid]
5811 if {$r != $targetrow} {
5812 # Fix up the scrollregion and change the scrolling position
5813 # now that our target row has moved.
5814 set diff [expr {($r - $targetrow) * $linespc}]
5815 set targetrow $r
5816 setcanvscroll
5817 set ymax [lindex [$canv cget -scrollregion] 3]
5818 incr y0 $diff
5819 incr y1 $diff
5820 set f0 [expr {$y0 / $ymax}]
5821 set f1 [expr {$y1 / $ymax}]
5822 allcanvs yview moveto $f0
5823 $cscroll set $f0 $f1
5824 set need_redisplay 1
5826 } else {
5827 unset targetid
5831 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5832 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5833 if {$endrow >= $vrowmod($curview)} {
5834 update_arcrows $curview
5836 if {$selectedline ne {} &&
5837 $row <= $selectedline && $selectedline <= $endrow} {
5838 set targetrow $selectedline
5839 } elseif {[info exists targetid]} {
5840 set targetrow [expr {int(($row + $endrow) / 2)}]
5842 if {[info exists targetrow]} {
5843 if {$targetrow >= $numcommits} {
5844 set targetrow [expr {$numcommits - 1}]
5846 set targetid [commitonrow $targetrow]
5848 drawcommits $row $endrow
5851 proc clear_display {} {
5852 global iddrawn linesegs need_redisplay nrows_drawn
5853 global vhighlights fhighlights nhighlights rhighlights
5854 global linehtag linentag linedtag boldids boldnameids
5856 allcanvs delete all
5857 catch {unset iddrawn}
5858 catch {unset linesegs}
5859 catch {unset linehtag}
5860 catch {unset linentag}
5861 catch {unset linedtag}
5862 set boldids {}
5863 set boldnameids {}
5864 catch {unset vhighlights}
5865 catch {unset fhighlights}
5866 catch {unset nhighlights}
5867 catch {unset rhighlights}
5868 set need_redisplay 0
5869 set nrows_drawn 0
5872 proc findcrossings {id} {
5873 global rowidlist parentlist numcommits displayorder
5875 set cross {}
5876 set ccross {}
5877 foreach {s e} [rowranges $id] {
5878 if {$e >= $numcommits} {
5879 set e [expr {$numcommits - 1}]
5881 if {$e <= $s} continue
5882 for {set row $e} {[incr row -1] >= $s} {} {
5883 set x [lsearch -exact [lindex $rowidlist $row] $id]
5884 if {$x < 0} break
5885 set olds [lindex $parentlist $row]
5886 set kid [lindex $displayorder $row]
5887 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5888 if {$kidx < 0} continue
5889 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5890 foreach p $olds {
5891 set px [lsearch -exact $nextrow $p]
5892 if {$px < 0} continue
5893 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5894 if {[lsearch -exact $ccross $p] >= 0} continue
5895 if {$x == $px + ($kidx < $px? -1: 1)} {
5896 lappend ccross $p
5897 } elseif {[lsearch -exact $cross $p] < 0} {
5898 lappend cross $p
5904 return [concat $ccross {{}} $cross]
5907 proc assigncolor {id} {
5908 global colormap colors nextcolor
5909 global parents children children curview
5911 if {[info exists colormap($id)]} return
5912 set ncolors [llength $colors]
5913 if {[info exists children($curview,$id)]} {
5914 set kids $children($curview,$id)
5915 } else {
5916 set kids {}
5918 if {[llength $kids] == 1} {
5919 set child [lindex $kids 0]
5920 if {[info exists colormap($child)]
5921 && [llength $parents($curview,$child)] == 1} {
5922 set colormap($id) $colormap($child)
5923 return
5926 set badcolors {}
5927 set origbad {}
5928 foreach x [findcrossings $id] {
5929 if {$x eq {}} {
5930 # delimiter between corner crossings and other crossings
5931 if {[llength $badcolors] >= $ncolors - 1} break
5932 set origbad $badcolors
5934 if {[info exists colormap($x)]
5935 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5936 lappend badcolors $colormap($x)
5939 if {[llength $badcolors] >= $ncolors} {
5940 set badcolors $origbad
5942 set origbad $badcolors
5943 if {[llength $badcolors] < $ncolors - 1} {
5944 foreach child $kids {
5945 if {[info exists colormap($child)]
5946 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5947 lappend badcolors $colormap($child)
5949 foreach p $parents($curview,$child) {
5950 if {[info exists colormap($p)]
5951 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5952 lappend badcolors $colormap($p)
5956 if {[llength $badcolors] >= $ncolors} {
5957 set badcolors $origbad
5960 for {set i 0} {$i <= $ncolors} {incr i} {
5961 set c [lindex $colors $nextcolor]
5962 if {[incr nextcolor] >= $ncolors} {
5963 set nextcolor 0
5965 if {[lsearch -exact $badcolors $c]} break
5967 set colormap($id) $c
5970 proc bindline {t id} {
5971 global canv
5973 $canv bind $t <Enter> "lineenter %x %y $id"
5974 $canv bind $t <Motion> "linemotion %x %y $id"
5975 $canv bind $t <Leave> "lineleave $id"
5976 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5979 proc drawtags {id x xt y1} {
5980 global idtags idheads idotherrefs mainhead
5981 global linespc lthickness
5982 global canv rowtextx curview fgcolor bgcolor ctxbut
5984 set marks {}
5985 set ntags 0
5986 set nheads 0
5987 if {[info exists idtags($id)]} {
5988 set marks $idtags($id)
5989 set ntags [llength $marks]
5991 if {[info exists idheads($id)]} {
5992 set marks [concat $marks $idheads($id)]
5993 set nheads [llength $idheads($id)]
5995 if {[info exists idotherrefs($id)]} {
5996 set marks [concat $marks $idotherrefs($id)]
5998 if {$marks eq {}} {
5999 return $xt
6002 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6003 set yt [expr {$y1 - 0.5 * $linespc}]
6004 set yb [expr {$yt + $linespc - 1}]
6005 set xvals {}
6006 set wvals {}
6007 set i -1
6008 foreach tag $marks {
6009 incr i
6010 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6011 set wid [font measure mainfontbold $tag]
6012 } else {
6013 set wid [font measure mainfont $tag]
6015 lappend xvals $xt
6016 lappend wvals $wid
6017 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6019 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6020 -width $lthickness -fill black -tags tag.$id]
6021 $canv lower $t
6022 foreach tag $marks x $xvals wid $wvals {
6023 set xl [expr {$x + $delta}]
6024 set xr [expr {$x + $delta + $wid + $lthickness}]
6025 set font mainfont
6026 if {[incr ntags -1] >= 0} {
6027 # draw a tag
6028 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6029 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6030 -width 1 -outline black -fill yellow -tags tag.$id]
6031 $canv bind $t <1> [list showtag $tag 1]
6032 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6033 } else {
6034 # draw a head or other ref
6035 if {[incr nheads -1] >= 0} {
6036 set col green
6037 if {$tag eq $mainhead} {
6038 set font mainfontbold
6040 } else {
6041 set col "#ddddff"
6043 set xl [expr {$xl - $delta/2}]
6044 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6045 -width 1 -outline black -fill $col -tags tag.$id
6046 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6047 set rwid [font measure mainfont $remoteprefix]
6048 set xi [expr {$x + 1}]
6049 set yti [expr {$yt + 1}]
6050 set xri [expr {$x + $rwid}]
6051 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6052 -width 0 -fill "#ffddaa" -tags tag.$id
6055 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6056 -font $font -tags [list tag.$id text]]
6057 if {$ntags >= 0} {
6058 $canv bind $t <1> [list showtag $tag 1]
6059 } elseif {$nheads >= 0} {
6060 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6063 return $xt
6066 proc xcoord {i level ln} {
6067 global canvx0 xspc1 xspc2
6069 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6070 if {$i > 0 && $i == $level} {
6071 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6072 } elseif {$i > $level} {
6073 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6075 return $x
6078 proc show_status {msg} {
6079 global canv fgcolor
6081 clear_display
6082 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6083 -tags text -fill $fgcolor
6086 # Don't change the text pane cursor if it is currently the hand cursor,
6087 # showing that we are over a sha1 ID link.
6088 proc settextcursor {c} {
6089 global ctext curtextcursor
6091 if {[$ctext cget -cursor] == $curtextcursor} {
6092 $ctext config -cursor $c
6094 set curtextcursor $c
6097 proc nowbusy {what {name {}}} {
6098 global isbusy busyname statusw
6100 if {[array names isbusy] eq {}} {
6101 . config -cursor watch
6102 settextcursor watch
6104 set isbusy($what) 1
6105 set busyname($what) $name
6106 if {$name ne {}} {
6107 $statusw conf -text $name
6111 proc notbusy {what} {
6112 global isbusy maincursor textcursor busyname statusw
6114 catch {
6115 unset isbusy($what)
6116 if {$busyname($what) ne {} &&
6117 [$statusw cget -text] eq $busyname($what)} {
6118 $statusw conf -text {}
6121 if {[array names isbusy] eq {}} {
6122 . config -cursor $maincursor
6123 settextcursor $textcursor
6127 proc findmatches {f} {
6128 global findtype findstring
6129 if {$findtype == [mc "Regexp"]} {
6130 set matches [regexp -indices -all -inline $findstring $f]
6131 } else {
6132 set fs $findstring
6133 if {$findtype == [mc "IgnCase"]} {
6134 set f [string tolower $f]
6135 set fs [string tolower $fs]
6137 set matches {}
6138 set i 0
6139 set l [string length $fs]
6140 while {[set j [string first $fs $f $i]] >= 0} {
6141 lappend matches [list $j [expr {$j+$l-1}]]
6142 set i [expr {$j + $l}]
6145 return $matches
6148 proc dofind {{dirn 1} {wrap 1}} {
6149 global findstring findstartline findcurline selectedline numcommits
6150 global gdttype filehighlight fh_serial find_dirn findallowwrap
6152 if {[info exists find_dirn]} {
6153 if {$find_dirn == $dirn} return
6154 stopfinding
6156 focus .
6157 if {$findstring eq {} || $numcommits == 0} return
6158 if {$selectedline eq {}} {
6159 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6160 } else {
6161 set findstartline $selectedline
6163 set findcurline $findstartline
6164 nowbusy finding [mc "Searching"]
6165 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6166 after cancel do_file_hl $fh_serial
6167 do_file_hl $fh_serial
6169 set find_dirn $dirn
6170 set findallowwrap $wrap
6171 run findmore
6174 proc stopfinding {} {
6175 global find_dirn findcurline fprogcoord
6177 if {[info exists find_dirn]} {
6178 unset find_dirn
6179 unset findcurline
6180 notbusy finding
6181 set fprogcoord 0
6182 adjustprogress
6184 stopblaming
6187 proc findmore {} {
6188 global commitdata commitinfo numcommits findpattern findloc
6189 global findstartline findcurline findallowwrap
6190 global find_dirn gdttype fhighlights fprogcoord
6191 global curview varcorder vrownum varccommits vrowmod
6193 if {![info exists find_dirn]} {
6194 return 0
6196 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6197 set l $findcurline
6198 set moretodo 0
6199 if {$find_dirn > 0} {
6200 incr l
6201 if {$l >= $numcommits} {
6202 set l 0
6204 if {$l <= $findstartline} {
6205 set lim [expr {$findstartline + 1}]
6206 } else {
6207 set lim $numcommits
6208 set moretodo $findallowwrap
6210 } else {
6211 if {$l == 0} {
6212 set l $numcommits
6214 incr l -1
6215 if {$l >= $findstartline} {
6216 set lim [expr {$findstartline - 1}]
6217 } else {
6218 set lim -1
6219 set moretodo $findallowwrap
6222 set n [expr {($lim - $l) * $find_dirn}]
6223 if {$n > 500} {
6224 set n 500
6225 set moretodo 1
6227 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6228 update_arcrows $curview
6230 set found 0
6231 set domore 1
6232 set ai [bsearch $vrownum($curview) $l]
6233 set a [lindex $varcorder($curview) $ai]
6234 set arow [lindex $vrownum($curview) $ai]
6235 set ids [lindex $varccommits($curview,$a)]
6236 set arowend [expr {$arow + [llength $ids]}]
6237 if {$gdttype eq [mc "containing:"]} {
6238 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6239 if {$l < $arow || $l >= $arowend} {
6240 incr ai $find_dirn
6241 set a [lindex $varcorder($curview) $ai]
6242 set arow [lindex $vrownum($curview) $ai]
6243 set ids [lindex $varccommits($curview,$a)]
6244 set arowend [expr {$arow + [llength $ids]}]
6246 set id [lindex $ids [expr {$l - $arow}]]
6247 # shouldn't happen unless git log doesn't give all the commits...
6248 if {![info exists commitdata($id)] ||
6249 ![doesmatch $commitdata($id)]} {
6250 continue
6252 if {![info exists commitinfo($id)]} {
6253 getcommit $id
6255 set info $commitinfo($id)
6256 foreach f $info ty $fldtypes {
6257 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6258 [doesmatch $f]} {
6259 set found 1
6260 break
6263 if {$found} break
6265 } else {
6266 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6267 if {$l < $arow || $l >= $arowend} {
6268 incr ai $find_dirn
6269 set a [lindex $varcorder($curview) $ai]
6270 set arow [lindex $vrownum($curview) $ai]
6271 set ids [lindex $varccommits($curview,$a)]
6272 set arowend [expr {$arow + [llength $ids]}]
6274 set id [lindex $ids [expr {$l - $arow}]]
6275 if {![info exists fhighlights($id)]} {
6276 # this sets fhighlights($id) to -1
6277 askfilehighlight $l $id
6279 if {$fhighlights($id) > 0} {
6280 set found $domore
6281 break
6283 if {$fhighlights($id) < 0} {
6284 if {$domore} {
6285 set domore 0
6286 set findcurline [expr {$l - $find_dirn}]
6291 if {$found || ($domore && !$moretodo)} {
6292 unset findcurline
6293 unset find_dirn
6294 notbusy finding
6295 set fprogcoord 0
6296 adjustprogress
6297 if {$found} {
6298 findselectline $l
6299 } else {
6300 bell
6302 return 0
6304 if {!$domore} {
6305 flushhighlights
6306 } else {
6307 set findcurline [expr {$l - $find_dirn}]
6309 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6310 if {$n < 0} {
6311 incr n $numcommits
6313 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6314 adjustprogress
6315 return $domore
6318 proc findselectline {l} {
6319 global findloc commentend ctext findcurline markingmatches gdttype
6321 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6322 set findcurline $l
6323 selectline $l 1
6324 if {$markingmatches &&
6325 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6326 # highlight the matches in the comments
6327 set f [$ctext get 1.0 $commentend]
6328 set matches [findmatches $f]
6329 foreach match $matches {
6330 set start [lindex $match 0]
6331 set end [expr {[lindex $match 1] + 1}]
6332 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6335 drawvisible
6338 # mark the bits of a headline or author that match a find string
6339 proc markmatches {canv l str tag matches font row} {
6340 global selectedline
6342 set bbox [$canv bbox $tag]
6343 set x0 [lindex $bbox 0]
6344 set y0 [lindex $bbox 1]
6345 set y1 [lindex $bbox 3]
6346 foreach match $matches {
6347 set start [lindex $match 0]
6348 set end [lindex $match 1]
6349 if {$start > $end} continue
6350 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6351 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6352 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6353 [expr {$x0+$xlen+2}] $y1 \
6354 -outline {} -tags [list match$l matches] -fill yellow]
6355 $canv lower $t
6356 if {$row == $selectedline} {
6357 $canv raise $t secsel
6362 proc unmarkmatches {} {
6363 global markingmatches
6365 allcanvs delete matches
6366 set markingmatches 0
6367 stopfinding
6370 proc selcanvline {w x y} {
6371 global canv canvy0 ctext linespc
6372 global rowtextx
6373 set ymax [lindex [$canv cget -scrollregion] 3]
6374 if {$ymax == {}} return
6375 set yfrac [lindex [$canv yview] 0]
6376 set y [expr {$y + $yfrac * $ymax}]
6377 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6378 if {$l < 0} {
6379 set l 0
6381 if {$w eq $canv} {
6382 set xmax [lindex [$canv cget -scrollregion] 2]
6383 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6384 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6386 unmarkmatches
6387 selectline $l 1
6390 proc commit_descriptor {p} {
6391 global commitinfo
6392 if {![info exists commitinfo($p)]} {
6393 getcommit $p
6395 set l "..."
6396 if {[llength $commitinfo($p)] > 1} {
6397 set l [lindex $commitinfo($p) 0]
6399 return "$p ($l)\n"
6402 # append some text to the ctext widget, and make any SHA1 ID
6403 # that we know about be a clickable link.
6404 proc appendwithlinks {text tags} {
6405 global ctext linknum curview
6407 set start [$ctext index "end - 1c"]
6408 $ctext insert end $text $tags
6409 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6410 foreach l $links {
6411 set s [lindex $l 0]
6412 set e [lindex $l 1]
6413 set linkid [string range $text $s $e]
6414 incr e
6415 $ctext tag delete link$linknum
6416 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6417 setlink $linkid link$linknum
6418 incr linknum
6422 proc setlink {id lk} {
6423 global curview ctext pendinglinks
6425 set known 0
6426 if {[string length $id] < 40} {
6427 set matches [longid $id]
6428 if {[llength $matches] > 0} {
6429 if {[llength $matches] > 1} return
6430 set known 1
6431 set id [lindex $matches 0]
6433 } else {
6434 set known [commitinview $id $curview]
6436 if {$known} {
6437 $ctext tag conf $lk -foreground blue -underline 1
6438 $ctext tag bind $lk <1> [list selbyid $id]
6439 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6440 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6441 } else {
6442 lappend pendinglinks($id) $lk
6443 interestedin $id {makelink %P}
6447 proc makelink {id} {
6448 global pendinglinks
6450 if {![info exists pendinglinks($id)]} return
6451 foreach lk $pendinglinks($id) {
6452 setlink $id $lk
6454 unset pendinglinks($id)
6457 proc linkcursor {w inc} {
6458 global linkentercount curtextcursor
6460 if {[incr linkentercount $inc] > 0} {
6461 $w configure -cursor hand2
6462 } else {
6463 $w configure -cursor $curtextcursor
6464 if {$linkentercount < 0} {
6465 set linkentercount 0
6470 proc viewnextline {dir} {
6471 global canv linespc
6473 $canv delete hover
6474 set ymax [lindex [$canv cget -scrollregion] 3]
6475 set wnow [$canv yview]
6476 set wtop [expr {[lindex $wnow 0] * $ymax}]
6477 set newtop [expr {$wtop + $dir * $linespc}]
6478 if {$newtop < 0} {
6479 set newtop 0
6480 } elseif {$newtop > $ymax} {
6481 set newtop $ymax
6483 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6486 # add a list of tag or branch names at position pos
6487 # returns the number of names inserted
6488 proc appendrefs {pos ids var} {
6489 global ctext linknum curview $var maxrefs
6491 if {[catch {$ctext index $pos}]} {
6492 return 0
6494 $ctext conf -state normal
6495 $ctext delete $pos "$pos lineend"
6496 set tags {}
6497 foreach id $ids {
6498 foreach tag [set $var\($id\)] {
6499 lappend tags [list $tag $id]
6502 if {[llength $tags] > $maxrefs} {
6503 $ctext insert $pos "many ([llength $tags])"
6504 } else {
6505 set tags [lsort -index 0 -decreasing $tags]
6506 set sep {}
6507 foreach ti $tags {
6508 set id [lindex $ti 1]
6509 set lk link$linknum
6510 incr linknum
6511 $ctext tag delete $lk
6512 $ctext insert $pos $sep
6513 $ctext insert $pos [lindex $ti 0] $lk
6514 setlink $id $lk
6515 set sep ", "
6518 $ctext conf -state disabled
6519 return [llength $tags]
6522 # called when we have finished computing the nearby tags
6523 proc dispneartags {delay} {
6524 global selectedline currentid showneartags tagphase
6526 if {$selectedline eq {} || !$showneartags} return
6527 after cancel dispnexttag
6528 if {$delay} {
6529 after 200 dispnexttag
6530 set tagphase -1
6531 } else {
6532 after idle dispnexttag
6533 set tagphase 0
6537 proc dispnexttag {} {
6538 global selectedline currentid showneartags tagphase ctext
6540 if {$selectedline eq {} || !$showneartags} return
6541 switch -- $tagphase {
6543 set dtags [desctags $currentid]
6544 if {$dtags ne {}} {
6545 appendrefs precedes $dtags idtags
6549 set atags [anctags $currentid]
6550 if {$atags ne {}} {
6551 appendrefs follows $atags idtags
6555 set dheads [descheads $currentid]
6556 if {$dheads ne {}} {
6557 if {[appendrefs branch $dheads idheads] > 1
6558 && [$ctext get "branch -3c"] eq "h"} {
6559 # turn "Branch" into "Branches"
6560 $ctext conf -state normal
6561 $ctext insert "branch -2c" "es"
6562 $ctext conf -state disabled
6567 if {[incr tagphase] <= 2} {
6568 after idle dispnexttag
6572 proc make_secsel {id} {
6573 global linehtag linentag linedtag canv canv2 canv3
6575 if {![info exists linehtag($id)]} return
6576 $canv delete secsel
6577 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6578 -tags secsel -fill [$canv cget -selectbackground]]
6579 $canv lower $t
6580 $canv2 delete secsel
6581 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6582 -tags secsel -fill [$canv2 cget -selectbackground]]
6583 $canv2 lower $t
6584 $canv3 delete secsel
6585 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6586 -tags secsel -fill [$canv3 cget -selectbackground]]
6587 $canv3 lower $t
6590 proc selectline {l isnew {desired_loc {}}} {
6591 global canv ctext commitinfo selectedline
6592 global canvy0 linespc parents children curview
6593 global currentid sha1entry
6594 global commentend idtags linknum
6595 global mergemax numcommits pending_select
6596 global cmitmode showneartags allcommits
6597 global targetrow targetid lastscrollrows
6598 global autoselect jump_to_here
6600 catch {unset pending_select}
6601 $canv delete hover
6602 normalline
6603 unsel_reflist
6604 stopfinding
6605 if {$l < 0 || $l >= $numcommits} return
6606 set id [commitonrow $l]
6607 set targetid $id
6608 set targetrow $l
6609 set selectedline $l
6610 set currentid $id
6611 if {$lastscrollrows < $numcommits} {
6612 setcanvscroll
6615 set y [expr {$canvy0 + $l * $linespc}]
6616 set ymax [lindex [$canv cget -scrollregion] 3]
6617 set ytop [expr {$y - $linespc - 1}]
6618 set ybot [expr {$y + $linespc + 1}]
6619 set wnow [$canv yview]
6620 set wtop [expr {[lindex $wnow 0] * $ymax}]
6621 set wbot [expr {[lindex $wnow 1] * $ymax}]
6622 set wh [expr {$wbot - $wtop}]
6623 set newtop $wtop
6624 if {$ytop < $wtop} {
6625 if {$ybot < $wtop} {
6626 set newtop [expr {$y - $wh / 2.0}]
6627 } else {
6628 set newtop $ytop
6629 if {$newtop > $wtop - $linespc} {
6630 set newtop [expr {$wtop - $linespc}]
6633 } elseif {$ybot > $wbot} {
6634 if {$ytop > $wbot} {
6635 set newtop [expr {$y - $wh / 2.0}]
6636 } else {
6637 set newtop [expr {$ybot - $wh}]
6638 if {$newtop < $wtop + $linespc} {
6639 set newtop [expr {$wtop + $linespc}]
6643 if {$newtop != $wtop} {
6644 if {$newtop < 0} {
6645 set newtop 0
6647 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6648 drawvisible
6651 make_secsel $id
6653 if {$isnew} {
6654 addtohistory [list selbyid $id]
6657 $sha1entry delete 0 end
6658 $sha1entry insert 0 $id
6659 if {$autoselect} {
6660 $sha1entry selection from 0
6661 $sha1entry selection to end
6663 rhighlight_sel $id
6665 $ctext conf -state normal
6666 clear_ctext
6667 set linknum 0
6668 if {![info exists commitinfo($id)]} {
6669 getcommit $id
6671 set info $commitinfo($id)
6672 set date [formatdate [lindex $info 2]]
6673 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6674 set date [formatdate [lindex $info 4]]
6675 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6676 if {[info exists idtags($id)]} {
6677 $ctext insert end [mc "Tags:"]
6678 foreach tag $idtags($id) {
6679 $ctext insert end " $tag"
6681 $ctext insert end "\n"
6684 set headers {}
6685 set olds $parents($curview,$id)
6686 if {[llength $olds] > 1} {
6687 set np 0
6688 foreach p $olds {
6689 if {$np >= $mergemax} {
6690 set tag mmax
6691 } else {
6692 set tag m$np
6694 $ctext insert end "[mc "Parent"]: " $tag
6695 appendwithlinks [commit_descriptor $p] {}
6696 incr np
6698 } else {
6699 foreach p $olds {
6700 append headers "[mc "Parent"]: [commit_descriptor $p]"
6704 foreach c $children($curview,$id) {
6705 append headers "[mc "Child"]: [commit_descriptor $c]"
6708 # make anything that looks like a SHA1 ID be a clickable link
6709 appendwithlinks $headers {}
6710 if {$showneartags} {
6711 if {![info exists allcommits]} {
6712 getallcommits
6714 $ctext insert end "[mc "Branch"]: "
6715 $ctext mark set branch "end -1c"
6716 $ctext mark gravity branch left
6717 $ctext insert end "\n[mc "Follows"]: "
6718 $ctext mark set follows "end -1c"
6719 $ctext mark gravity follows left
6720 $ctext insert end "\n[mc "Precedes"]: "
6721 $ctext mark set precedes "end -1c"
6722 $ctext mark gravity precedes left
6723 $ctext insert end "\n"
6724 dispneartags 1
6726 $ctext insert end "\n"
6727 set comment [lindex $info 5]
6728 if {[string first "\r" $comment] >= 0} {
6729 set comment [string map {"\r" "\n "} $comment]
6731 appendwithlinks $comment {comment}
6733 $ctext tag remove found 1.0 end
6734 $ctext conf -state disabled
6735 set commentend [$ctext index "end - 1c"]
6737 set jump_to_here $desired_loc
6738 init_flist [mc "Comments"]
6739 if {$cmitmode eq "tree"} {
6740 gettree $id
6741 } elseif {[llength $olds] <= 1} {
6742 startdiff $id
6743 } else {
6744 mergediff $id
6748 proc selfirstline {} {
6749 unmarkmatches
6750 selectline 0 1
6753 proc sellastline {} {
6754 global numcommits
6755 unmarkmatches
6756 set l [expr {$numcommits - 1}]
6757 selectline $l 1
6760 proc selnextline {dir} {
6761 global selectedline
6762 focus .
6763 if {$selectedline eq {}} return
6764 set l [expr {$selectedline + $dir}]
6765 unmarkmatches
6766 selectline $l 1
6769 proc selnextpage {dir} {
6770 global canv linespc selectedline numcommits
6772 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6773 if {$lpp < 1} {
6774 set lpp 1
6776 allcanvs yview scroll [expr {$dir * $lpp}] units
6777 drawvisible
6778 if {$selectedline eq {}} return
6779 set l [expr {$selectedline + $dir * $lpp}]
6780 if {$l < 0} {
6781 set l 0
6782 } elseif {$l >= $numcommits} {
6783 set l [expr $numcommits - 1]
6785 unmarkmatches
6786 selectline $l 1
6789 proc unselectline {} {
6790 global selectedline currentid
6792 set selectedline {}
6793 catch {unset currentid}
6794 allcanvs delete secsel
6795 rhighlight_none
6798 proc reselectline {} {
6799 global selectedline
6801 if {$selectedline ne {}} {
6802 selectline $selectedline 0
6806 proc addtohistory {cmd} {
6807 global history historyindex curview
6809 set elt [list $curview $cmd]
6810 if {$historyindex > 0
6811 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6812 return
6815 if {$historyindex < [llength $history]} {
6816 set history [lreplace $history $historyindex end $elt]
6817 } else {
6818 lappend history $elt
6820 incr historyindex
6821 if {$historyindex > 1} {
6822 .tf.bar.leftbut conf -state normal
6823 } else {
6824 .tf.bar.leftbut conf -state disabled
6826 .tf.bar.rightbut conf -state disabled
6829 proc godo {elt} {
6830 global curview
6832 set view [lindex $elt 0]
6833 set cmd [lindex $elt 1]
6834 if {$curview != $view} {
6835 showview $view
6837 eval $cmd
6840 proc goback {} {
6841 global history historyindex
6842 focus .
6844 if {$historyindex > 1} {
6845 incr historyindex -1
6846 godo [lindex $history [expr {$historyindex - 1}]]
6847 .tf.bar.rightbut conf -state normal
6849 if {$historyindex <= 1} {
6850 .tf.bar.leftbut conf -state disabled
6854 proc goforw {} {
6855 global history historyindex
6856 focus .
6858 if {$historyindex < [llength $history]} {
6859 set cmd [lindex $history $historyindex]
6860 incr historyindex
6861 godo $cmd
6862 .tf.bar.leftbut conf -state normal
6864 if {$historyindex >= [llength $history]} {
6865 .tf.bar.rightbut conf -state disabled
6869 proc gettree {id} {
6870 global treefilelist treeidlist diffids diffmergeid treepending
6871 global nullid nullid2
6873 set diffids $id
6874 catch {unset diffmergeid}
6875 if {![info exists treefilelist($id)]} {
6876 if {![info exists treepending]} {
6877 if {$id eq $nullid} {
6878 set cmd [list | git ls-files]
6879 } elseif {$id eq $nullid2} {
6880 set cmd [list | git ls-files --stage -t]
6881 } else {
6882 set cmd [list | git ls-tree -r $id]
6884 if {[catch {set gtf [open $cmd r]}]} {
6885 return
6887 set treepending $id
6888 set treefilelist($id) {}
6889 set treeidlist($id) {}
6890 fconfigure $gtf -blocking 0 -encoding binary
6891 filerun $gtf [list gettreeline $gtf $id]
6893 } else {
6894 setfilelist $id
6898 proc gettreeline {gtf id} {
6899 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6901 set nl 0
6902 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6903 if {$diffids eq $nullid} {
6904 set fname $line
6905 } else {
6906 set i [string first "\t" $line]
6907 if {$i < 0} continue
6908 set fname [string range $line [expr {$i+1}] end]
6909 set line [string range $line 0 [expr {$i-1}]]
6910 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6911 set sha1 [lindex $line 2]
6912 lappend treeidlist($id) $sha1
6914 if {[string index $fname 0] eq "\""} {
6915 set fname [lindex $fname 0]
6917 set fname [encoding convertfrom $fname]
6918 lappend treefilelist($id) $fname
6920 if {![eof $gtf]} {
6921 return [expr {$nl >= 1000? 2: 1}]
6923 close $gtf
6924 unset treepending
6925 if {$cmitmode ne "tree"} {
6926 if {![info exists diffmergeid]} {
6927 gettreediffs $diffids
6929 } elseif {$id ne $diffids} {
6930 gettree $diffids
6931 } else {
6932 setfilelist $id
6934 return 0
6937 proc showfile {f} {
6938 global treefilelist treeidlist diffids nullid nullid2
6939 global ctext_file_names ctext_file_lines
6940 global ctext commentend
6942 set i [lsearch -exact $treefilelist($diffids) $f]
6943 if {$i < 0} {
6944 puts "oops, $f not in list for id $diffids"
6945 return
6947 if {$diffids eq $nullid} {
6948 if {[catch {set bf [open $f r]} err]} {
6949 puts "oops, can't read $f: $err"
6950 return
6952 } else {
6953 set blob [lindex $treeidlist($diffids) $i]
6954 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6955 puts "oops, error reading blob $blob: $err"
6956 return
6959 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6960 filerun $bf [list getblobline $bf $diffids]
6961 $ctext config -state normal
6962 clear_ctext $commentend
6963 lappend ctext_file_names $f
6964 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6965 $ctext insert end "\n"
6966 $ctext insert end "$f\n" filesep
6967 $ctext config -state disabled
6968 $ctext yview $commentend
6969 settabs 0
6972 proc getblobline {bf id} {
6973 global diffids cmitmode ctext
6975 if {$id ne $diffids || $cmitmode ne "tree"} {
6976 catch {close $bf}
6977 return 0
6979 $ctext config -state normal
6980 set nl 0
6981 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6982 $ctext insert end "$line\n"
6984 if {[eof $bf]} {
6985 global jump_to_here ctext_file_names commentend
6987 # delete last newline
6988 $ctext delete "end - 2c" "end - 1c"
6989 close $bf
6990 if {$jump_to_here ne {} &&
6991 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6992 set lnum [expr {[lindex $jump_to_here 1] +
6993 [lindex [split $commentend .] 0]}]
6994 mark_ctext_line $lnum
6996 return 0
6998 $ctext config -state disabled
6999 return [expr {$nl >= 1000? 2: 1}]
7002 proc mark_ctext_line {lnum} {
7003 global ctext markbgcolor
7005 $ctext tag delete omark
7006 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7007 $ctext tag conf omark -background $markbgcolor
7008 $ctext see $lnum.0
7011 proc mergediff {id} {
7012 global diffmergeid
7013 global diffids treediffs
7014 global parents curview
7016 set diffmergeid $id
7017 set diffids $id
7018 set treediffs($id) {}
7019 set np [llength $parents($curview,$id)]
7020 settabs $np
7021 getblobdiffs $id
7024 proc startdiff {ids} {
7025 global treediffs diffids treepending diffmergeid nullid nullid2
7027 settabs 1
7028 set diffids $ids
7029 catch {unset diffmergeid}
7030 if {![info exists treediffs($ids)] ||
7031 [lsearch -exact $ids $nullid] >= 0 ||
7032 [lsearch -exact $ids $nullid2] >= 0} {
7033 if {![info exists treepending]} {
7034 gettreediffs $ids
7036 } else {
7037 addtocflist $ids
7041 proc path_filter {filter name} {
7042 foreach p $filter {
7043 set l [string length $p]
7044 if {[string index $p end] eq "/"} {
7045 if {[string compare -length $l $p $name] == 0} {
7046 return 1
7048 } else {
7049 if {[string compare -length $l $p $name] == 0 &&
7050 ([string length $name] == $l ||
7051 [string index $name $l] eq "/")} {
7052 return 1
7056 return 0
7059 proc addtocflist {ids} {
7060 global treediffs
7062 add_flist $treediffs($ids)
7063 getblobdiffs $ids
7066 proc diffcmd {ids flags} {
7067 global nullid nullid2
7069 set i [lsearch -exact $ids $nullid]
7070 set j [lsearch -exact $ids $nullid2]
7071 if {$i >= 0} {
7072 if {[llength $ids] > 1 && $j < 0} {
7073 # comparing working directory with some specific revision
7074 set cmd [concat | git diff-index $flags]
7075 if {$i == 0} {
7076 lappend cmd -R [lindex $ids 1]
7077 } else {
7078 lappend cmd [lindex $ids 0]
7080 } else {
7081 # comparing working directory with index
7082 set cmd [concat | git diff-files $flags]
7083 if {$j == 1} {
7084 lappend cmd -R
7087 } elseif {$j >= 0} {
7088 set cmd [concat | git diff-index --cached $flags]
7089 if {[llength $ids] > 1} {
7090 # comparing index with specific revision
7091 if {$i == 0} {
7092 lappend cmd -R [lindex $ids 1]
7093 } else {
7094 lappend cmd [lindex $ids 0]
7096 } else {
7097 # comparing index with HEAD
7098 lappend cmd HEAD
7100 } else {
7101 set cmd [concat | git diff-tree -r $flags $ids]
7103 return $cmd
7106 proc gettreediffs {ids} {
7107 global treediff treepending
7109 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7111 set treepending $ids
7112 set treediff {}
7113 fconfigure $gdtf -blocking 0 -encoding binary
7114 filerun $gdtf [list gettreediffline $gdtf $ids]
7117 proc gettreediffline {gdtf ids} {
7118 global treediff treediffs treepending diffids diffmergeid
7119 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7121 set nr 0
7122 set sublist {}
7123 set max 1000
7124 if {$perfile_attrs} {
7125 # cache_gitattr is slow, and even slower on win32 where we
7126 # have to invoke it for only about 30 paths at a time
7127 set max 500
7128 if {[tk windowingsystem] == "win32"} {
7129 set max 120
7132 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7133 set i [string first "\t" $line]
7134 if {$i >= 0} {
7135 set file [string range $line [expr {$i+1}] end]
7136 if {[string index $file 0] eq "\""} {
7137 set file [lindex $file 0]
7139 set file [encoding convertfrom $file]
7140 if {$file ne [lindex $treediff end]} {
7141 lappend treediff $file
7142 lappend sublist $file
7146 if {$perfile_attrs} {
7147 cache_gitattr encoding $sublist
7149 if {![eof $gdtf]} {
7150 return [expr {$nr >= $max? 2: 1}]
7152 close $gdtf
7153 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7154 set flist {}
7155 foreach f $treediff {
7156 if {[path_filter $vfilelimit($curview) $f]} {
7157 lappend flist $f
7160 set treediffs($ids) $flist
7161 } else {
7162 set treediffs($ids) $treediff
7164 unset treepending
7165 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7166 gettree $diffids
7167 } elseif {$ids != $diffids} {
7168 if {![info exists diffmergeid]} {
7169 gettreediffs $diffids
7171 } else {
7172 addtocflist $ids
7174 return 0
7177 # empty string or positive integer
7178 proc diffcontextvalidate {v} {
7179 return [regexp {^(|[1-9][0-9]*)$} $v]
7182 proc diffcontextchange {n1 n2 op} {
7183 global diffcontextstring diffcontext
7185 if {[string is integer -strict $diffcontextstring]} {
7186 if {$diffcontextstring > 0} {
7187 set diffcontext $diffcontextstring
7188 reselectline
7193 proc changeignorespace {} {
7194 reselectline
7197 proc getblobdiffs {ids} {
7198 global blobdifffd diffids env
7199 global diffinhdr treediffs
7200 global diffcontext
7201 global ignorespace
7202 global limitdiffs vfilelimit curview
7203 global diffencoding targetline diffnparents
7205 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7206 if {$ignorespace} {
7207 append cmd " -w"
7209 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7210 set cmd [concat $cmd -- $vfilelimit($curview)]
7212 if {[catch {set bdf [open $cmd r]} err]} {
7213 error_popup [mc "Error getting diffs: %s" $err]
7214 return
7216 set targetline {}
7217 set diffnparents 0
7218 set diffinhdr 0
7219 set diffencoding [get_path_encoding {}]
7220 fconfigure $bdf -blocking 0 -encoding binary
7221 set blobdifffd($ids) $bdf
7222 filerun $bdf [list getblobdiffline $bdf $diffids]
7225 proc setinlist {var i val} {
7226 global $var
7228 while {[llength [set $var]] < $i} {
7229 lappend $var {}
7231 if {[llength [set $var]] == $i} {
7232 lappend $var $val
7233 } else {
7234 lset $var $i $val
7238 proc makediffhdr {fname ids} {
7239 global ctext curdiffstart treediffs diffencoding
7240 global ctext_file_names jump_to_here targetline diffline
7242 set fname [encoding convertfrom $fname]
7243 set diffencoding [get_path_encoding $fname]
7244 set i [lsearch -exact $treediffs($ids) $fname]
7245 if {$i >= 0} {
7246 setinlist difffilestart $i $curdiffstart
7248 lset ctext_file_names end $fname
7249 set l [expr {(78 - [string length $fname]) / 2}]
7250 set pad [string range "----------------------------------------" 1 $l]
7251 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7252 set targetline {}
7253 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7254 set targetline [lindex $jump_to_here 1]
7256 set diffline 0
7259 proc getblobdiffline {bdf ids} {
7260 global diffids blobdifffd ctext curdiffstart
7261 global diffnexthead diffnextnote difffilestart
7262 global ctext_file_names ctext_file_lines
7263 global diffinhdr treediffs mergemax diffnparents
7264 global diffencoding jump_to_here targetline diffline
7266 set nr 0
7267 $ctext conf -state normal
7268 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7269 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7270 close $bdf
7271 return 0
7273 if {![string compare -length 5 "diff " $line]} {
7274 if {![regexp {^diff (--cc|--git) } $line m type]} {
7275 set line [encoding convertfrom $line]
7276 $ctext insert end "$line\n" hunksep
7277 continue
7279 # start of a new file
7280 set diffinhdr 1
7281 $ctext insert end "\n"
7282 set curdiffstart [$ctext index "end - 1c"]
7283 lappend ctext_file_names ""
7284 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7285 $ctext insert end "\n" filesep
7287 if {$type eq "--cc"} {
7288 # start of a new file in a merge diff
7289 set fname [string range $line 10 end]
7290 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7291 lappend treediffs($ids) $fname
7292 add_flist [list $fname]
7295 } else {
7296 set line [string range $line 11 end]
7297 # If the name hasn't changed the length will be odd,
7298 # the middle char will be a space, and the two bits either
7299 # side will be a/name and b/name, or "a/name" and "b/name".
7300 # If the name has changed we'll get "rename from" and
7301 # "rename to" or "copy from" and "copy to" lines following
7302 # this, and we'll use them to get the filenames.
7303 # This complexity is necessary because spaces in the
7304 # filename(s) don't get escaped.
7305 set l [string length $line]
7306 set i [expr {$l / 2}]
7307 if {!(($l & 1) && [string index $line $i] eq " " &&
7308 [string range $line 2 [expr {$i - 1}]] eq \
7309 [string range $line [expr {$i + 3}] end])} {
7310 continue
7312 # unescape if quoted and chop off the a/ from the front
7313 if {[string index $line 0] eq "\""} {
7314 set fname [string range [lindex $line 0] 2 end]
7315 } else {
7316 set fname [string range $line 2 [expr {$i - 1}]]
7319 makediffhdr $fname $ids
7321 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7322 set fname [encoding convertfrom [string range $line 16 end]]
7323 $ctext insert end "\n"
7324 set curdiffstart [$ctext index "end - 1c"]
7325 lappend ctext_file_names $fname
7326 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7327 $ctext insert end "$line\n" filesep
7328 set i [lsearch -exact $treediffs($ids) $fname]
7329 if {$i >= 0} {
7330 setinlist difffilestart $i $curdiffstart
7333 } elseif {![string compare -length 2 "@@" $line]} {
7334 regexp {^@@+} $line ats
7335 set line [encoding convertfrom $diffencoding $line]
7336 $ctext insert end "$line\n" hunksep
7337 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7338 set diffline $nl
7340 set diffnparents [expr {[string length $ats] - 1}]
7341 set diffinhdr 0
7343 } elseif {$diffinhdr} {
7344 if {![string compare -length 12 "rename from " $line]} {
7345 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7346 if {[string index $fname 0] eq "\""} {
7347 set fname [lindex $fname 0]
7349 set fname [encoding convertfrom $fname]
7350 set i [lsearch -exact $treediffs($ids) $fname]
7351 if {$i >= 0} {
7352 setinlist difffilestart $i $curdiffstart
7354 } elseif {![string compare -length 10 $line "rename to "] ||
7355 ![string compare -length 8 $line "copy to "]} {
7356 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7357 if {[string index $fname 0] eq "\""} {
7358 set fname [lindex $fname 0]
7360 makediffhdr $fname $ids
7361 } elseif {[string compare -length 3 $line "---"] == 0} {
7362 # do nothing
7363 continue
7364 } elseif {[string compare -length 3 $line "+++"] == 0} {
7365 set diffinhdr 0
7366 continue
7368 $ctext insert end "$line\n" filesep
7370 } else {
7371 set line [encoding convertfrom $diffencoding $line]
7372 # parse the prefix - one ' ', '-' or '+' for each parent
7373 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7374 set tag [expr {$diffnparents > 1? "m": "d"}]
7375 if {[string trim $prefix " -+"] eq {}} {
7376 # prefix only has " ", "-" and "+" in it: normal diff line
7377 set num [string first "-" $prefix]
7378 if {$num >= 0} {
7379 # removed line, first parent with line is $num
7380 if {$num >= $mergemax} {
7381 set num "max"
7383 $ctext insert end "$line\n" $tag$num
7384 } else {
7385 set tags {}
7386 if {[string first "+" $prefix] >= 0} {
7387 # added line
7388 lappend tags ${tag}result
7389 if {$diffnparents > 1} {
7390 set num [string first " " $prefix]
7391 if {$num >= 0} {
7392 if {$num >= $mergemax} {
7393 set num "max"
7395 lappend tags m$num
7399 if {$targetline ne {}} {
7400 if {$diffline == $targetline} {
7401 set seehere [$ctext index "end - 1 chars"]
7402 set targetline {}
7403 } else {
7404 incr diffline
7407 $ctext insert end "$line\n" $tags
7409 } else {
7410 # "\ No newline at end of file",
7411 # or something else we don't recognize
7412 $ctext insert end "$line\n" hunksep
7416 if {[info exists seehere]} {
7417 mark_ctext_line [lindex [split $seehere .] 0]
7419 $ctext conf -state disabled
7420 if {[eof $bdf]} {
7421 close $bdf
7422 return 0
7424 return [expr {$nr >= 1000? 2: 1}]
7427 proc changediffdisp {} {
7428 global ctext diffelide
7430 $ctext tag conf d0 -elide [lindex $diffelide 0]
7431 $ctext tag conf dresult -elide [lindex $diffelide 1]
7434 proc highlightfile {loc cline} {
7435 global ctext cflist cflist_top
7437 $ctext yview $loc
7438 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7439 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7440 $cflist see $cline.0
7441 set cflist_top $cline
7444 proc prevfile {} {
7445 global difffilestart ctext cmitmode
7447 if {$cmitmode eq "tree"} return
7448 set prev 0.0
7449 set prevline 1
7450 set here [$ctext index @0,0]
7451 foreach loc $difffilestart {
7452 if {[$ctext compare $loc >= $here]} {
7453 highlightfile $prev $prevline
7454 return
7456 set prev $loc
7457 incr prevline
7459 highlightfile $prev $prevline
7462 proc nextfile {} {
7463 global difffilestart ctext cmitmode
7465 if {$cmitmode eq "tree"} return
7466 set here [$ctext index @0,0]
7467 set line 1
7468 foreach loc $difffilestart {
7469 incr line
7470 if {[$ctext compare $loc > $here]} {
7471 highlightfile $loc $line
7472 return
7477 proc clear_ctext {{first 1.0}} {
7478 global ctext smarktop smarkbot
7479 global ctext_file_names ctext_file_lines
7480 global pendinglinks
7482 set l [lindex [split $first .] 0]
7483 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7484 set smarktop $l
7486 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7487 set smarkbot $l
7489 $ctext delete $first end
7490 if {$first eq "1.0"} {
7491 catch {unset pendinglinks}
7493 set ctext_file_names {}
7494 set ctext_file_lines {}
7497 proc settabs {{firstab {}}} {
7498 global firsttabstop tabstop ctext have_tk85
7500 if {$firstab ne {} && $have_tk85} {
7501 set firsttabstop $firstab
7503 set w [font measure textfont "0"]
7504 if {$firsttabstop != 0} {
7505 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7506 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7507 } elseif {$have_tk85 || $tabstop != 8} {
7508 $ctext conf -tabs [expr {$tabstop * $w}]
7509 } else {
7510 $ctext conf -tabs {}
7514 proc incrsearch {name ix op} {
7515 global ctext searchstring searchdirn
7517 $ctext tag remove found 1.0 end
7518 if {[catch {$ctext index anchor}]} {
7519 # no anchor set, use start of selection, or of visible area
7520 set sel [$ctext tag ranges sel]
7521 if {$sel ne {}} {
7522 $ctext mark set anchor [lindex $sel 0]
7523 } elseif {$searchdirn eq "-forwards"} {
7524 $ctext mark set anchor @0,0
7525 } else {
7526 $ctext mark set anchor @0,[winfo height $ctext]
7529 if {$searchstring ne {}} {
7530 set here [$ctext search $searchdirn -- $searchstring anchor]
7531 if {$here ne {}} {
7532 $ctext see $here
7534 searchmarkvisible 1
7538 proc dosearch {} {
7539 global sstring ctext searchstring searchdirn
7541 focus $sstring
7542 $sstring icursor end
7543 set searchdirn -forwards
7544 if {$searchstring ne {}} {
7545 set sel [$ctext tag ranges sel]
7546 if {$sel ne {}} {
7547 set start "[lindex $sel 0] + 1c"
7548 } elseif {[catch {set start [$ctext index anchor]}]} {
7549 set start "@0,0"
7551 set match [$ctext search -count mlen -- $searchstring $start]
7552 $ctext tag remove sel 1.0 end
7553 if {$match eq {}} {
7554 bell
7555 return
7557 $ctext see $match
7558 set mend "$match + $mlen c"
7559 $ctext tag add sel $match $mend
7560 $ctext mark unset anchor
7564 proc dosearchback {} {
7565 global sstring ctext searchstring searchdirn
7567 focus $sstring
7568 $sstring icursor end
7569 set searchdirn -backwards
7570 if {$searchstring ne {}} {
7571 set sel [$ctext tag ranges sel]
7572 if {$sel ne {}} {
7573 set start [lindex $sel 0]
7574 } elseif {[catch {set start [$ctext index anchor]}]} {
7575 set start @0,[winfo height $ctext]
7577 set match [$ctext search -backwards -count ml -- $searchstring $start]
7578 $ctext tag remove sel 1.0 end
7579 if {$match eq {}} {
7580 bell
7581 return
7583 $ctext see $match
7584 set mend "$match + $ml c"
7585 $ctext tag add sel $match $mend
7586 $ctext mark unset anchor
7590 proc searchmark {first last} {
7591 global ctext searchstring
7593 set mend $first.0
7594 while {1} {
7595 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7596 if {$match eq {}} break
7597 set mend "$match + $mlen c"
7598 $ctext tag add found $match $mend
7602 proc searchmarkvisible {doall} {
7603 global ctext smarktop smarkbot
7605 set topline [lindex [split [$ctext index @0,0] .] 0]
7606 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7607 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7608 # no overlap with previous
7609 searchmark $topline $botline
7610 set smarktop $topline
7611 set smarkbot $botline
7612 } else {
7613 if {$topline < $smarktop} {
7614 searchmark $topline [expr {$smarktop-1}]
7615 set smarktop $topline
7617 if {$botline > $smarkbot} {
7618 searchmark [expr {$smarkbot+1}] $botline
7619 set smarkbot $botline
7624 proc scrolltext {f0 f1} {
7625 global searchstring
7627 .bleft.bottom.sb set $f0 $f1
7628 if {$searchstring ne {}} {
7629 searchmarkvisible 0
7633 proc setcoords {} {
7634 global linespc charspc canvx0 canvy0
7635 global xspc1 xspc2 lthickness
7637 set linespc [font metrics mainfont -linespace]
7638 set charspc [font measure mainfont "m"]
7639 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7640 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7641 set lthickness [expr {int($linespc / 9) + 1}]
7642 set xspc1(0) $linespc
7643 set xspc2 $linespc
7646 proc redisplay {} {
7647 global canv
7648 global selectedline
7650 set ymax [lindex [$canv cget -scrollregion] 3]
7651 if {$ymax eq {} || $ymax == 0} return
7652 set span [$canv yview]
7653 clear_display
7654 setcanvscroll
7655 allcanvs yview moveto [lindex $span 0]
7656 drawvisible
7657 if {$selectedline ne {}} {
7658 selectline $selectedline 0
7659 allcanvs yview moveto [lindex $span 0]
7663 proc parsefont {f n} {
7664 global fontattr
7666 set fontattr($f,family) [lindex $n 0]
7667 set s [lindex $n 1]
7668 if {$s eq {} || $s == 0} {
7669 set s 10
7670 } elseif {$s < 0} {
7671 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7673 set fontattr($f,size) $s
7674 set fontattr($f,weight) normal
7675 set fontattr($f,slant) roman
7676 foreach style [lrange $n 2 end] {
7677 switch -- $style {
7678 "normal" -
7679 "bold" {set fontattr($f,weight) $style}
7680 "roman" -
7681 "italic" {set fontattr($f,slant) $style}
7686 proc fontflags {f {isbold 0}} {
7687 global fontattr
7689 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7690 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7691 -slant $fontattr($f,slant)]
7694 proc fontname {f} {
7695 global fontattr
7697 set n [list $fontattr($f,family) $fontattr($f,size)]
7698 if {$fontattr($f,weight) eq "bold"} {
7699 lappend n "bold"
7701 if {$fontattr($f,slant) eq "italic"} {
7702 lappend n "italic"
7704 return $n
7707 proc incrfont {inc} {
7708 global mainfont textfont ctext canv cflist showrefstop
7709 global stopped entries fontattr
7711 unmarkmatches
7712 set s $fontattr(mainfont,size)
7713 incr s $inc
7714 if {$s < 1} {
7715 set s 1
7717 set fontattr(mainfont,size) $s
7718 font config mainfont -size $s
7719 font config mainfontbold -size $s
7720 set mainfont [fontname mainfont]
7721 set s $fontattr(textfont,size)
7722 incr s $inc
7723 if {$s < 1} {
7724 set s 1
7726 set fontattr(textfont,size) $s
7727 font config textfont -size $s
7728 font config textfontbold -size $s
7729 set textfont [fontname textfont]
7730 setcoords
7731 settabs
7732 redisplay
7735 proc clearsha1 {} {
7736 global sha1entry sha1string
7737 if {[string length $sha1string] == 40} {
7738 $sha1entry delete 0 end
7742 proc sha1change {n1 n2 op} {
7743 global sha1string currentid sha1but
7744 if {$sha1string == {}
7745 || ([info exists currentid] && $sha1string == $currentid)} {
7746 set state disabled
7747 } else {
7748 set state normal
7750 if {[$sha1but cget -state] == $state} return
7751 if {$state == "normal"} {
7752 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7753 } else {
7754 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7758 proc gotocommit {} {
7759 global sha1string tagids headids curview varcid
7761 if {$sha1string == {}
7762 || ([info exists currentid] && $sha1string == $currentid)} return
7763 if {[info exists tagids($sha1string)]} {
7764 set id $tagids($sha1string)
7765 } elseif {[info exists headids($sha1string)]} {
7766 set id $headids($sha1string)
7767 } else {
7768 set id [string tolower $sha1string]
7769 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7770 set matches [longid $id]
7771 if {$matches ne {}} {
7772 if {[llength $matches] > 1} {
7773 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7774 return
7776 set id [lindex $matches 0]
7780 if {[commitinview $id $curview]} {
7781 selectline [rowofcommit $id] 1
7782 return
7784 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7785 set msg [mc "SHA1 id %s is not known" $sha1string]
7786 } else {
7787 set msg [mc "Tag/Head %s is not known" $sha1string]
7789 error_popup $msg
7792 proc lineenter {x y id} {
7793 global hoverx hovery hoverid hovertimer
7794 global commitinfo canv
7796 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7797 set hoverx $x
7798 set hovery $y
7799 set hoverid $id
7800 if {[info exists hovertimer]} {
7801 after cancel $hovertimer
7803 set hovertimer [after 500 linehover]
7804 $canv delete hover
7807 proc linemotion {x y id} {
7808 global hoverx hovery hoverid hovertimer
7810 if {[info exists hoverid] && $id == $hoverid} {
7811 set hoverx $x
7812 set hovery $y
7813 if {[info exists hovertimer]} {
7814 after cancel $hovertimer
7816 set hovertimer [after 500 linehover]
7820 proc lineleave {id} {
7821 global hoverid hovertimer canv
7823 if {[info exists hoverid] && $id == $hoverid} {
7824 $canv delete hover
7825 if {[info exists hovertimer]} {
7826 after cancel $hovertimer
7827 unset hovertimer
7829 unset hoverid
7833 proc linehover {} {
7834 global hoverx hovery hoverid hovertimer
7835 global canv linespc lthickness
7836 global commitinfo
7838 set text [lindex $commitinfo($hoverid) 0]
7839 set ymax [lindex [$canv cget -scrollregion] 3]
7840 if {$ymax == {}} return
7841 set yfrac [lindex [$canv yview] 0]
7842 set x [expr {$hoverx + 2 * $linespc}]
7843 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7844 set x0 [expr {$x - 2 * $lthickness}]
7845 set y0 [expr {$y - 2 * $lthickness}]
7846 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7847 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7848 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7849 -fill \#ffff80 -outline black -width 1 -tags hover]
7850 $canv raise $t
7851 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7852 -font mainfont]
7853 $canv raise $t
7856 proc clickisonarrow {id y} {
7857 global lthickness
7859 set ranges [rowranges $id]
7860 set thresh [expr {2 * $lthickness + 6}]
7861 set n [expr {[llength $ranges] - 1}]
7862 for {set i 1} {$i < $n} {incr i} {
7863 set row [lindex $ranges $i]
7864 if {abs([yc $row] - $y) < $thresh} {
7865 return $i
7868 return {}
7871 proc arrowjump {id n y} {
7872 global canv
7874 # 1 <-> 2, 3 <-> 4, etc...
7875 set n [expr {(($n - 1) ^ 1) + 1}]
7876 set row [lindex [rowranges $id] $n]
7877 set yt [yc $row]
7878 set ymax [lindex [$canv cget -scrollregion] 3]
7879 if {$ymax eq {} || $ymax <= 0} return
7880 set view [$canv yview]
7881 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7882 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7883 if {$yfrac < 0} {
7884 set yfrac 0
7886 allcanvs yview moveto $yfrac
7889 proc lineclick {x y id isnew} {
7890 global ctext commitinfo children canv thickerline curview
7892 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7893 unmarkmatches
7894 unselectline
7895 normalline
7896 $canv delete hover
7897 # draw this line thicker than normal
7898 set thickerline $id
7899 drawlines $id
7900 if {$isnew} {
7901 set ymax [lindex [$canv cget -scrollregion] 3]
7902 if {$ymax eq {}} return
7903 set yfrac [lindex [$canv yview] 0]
7904 set y [expr {$y + $yfrac * $ymax}]
7906 set dirn [clickisonarrow $id $y]
7907 if {$dirn ne {}} {
7908 arrowjump $id $dirn $y
7909 return
7912 if {$isnew} {
7913 addtohistory [list lineclick $x $y $id 0]
7915 # fill the details pane with info about this line
7916 $ctext conf -state normal
7917 clear_ctext
7918 settabs 0
7919 $ctext insert end "[mc "Parent"]:\t"
7920 $ctext insert end $id link0
7921 setlink $id link0
7922 set info $commitinfo($id)
7923 $ctext insert end "\n\t[lindex $info 0]\n"
7924 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7925 set date [formatdate [lindex $info 2]]
7926 $ctext insert end "\t[mc "Date"]:\t$date\n"
7927 set kids $children($curview,$id)
7928 if {$kids ne {}} {
7929 $ctext insert end "\n[mc "Children"]:"
7930 set i 0
7931 foreach child $kids {
7932 incr i
7933 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7934 set info $commitinfo($child)
7935 $ctext insert end "\n\t"
7936 $ctext insert end $child link$i
7937 setlink $child link$i
7938 $ctext insert end "\n\t[lindex $info 0]"
7939 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7940 set date [formatdate [lindex $info 2]]
7941 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7944 $ctext conf -state disabled
7945 init_flist {}
7948 proc normalline {} {
7949 global thickerline
7950 if {[info exists thickerline]} {
7951 set id $thickerline
7952 unset thickerline
7953 drawlines $id
7957 proc selbyid {id} {
7958 global curview
7959 if {[commitinview $id $curview]} {
7960 selectline [rowofcommit $id] 1
7964 proc mstime {} {
7965 global startmstime
7966 if {![info exists startmstime]} {
7967 set startmstime [clock clicks -milliseconds]
7969 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7972 proc rowmenu {x y id} {
7973 global rowctxmenu selectedline rowmenuid curview
7974 global nullid nullid2 fakerowmenu mainhead
7976 stopfinding
7977 set rowmenuid $id
7978 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7979 set state disabled
7980 } else {
7981 set state normal
7983 if {$id ne $nullid && $id ne $nullid2} {
7984 set menu $rowctxmenu
7985 if {$mainhead ne {}} {
7986 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
7987 } else {
7988 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7990 } else {
7991 set menu $fakerowmenu
7993 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7994 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7995 $menu entryconfigure [mca "Make patch"] -state $state
7996 tk_popup $menu $x $y
7999 proc diffvssel {dirn} {
8000 global rowmenuid selectedline
8002 if {$selectedline eq {}} return
8003 if {$dirn} {
8004 set oldid [commitonrow $selectedline]
8005 set newid $rowmenuid
8006 } else {
8007 set oldid $rowmenuid
8008 set newid [commitonrow $selectedline]
8010 addtohistory [list doseldiff $oldid $newid]
8011 doseldiff $oldid $newid
8014 proc doseldiff {oldid newid} {
8015 global ctext
8016 global commitinfo
8018 $ctext conf -state normal
8019 clear_ctext
8020 init_flist [mc "Top"]
8021 $ctext insert end "[mc "From"] "
8022 $ctext insert end $oldid link0
8023 setlink $oldid link0
8024 $ctext insert end "\n "
8025 $ctext insert end [lindex $commitinfo($oldid) 0]
8026 $ctext insert end "\n\n[mc "To"] "
8027 $ctext insert end $newid link1
8028 setlink $newid link1
8029 $ctext insert end "\n "
8030 $ctext insert end [lindex $commitinfo($newid) 0]
8031 $ctext insert end "\n"
8032 $ctext conf -state disabled
8033 $ctext tag remove found 1.0 end
8034 startdiff [list $oldid $newid]
8037 proc mkpatch {} {
8038 global rowmenuid currentid commitinfo patchtop patchnum
8040 if {![info exists currentid]} return
8041 set oldid $currentid
8042 set oldhead [lindex $commitinfo($oldid) 0]
8043 set newid $rowmenuid
8044 set newhead [lindex $commitinfo($newid) 0]
8045 set top .patch
8046 set patchtop $top
8047 catch {destroy $top}
8048 toplevel $top
8049 make_transient $top .
8050 label $top.title -text [mc "Generate patch"]
8051 grid $top.title - -pady 10
8052 label $top.from -text [mc "From:"]
8053 entry $top.fromsha1 -width 40 -relief flat
8054 $top.fromsha1 insert 0 $oldid
8055 $top.fromsha1 conf -state readonly
8056 grid $top.from $top.fromsha1 -sticky w
8057 entry $top.fromhead -width 60 -relief flat
8058 $top.fromhead insert 0 $oldhead
8059 $top.fromhead conf -state readonly
8060 grid x $top.fromhead -sticky w
8061 label $top.to -text [mc "To:"]
8062 entry $top.tosha1 -width 40 -relief flat
8063 $top.tosha1 insert 0 $newid
8064 $top.tosha1 conf -state readonly
8065 grid $top.to $top.tosha1 -sticky w
8066 entry $top.tohead -width 60 -relief flat
8067 $top.tohead insert 0 $newhead
8068 $top.tohead conf -state readonly
8069 grid x $top.tohead -sticky w
8070 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8071 grid $top.rev x -pady 10
8072 label $top.flab -text [mc "Output file:"]
8073 entry $top.fname -width 60
8074 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8075 incr patchnum
8076 grid $top.flab $top.fname -sticky w
8077 frame $top.buts
8078 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8079 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8080 bind $top <Key-Return> mkpatchgo
8081 bind $top <Key-Escape> mkpatchcan
8082 grid $top.buts.gen $top.buts.can
8083 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8084 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8085 grid $top.buts - -pady 10 -sticky ew
8086 focus $top.fname
8089 proc mkpatchrev {} {
8090 global patchtop
8092 set oldid [$patchtop.fromsha1 get]
8093 set oldhead [$patchtop.fromhead get]
8094 set newid [$patchtop.tosha1 get]
8095 set newhead [$patchtop.tohead get]
8096 foreach e [list fromsha1 fromhead tosha1 tohead] \
8097 v [list $newid $newhead $oldid $oldhead] {
8098 $patchtop.$e conf -state normal
8099 $patchtop.$e delete 0 end
8100 $patchtop.$e insert 0 $v
8101 $patchtop.$e conf -state readonly
8105 proc mkpatchgo {} {
8106 global patchtop nullid nullid2
8108 set oldid [$patchtop.fromsha1 get]
8109 set newid [$patchtop.tosha1 get]
8110 set fname [$patchtop.fname get]
8111 set cmd [diffcmd [list $oldid $newid] -p]
8112 # trim off the initial "|"
8113 set cmd [lrange $cmd 1 end]
8114 lappend cmd >$fname &
8115 if {[catch {eval exec $cmd} err]} {
8116 error_popup "[mc "Error creating patch:"] $err" $patchtop
8118 catch {destroy $patchtop}
8119 unset patchtop
8122 proc mkpatchcan {} {
8123 global patchtop
8125 catch {destroy $patchtop}
8126 unset patchtop
8129 proc mktag {} {
8130 global rowmenuid mktagtop commitinfo
8132 set top .maketag
8133 set mktagtop $top
8134 catch {destroy $top}
8135 toplevel $top
8136 make_transient $top .
8137 label $top.title -text [mc "Create tag"]
8138 grid $top.title - -pady 10
8139 label $top.id -text [mc "ID:"]
8140 entry $top.sha1 -width 40 -relief flat
8141 $top.sha1 insert 0 $rowmenuid
8142 $top.sha1 conf -state readonly
8143 grid $top.id $top.sha1 -sticky w
8144 entry $top.head -width 60 -relief flat
8145 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8146 $top.head conf -state readonly
8147 grid x $top.head -sticky w
8148 label $top.tlab -text [mc "Tag name:"]
8149 entry $top.tag -width 60
8150 grid $top.tlab $top.tag -sticky w
8151 frame $top.buts
8152 button $top.buts.gen -text [mc "Create"] -command mktaggo
8153 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8154 bind $top <Key-Return> mktaggo
8155 bind $top <Key-Escape> mktagcan
8156 grid $top.buts.gen $top.buts.can
8157 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8158 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8159 grid $top.buts - -pady 10 -sticky ew
8160 focus $top.tag
8163 proc domktag {} {
8164 global mktagtop env tagids idtags
8166 set id [$mktagtop.sha1 get]
8167 set tag [$mktagtop.tag get]
8168 if {$tag == {}} {
8169 error_popup [mc "No tag name specified"] $mktagtop
8170 return 0
8172 if {[info exists tagids($tag)]} {
8173 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8174 return 0
8176 if {[catch {
8177 exec git tag $tag $id
8178 } err]} {
8179 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8180 return 0
8183 set tagids($tag) $id
8184 lappend idtags($id) $tag
8185 redrawtags $id
8186 addedtag $id
8187 dispneartags 0
8188 run refill_reflist
8189 return 1
8192 proc redrawtags {id} {
8193 global canv linehtag idpos currentid curview cmitlisted
8194 global canvxmax iddrawn circleitem mainheadid circlecolors
8196 if {![commitinview $id $curview]} return
8197 if {![info exists iddrawn($id)]} return
8198 set row [rowofcommit $id]
8199 if {$id eq $mainheadid} {
8200 set ofill yellow
8201 } else {
8202 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8204 $canv itemconf $circleitem($row) -fill $ofill
8205 $canv delete tag.$id
8206 set xt [eval drawtags $id $idpos($id)]
8207 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8208 set text [$canv itemcget $linehtag($id) -text]
8209 set font [$canv itemcget $linehtag($id) -font]
8210 set xr [expr {$xt + [font measure $font $text]}]
8211 if {$xr > $canvxmax} {
8212 set canvxmax $xr
8213 setcanvscroll
8215 if {[info exists currentid] && $currentid == $id} {
8216 make_secsel $id
8220 proc mktagcan {} {
8221 global mktagtop
8223 catch {destroy $mktagtop}
8224 unset mktagtop
8227 proc mktaggo {} {
8228 if {![domktag]} return
8229 mktagcan
8232 proc writecommit {} {
8233 global rowmenuid wrcomtop commitinfo wrcomcmd
8235 set top .writecommit
8236 set wrcomtop $top
8237 catch {destroy $top}
8238 toplevel $top
8239 make_transient $top .
8240 label $top.title -text [mc "Write commit to file"]
8241 grid $top.title - -pady 10
8242 label $top.id -text [mc "ID:"]
8243 entry $top.sha1 -width 40 -relief flat
8244 $top.sha1 insert 0 $rowmenuid
8245 $top.sha1 conf -state readonly
8246 grid $top.id $top.sha1 -sticky w
8247 entry $top.head -width 60 -relief flat
8248 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8249 $top.head conf -state readonly
8250 grid x $top.head -sticky w
8251 label $top.clab -text [mc "Command:"]
8252 entry $top.cmd -width 60 -textvariable wrcomcmd
8253 grid $top.clab $top.cmd -sticky w -pady 10
8254 label $top.flab -text [mc "Output file:"]
8255 entry $top.fname -width 60
8256 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8257 grid $top.flab $top.fname -sticky w
8258 frame $top.buts
8259 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8260 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8261 bind $top <Key-Return> wrcomgo
8262 bind $top <Key-Escape> wrcomcan
8263 grid $top.buts.gen $top.buts.can
8264 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8265 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8266 grid $top.buts - -pady 10 -sticky ew
8267 focus $top.fname
8270 proc wrcomgo {} {
8271 global wrcomtop
8273 set id [$wrcomtop.sha1 get]
8274 set cmd "echo $id | [$wrcomtop.cmd get]"
8275 set fname [$wrcomtop.fname get]
8276 if {[catch {exec sh -c $cmd >$fname &} err]} {
8277 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8279 catch {destroy $wrcomtop}
8280 unset wrcomtop
8283 proc wrcomcan {} {
8284 global wrcomtop
8286 catch {destroy $wrcomtop}
8287 unset wrcomtop
8290 proc mkbranch {} {
8291 global rowmenuid mkbrtop
8293 set top .makebranch
8294 catch {destroy $top}
8295 toplevel $top
8296 make_transient $top .
8297 label $top.title -text [mc "Create new branch"]
8298 grid $top.title - -pady 10
8299 label $top.id -text [mc "ID:"]
8300 entry $top.sha1 -width 40 -relief flat
8301 $top.sha1 insert 0 $rowmenuid
8302 $top.sha1 conf -state readonly
8303 grid $top.id $top.sha1 -sticky w
8304 label $top.nlab -text [mc "Name:"]
8305 entry $top.name -width 40
8306 grid $top.nlab $top.name -sticky w
8307 frame $top.buts
8308 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8309 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8310 bind $top <Key-Return> [list mkbrgo $top]
8311 bind $top <Key-Escape> "catch {destroy $top}"
8312 grid $top.buts.go $top.buts.can
8313 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8314 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8315 grid $top.buts - -pady 10 -sticky ew
8316 focus $top.name
8319 proc mkbrgo {top} {
8320 global headids idheads
8322 set name [$top.name get]
8323 set id [$top.sha1 get]
8324 set cmdargs {}
8325 set old_id {}
8326 if {$name eq {}} {
8327 error_popup [mc "Please specify a name for the new branch"] $top
8328 return
8330 if {[info exists headids($name)]} {
8331 if {![confirm_popup [mc \
8332 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8333 return
8335 set old_id $headids($name)
8336 lappend cmdargs -f
8338 catch {destroy $top}
8339 lappend cmdargs $name $id
8340 nowbusy newbranch
8341 update
8342 if {[catch {
8343 eval exec git branch $cmdargs
8344 } err]} {
8345 notbusy newbranch
8346 error_popup $err
8347 } else {
8348 notbusy newbranch
8349 if {$old_id ne {}} {
8350 movehead $id $name
8351 movedhead $id $name
8352 redrawtags $old_id
8353 redrawtags $id
8354 } else {
8355 set headids($name) $id
8356 lappend idheads($id) $name
8357 addedhead $id $name
8358 redrawtags $id
8360 dispneartags 0
8361 run refill_reflist
8365 proc exec_citool {tool_args {baseid {}}} {
8366 global commitinfo env
8368 set save_env [array get env GIT_AUTHOR_*]
8370 if {$baseid ne {}} {
8371 if {![info exists commitinfo($baseid)]} {
8372 getcommit $baseid
8374 set author [lindex $commitinfo($baseid) 1]
8375 set date [lindex $commitinfo($baseid) 2]
8376 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8377 $author author name email]
8378 && $date ne {}} {
8379 set env(GIT_AUTHOR_NAME) $name
8380 set env(GIT_AUTHOR_EMAIL) $email
8381 set env(GIT_AUTHOR_DATE) $date
8385 eval exec git citool $tool_args &
8387 array unset env GIT_AUTHOR_*
8388 array set env $save_env
8391 proc cherrypick {} {
8392 global rowmenuid curview
8393 global mainhead mainheadid
8395 set oldhead [exec git rev-parse HEAD]
8396 set dheads [descheads $rowmenuid]
8397 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8398 set ok [confirm_popup [mc "Commit %s is already\
8399 included in branch %s -- really re-apply it?" \
8400 [string range $rowmenuid 0 7] $mainhead]]
8401 if {!$ok} return
8403 nowbusy cherrypick [mc "Cherry-picking"]
8404 update
8405 # Unfortunately git-cherry-pick writes stuff to stderr even when
8406 # no error occurs, and exec takes that as an indication of error...
8407 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8408 notbusy cherrypick
8409 if {[regexp -line \
8410 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8411 $err msg fname]} {
8412 error_popup [mc "Cherry-pick failed because of local changes\
8413 to file '%s'.\nPlease commit, reset or stash\
8414 your changes and try again." $fname]
8415 } elseif {[regexp -line \
8416 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8417 $err]} {
8418 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8419 conflict.\nDo you wish to run git citool to\
8420 resolve it?"]]} {
8421 # Force citool to read MERGE_MSG
8422 file delete [file join [gitdir] "GITGUI_MSG"]
8423 exec_citool {} $rowmenuid
8425 } else {
8426 error_popup $err
8428 run updatecommits
8429 return
8431 set newhead [exec git rev-parse HEAD]
8432 if {$newhead eq $oldhead} {
8433 notbusy cherrypick
8434 error_popup [mc "No changes committed"]
8435 return
8437 addnewchild $newhead $oldhead
8438 if {[commitinview $oldhead $curview]} {
8439 # XXX this isn't right if we have a path limit...
8440 insertrow $newhead $oldhead $curview
8441 if {$mainhead ne {}} {
8442 movehead $newhead $mainhead
8443 movedhead $newhead $mainhead
8445 set mainheadid $newhead
8446 redrawtags $oldhead
8447 redrawtags $newhead
8448 selbyid $newhead
8450 notbusy cherrypick
8453 proc resethead {} {
8454 global mainhead rowmenuid confirm_ok resettype
8456 set confirm_ok 0
8457 set w ".confirmreset"
8458 toplevel $w
8459 make_transient $w .
8460 wm title $w [mc "Confirm reset"]
8461 message $w.m -text \
8462 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8463 -justify center -aspect 1000
8464 pack $w.m -side top -fill x -padx 20 -pady 20
8465 frame $w.f -relief sunken -border 2
8466 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8467 grid $w.f.rt -sticky w
8468 set resettype mixed
8469 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8470 -text [mc "Soft: Leave working tree and index untouched"]
8471 grid $w.f.soft -sticky w
8472 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8473 -text [mc "Mixed: Leave working tree untouched, reset index"]
8474 grid $w.f.mixed -sticky w
8475 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8476 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8477 grid $w.f.hard -sticky w
8478 pack $w.f -side top -fill x
8479 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8480 pack $w.ok -side left -fill x -padx 20 -pady 20
8481 button $w.cancel -text [mc Cancel] -command "destroy $w"
8482 bind $w <Key-Escape> [list destroy $w]
8483 pack $w.cancel -side right -fill x -padx 20 -pady 20
8484 bind $w <Visibility> "grab $w; focus $w"
8485 tkwait window $w
8486 if {!$confirm_ok} return
8487 if {[catch {set fd [open \
8488 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8489 error_popup $err
8490 } else {
8491 dohidelocalchanges
8492 filerun $fd [list readresetstat $fd]
8493 nowbusy reset [mc "Resetting"]
8494 selbyid $rowmenuid
8498 proc readresetstat {fd} {
8499 global mainhead mainheadid showlocalchanges rprogcoord
8501 if {[gets $fd line] >= 0} {
8502 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8503 set rprogcoord [expr {1.0 * $m / $n}]
8504 adjustprogress
8506 return 1
8508 set rprogcoord 0
8509 adjustprogress
8510 notbusy reset
8511 if {[catch {close $fd} err]} {
8512 error_popup $err
8514 set oldhead $mainheadid
8515 set newhead [exec git rev-parse HEAD]
8516 if {$newhead ne $oldhead} {
8517 movehead $newhead $mainhead
8518 movedhead $newhead $mainhead
8519 set mainheadid $newhead
8520 redrawtags $oldhead
8521 redrawtags $newhead
8523 if {$showlocalchanges} {
8524 doshowlocalchanges
8526 return 0
8529 # context menu for a head
8530 proc headmenu {x y id head} {
8531 global headmenuid headmenuhead headctxmenu mainhead
8533 stopfinding
8534 set headmenuid $id
8535 set headmenuhead $head
8536 set state normal
8537 if {$head eq $mainhead} {
8538 set state disabled
8540 $headctxmenu entryconfigure 0 -state $state
8541 $headctxmenu entryconfigure 1 -state $state
8542 tk_popup $headctxmenu $x $y
8545 proc cobranch {} {
8546 global headmenuid headmenuhead headids
8547 global showlocalchanges
8549 # check the tree is clean first??
8550 nowbusy checkout [mc "Checking out"]
8551 update
8552 dohidelocalchanges
8553 if {[catch {
8554 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8555 } err]} {
8556 notbusy checkout
8557 error_popup $err
8558 if {$showlocalchanges} {
8559 dodiffindex
8561 } else {
8562 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8566 proc readcheckoutstat {fd newhead newheadid} {
8567 global mainhead mainheadid headids showlocalchanges progresscoords
8568 global viewmainheadid curview
8570 if {[gets $fd line] >= 0} {
8571 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8572 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8573 adjustprogress
8575 return 1
8577 set progresscoords {0 0}
8578 adjustprogress
8579 notbusy checkout
8580 if {[catch {close $fd} err]} {
8581 error_popup $err
8583 set oldmainid $mainheadid
8584 set mainhead $newhead
8585 set mainheadid $newheadid
8586 set viewmainheadid($curview) $newheadid
8587 redrawtags $oldmainid
8588 redrawtags $newheadid
8589 selbyid $newheadid
8590 if {$showlocalchanges} {
8591 dodiffindex
8595 proc rmbranch {} {
8596 global headmenuid headmenuhead mainhead
8597 global idheads
8599 set head $headmenuhead
8600 set id $headmenuid
8601 # this check shouldn't be needed any more...
8602 if {$head eq $mainhead} {
8603 error_popup [mc "Cannot delete the currently checked-out branch"]
8604 return
8606 set dheads [descheads $id]
8607 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8608 # the stuff on this branch isn't on any other branch
8609 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8610 branch.\nReally delete branch %s?" $head $head]]} return
8612 nowbusy rmbranch
8613 update
8614 if {[catch {exec git branch -D $head} err]} {
8615 notbusy rmbranch
8616 error_popup $err
8617 return
8619 removehead $id $head
8620 removedhead $id $head
8621 redrawtags $id
8622 notbusy rmbranch
8623 dispneartags 0
8624 run refill_reflist
8627 # Display a list of tags and heads
8628 proc showrefs {} {
8629 global showrefstop bgcolor fgcolor selectbgcolor
8630 global bglist fglist reflistfilter reflist maincursor
8632 set top .showrefs
8633 set showrefstop $top
8634 if {[winfo exists $top]} {
8635 raise $top
8636 refill_reflist
8637 return
8639 toplevel $top
8640 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8641 make_transient $top .
8642 text $top.list -background $bgcolor -foreground $fgcolor \
8643 -selectbackground $selectbgcolor -font mainfont \
8644 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8645 -width 30 -height 20 -cursor $maincursor \
8646 -spacing1 1 -spacing3 1 -state disabled
8647 $top.list tag configure highlight -background $selectbgcolor
8648 lappend bglist $top.list
8649 lappend fglist $top.list
8650 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8651 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8652 grid $top.list $top.ysb -sticky nsew
8653 grid $top.xsb x -sticky ew
8654 frame $top.f
8655 label $top.f.l -text "[mc "Filter"]: "
8656 entry $top.f.e -width 20 -textvariable reflistfilter
8657 set reflistfilter "*"
8658 trace add variable reflistfilter write reflistfilter_change
8659 pack $top.f.e -side right -fill x -expand 1
8660 pack $top.f.l -side left
8661 grid $top.f - -sticky ew -pady 2
8662 button $top.close -command [list destroy $top] -text [mc "Close"]
8663 bind $top <Key-Escape> [list destroy $top]
8664 grid $top.close -
8665 grid columnconfigure $top 0 -weight 1
8666 grid rowconfigure $top 0 -weight 1
8667 bind $top.list <1> {break}
8668 bind $top.list <B1-Motion> {break}
8669 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8670 set reflist {}
8671 refill_reflist
8674 proc sel_reflist {w x y} {
8675 global showrefstop reflist headids tagids otherrefids
8677 if {![winfo exists $showrefstop]} return
8678 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8679 set ref [lindex $reflist [expr {$l-1}]]
8680 set n [lindex $ref 0]
8681 switch -- [lindex $ref 1] {
8682 "H" {selbyid $headids($n)}
8683 "T" {selbyid $tagids($n)}
8684 "o" {selbyid $otherrefids($n)}
8686 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8689 proc unsel_reflist {} {
8690 global showrefstop
8692 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8693 $showrefstop.list tag remove highlight 0.0 end
8696 proc reflistfilter_change {n1 n2 op} {
8697 global reflistfilter
8699 after cancel refill_reflist
8700 after 200 refill_reflist
8703 proc refill_reflist {} {
8704 global reflist reflistfilter showrefstop headids tagids otherrefids
8705 global curview
8707 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8708 set refs {}
8709 foreach n [array names headids] {
8710 if {[string match $reflistfilter $n]} {
8711 if {[commitinview $headids($n) $curview]} {
8712 lappend refs [list $n H]
8713 } else {
8714 interestedin $headids($n) {run refill_reflist}
8718 foreach n [array names tagids] {
8719 if {[string match $reflistfilter $n]} {
8720 if {[commitinview $tagids($n) $curview]} {
8721 lappend refs [list $n T]
8722 } else {
8723 interestedin $tagids($n) {run refill_reflist}
8727 foreach n [array names otherrefids] {
8728 if {[string match $reflistfilter $n]} {
8729 if {[commitinview $otherrefids($n) $curview]} {
8730 lappend refs [list $n o]
8731 } else {
8732 interestedin $otherrefids($n) {run refill_reflist}
8736 set refs [lsort -index 0 $refs]
8737 if {$refs eq $reflist} return
8739 # Update the contents of $showrefstop.list according to the
8740 # differences between $reflist (old) and $refs (new)
8741 $showrefstop.list conf -state normal
8742 $showrefstop.list insert end "\n"
8743 set i 0
8744 set j 0
8745 while {$i < [llength $reflist] || $j < [llength $refs]} {
8746 if {$i < [llength $reflist]} {
8747 if {$j < [llength $refs]} {
8748 set cmp [string compare [lindex $reflist $i 0] \
8749 [lindex $refs $j 0]]
8750 if {$cmp == 0} {
8751 set cmp [string compare [lindex $reflist $i 1] \
8752 [lindex $refs $j 1]]
8754 } else {
8755 set cmp -1
8757 } else {
8758 set cmp 1
8760 switch -- $cmp {
8761 -1 {
8762 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8763 incr i
8766 incr i
8767 incr j
8770 set l [expr {$j + 1}]
8771 $showrefstop.list image create $l.0 -align baseline \
8772 -image reficon-[lindex $refs $j 1] -padx 2
8773 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8774 incr j
8778 set reflist $refs
8779 # delete last newline
8780 $showrefstop.list delete end-2c end-1c
8781 $showrefstop.list conf -state disabled
8784 # Stuff for finding nearby tags
8785 proc getallcommits {} {
8786 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8787 global idheads idtags idotherrefs allparents tagobjid
8789 if {![info exists allcommits]} {
8790 set nextarc 0
8791 set allcommits 0
8792 set seeds {}
8793 set allcwait 0
8794 set cachedarcs 0
8795 set allccache [file join [gitdir] "gitk.cache"]
8796 if {![catch {
8797 set f [open $allccache r]
8798 set allcwait 1
8799 getcache $f
8800 }]} return
8803 if {$allcwait} {
8804 return
8806 set cmd [list | git rev-list --parents]
8807 set allcupdate [expr {$seeds ne {}}]
8808 if {!$allcupdate} {
8809 set ids "--all"
8810 } else {
8811 set refs [concat [array names idheads] [array names idtags] \
8812 [array names idotherrefs]]
8813 set ids {}
8814 set tagobjs {}
8815 foreach name [array names tagobjid] {
8816 lappend tagobjs $tagobjid($name)
8818 foreach id [lsort -unique $refs] {
8819 if {![info exists allparents($id)] &&
8820 [lsearch -exact $tagobjs $id] < 0} {
8821 lappend ids $id
8824 if {$ids ne {}} {
8825 foreach id $seeds {
8826 lappend ids "^$id"
8830 if {$ids ne {}} {
8831 set fd [open [concat $cmd $ids] r]
8832 fconfigure $fd -blocking 0
8833 incr allcommits
8834 nowbusy allcommits
8835 filerun $fd [list getallclines $fd]
8836 } else {
8837 dispneartags 0
8841 # Since most commits have 1 parent and 1 child, we group strings of
8842 # such commits into "arcs" joining branch/merge points (BMPs), which
8843 # are commits that either don't have 1 parent or don't have 1 child.
8845 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8846 # arcout(id) - outgoing arcs for BMP
8847 # arcids(a) - list of IDs on arc including end but not start
8848 # arcstart(a) - BMP ID at start of arc
8849 # arcend(a) - BMP ID at end of arc
8850 # growing(a) - arc a is still growing
8851 # arctags(a) - IDs out of arcids (excluding end) that have tags
8852 # archeads(a) - IDs out of arcids (excluding end) that have heads
8853 # The start of an arc is at the descendent end, so "incoming" means
8854 # coming from descendents, and "outgoing" means going towards ancestors.
8856 proc getallclines {fd} {
8857 global allparents allchildren idtags idheads nextarc
8858 global arcnos arcids arctags arcout arcend arcstart archeads growing
8859 global seeds allcommits cachedarcs allcupdate
8861 set nid 0
8862 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8863 set id [lindex $line 0]
8864 if {[info exists allparents($id)]} {
8865 # seen it already
8866 continue
8868 set cachedarcs 0
8869 set olds [lrange $line 1 end]
8870 set allparents($id) $olds
8871 if {![info exists allchildren($id)]} {
8872 set allchildren($id) {}
8873 set arcnos($id) {}
8874 lappend seeds $id
8875 } else {
8876 set a $arcnos($id)
8877 if {[llength $olds] == 1 && [llength $a] == 1} {
8878 lappend arcids($a) $id
8879 if {[info exists idtags($id)]} {
8880 lappend arctags($a) $id
8882 if {[info exists idheads($id)]} {
8883 lappend archeads($a) $id
8885 if {[info exists allparents($olds)]} {
8886 # seen parent already
8887 if {![info exists arcout($olds)]} {
8888 splitarc $olds
8890 lappend arcids($a) $olds
8891 set arcend($a) $olds
8892 unset growing($a)
8894 lappend allchildren($olds) $id
8895 lappend arcnos($olds) $a
8896 continue
8899 foreach a $arcnos($id) {
8900 lappend arcids($a) $id
8901 set arcend($a) $id
8902 unset growing($a)
8905 set ao {}
8906 foreach p $olds {
8907 lappend allchildren($p) $id
8908 set a [incr nextarc]
8909 set arcstart($a) $id
8910 set archeads($a) {}
8911 set arctags($a) {}
8912 set archeads($a) {}
8913 set arcids($a) {}
8914 lappend ao $a
8915 set growing($a) 1
8916 if {[info exists allparents($p)]} {
8917 # seen it already, may need to make a new branch
8918 if {![info exists arcout($p)]} {
8919 splitarc $p
8921 lappend arcids($a) $p
8922 set arcend($a) $p
8923 unset growing($a)
8925 lappend arcnos($p) $a
8927 set arcout($id) $ao
8929 if {$nid > 0} {
8930 global cached_dheads cached_dtags cached_atags
8931 catch {unset cached_dheads}
8932 catch {unset cached_dtags}
8933 catch {unset cached_atags}
8935 if {![eof $fd]} {
8936 return [expr {$nid >= 1000? 2: 1}]
8938 set cacheok 1
8939 if {[catch {
8940 fconfigure $fd -blocking 1
8941 close $fd
8942 } err]} {
8943 # got an error reading the list of commits
8944 # if we were updating, try rereading the whole thing again
8945 if {$allcupdate} {
8946 incr allcommits -1
8947 dropcache $err
8948 return
8950 error_popup "[mc "Error reading commit topology information;\
8951 branch and preceding/following tag information\
8952 will be incomplete."]\n($err)"
8953 set cacheok 0
8955 if {[incr allcommits -1] == 0} {
8956 notbusy allcommits
8957 if {$cacheok} {
8958 run savecache
8961 dispneartags 0
8962 return 0
8965 proc recalcarc {a} {
8966 global arctags archeads arcids idtags idheads
8968 set at {}
8969 set ah {}
8970 foreach id [lrange $arcids($a) 0 end-1] {
8971 if {[info exists idtags($id)]} {
8972 lappend at $id
8974 if {[info exists idheads($id)]} {
8975 lappend ah $id
8978 set arctags($a) $at
8979 set archeads($a) $ah
8982 proc splitarc {p} {
8983 global arcnos arcids nextarc arctags archeads idtags idheads
8984 global arcstart arcend arcout allparents growing
8986 set a $arcnos($p)
8987 if {[llength $a] != 1} {
8988 puts "oops splitarc called but [llength $a] arcs already"
8989 return
8991 set a [lindex $a 0]
8992 set i [lsearch -exact $arcids($a) $p]
8993 if {$i < 0} {
8994 puts "oops splitarc $p not in arc $a"
8995 return
8997 set na [incr nextarc]
8998 if {[info exists arcend($a)]} {
8999 set arcend($na) $arcend($a)
9000 } else {
9001 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9002 set j [lsearch -exact $arcnos($l) $a]
9003 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9005 set tail [lrange $arcids($a) [expr {$i+1}] end]
9006 set arcids($a) [lrange $arcids($a) 0 $i]
9007 set arcend($a) $p
9008 set arcstart($na) $p
9009 set arcout($p) $na
9010 set arcids($na) $tail
9011 if {[info exists growing($a)]} {
9012 set growing($na) 1
9013 unset growing($a)
9016 foreach id $tail {
9017 if {[llength $arcnos($id)] == 1} {
9018 set arcnos($id) $na
9019 } else {
9020 set j [lsearch -exact $arcnos($id) $a]
9021 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9025 # reconstruct tags and heads lists
9026 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9027 recalcarc $a
9028 recalcarc $na
9029 } else {
9030 set arctags($na) {}
9031 set archeads($na) {}
9035 # Update things for a new commit added that is a child of one
9036 # existing commit. Used when cherry-picking.
9037 proc addnewchild {id p} {
9038 global allparents allchildren idtags nextarc
9039 global arcnos arcids arctags arcout arcend arcstart archeads growing
9040 global seeds allcommits
9042 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9043 set allparents($id) [list $p]
9044 set allchildren($id) {}
9045 set arcnos($id) {}
9046 lappend seeds $id
9047 lappend allchildren($p) $id
9048 set a [incr nextarc]
9049 set arcstart($a) $id
9050 set archeads($a) {}
9051 set arctags($a) {}
9052 set arcids($a) [list $p]
9053 set arcend($a) $p
9054 if {![info exists arcout($p)]} {
9055 splitarc $p
9057 lappend arcnos($p) $a
9058 set arcout($id) [list $a]
9061 # This implements a cache for the topology information.
9062 # The cache saves, for each arc, the start and end of the arc,
9063 # the ids on the arc, and the outgoing arcs from the end.
9064 proc readcache {f} {
9065 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9066 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9067 global allcwait
9069 set a $nextarc
9070 set lim $cachedarcs
9071 if {$lim - $a > 500} {
9072 set lim [expr {$a + 500}]
9074 if {[catch {
9075 if {$a == $lim} {
9076 # finish reading the cache and setting up arctags, etc.
9077 set line [gets $f]
9078 if {$line ne "1"} {error "bad final version"}
9079 close $f
9080 foreach id [array names idtags] {
9081 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9082 [llength $allparents($id)] == 1} {
9083 set a [lindex $arcnos($id) 0]
9084 if {$arctags($a) eq {}} {
9085 recalcarc $a
9089 foreach id [array names idheads] {
9090 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9091 [llength $allparents($id)] == 1} {
9092 set a [lindex $arcnos($id) 0]
9093 if {$archeads($a) eq {}} {
9094 recalcarc $a
9098 foreach id [lsort -unique $possible_seeds] {
9099 if {$arcnos($id) eq {}} {
9100 lappend seeds $id
9103 set allcwait 0
9104 } else {
9105 while {[incr a] <= $lim} {
9106 set line [gets $f]
9107 if {[llength $line] != 3} {error "bad line"}
9108 set s [lindex $line 0]
9109 set arcstart($a) $s
9110 lappend arcout($s) $a
9111 if {![info exists arcnos($s)]} {
9112 lappend possible_seeds $s
9113 set arcnos($s) {}
9115 set e [lindex $line 1]
9116 if {$e eq {}} {
9117 set growing($a) 1
9118 } else {
9119 set arcend($a) $e
9120 if {![info exists arcout($e)]} {
9121 set arcout($e) {}
9124 set arcids($a) [lindex $line 2]
9125 foreach id $arcids($a) {
9126 lappend allparents($s) $id
9127 set s $id
9128 lappend arcnos($id) $a
9130 if {![info exists allparents($s)]} {
9131 set allparents($s) {}
9133 set arctags($a) {}
9134 set archeads($a) {}
9136 set nextarc [expr {$a - 1}]
9138 } err]} {
9139 dropcache $err
9140 return 0
9142 if {!$allcwait} {
9143 getallcommits
9145 return $allcwait
9148 proc getcache {f} {
9149 global nextarc cachedarcs possible_seeds
9151 if {[catch {
9152 set line [gets $f]
9153 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9154 # make sure it's an integer
9155 set cachedarcs [expr {int([lindex $line 1])}]
9156 if {$cachedarcs < 0} {error "bad number of arcs"}
9157 set nextarc 0
9158 set possible_seeds {}
9159 run readcache $f
9160 } err]} {
9161 dropcache $err
9163 return 0
9166 proc dropcache {err} {
9167 global allcwait nextarc cachedarcs seeds
9169 #puts "dropping cache ($err)"
9170 foreach v {arcnos arcout arcids arcstart arcend growing \
9171 arctags archeads allparents allchildren} {
9172 global $v
9173 catch {unset $v}
9175 set allcwait 0
9176 set nextarc 0
9177 set cachedarcs 0
9178 set seeds {}
9179 getallcommits
9182 proc writecache {f} {
9183 global cachearc cachedarcs allccache
9184 global arcstart arcend arcnos arcids arcout
9186 set a $cachearc
9187 set lim $cachedarcs
9188 if {$lim - $a > 1000} {
9189 set lim [expr {$a + 1000}]
9191 if {[catch {
9192 while {[incr a] <= $lim} {
9193 if {[info exists arcend($a)]} {
9194 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9195 } else {
9196 puts $f [list $arcstart($a) {} $arcids($a)]
9199 } err]} {
9200 catch {close $f}
9201 catch {file delete $allccache}
9202 #puts "writing cache failed ($err)"
9203 return 0
9205 set cachearc [expr {$a - 1}]
9206 if {$a > $cachedarcs} {
9207 puts $f "1"
9208 close $f
9209 return 0
9211 return 1
9214 proc savecache {} {
9215 global nextarc cachedarcs cachearc allccache
9217 if {$nextarc == $cachedarcs} return
9218 set cachearc 0
9219 set cachedarcs $nextarc
9220 catch {
9221 set f [open $allccache w]
9222 puts $f [list 1 $cachedarcs]
9223 run writecache $f
9227 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9228 # or 0 if neither is true.
9229 proc anc_or_desc {a b} {
9230 global arcout arcstart arcend arcnos cached_isanc
9232 if {$arcnos($a) eq $arcnos($b)} {
9233 # Both are on the same arc(s); either both are the same BMP,
9234 # or if one is not a BMP, the other is also not a BMP or is
9235 # the BMP at end of the arc (and it only has 1 incoming arc).
9236 # Or both can be BMPs with no incoming arcs.
9237 if {$a eq $b || $arcnos($a) eq {}} {
9238 return 0
9240 # assert {[llength $arcnos($a)] == 1}
9241 set arc [lindex $arcnos($a) 0]
9242 set i [lsearch -exact $arcids($arc) $a]
9243 set j [lsearch -exact $arcids($arc) $b]
9244 if {$i < 0 || $i > $j} {
9245 return 1
9246 } else {
9247 return -1
9251 if {![info exists arcout($a)]} {
9252 set arc [lindex $arcnos($a) 0]
9253 if {[info exists arcend($arc)]} {
9254 set aend $arcend($arc)
9255 } else {
9256 set aend {}
9258 set a $arcstart($arc)
9259 } else {
9260 set aend $a
9262 if {![info exists arcout($b)]} {
9263 set arc [lindex $arcnos($b) 0]
9264 if {[info exists arcend($arc)]} {
9265 set bend $arcend($arc)
9266 } else {
9267 set bend {}
9269 set b $arcstart($arc)
9270 } else {
9271 set bend $b
9273 if {$a eq $bend} {
9274 return 1
9276 if {$b eq $aend} {
9277 return -1
9279 if {[info exists cached_isanc($a,$bend)]} {
9280 if {$cached_isanc($a,$bend)} {
9281 return 1
9284 if {[info exists cached_isanc($b,$aend)]} {
9285 if {$cached_isanc($b,$aend)} {
9286 return -1
9288 if {[info exists cached_isanc($a,$bend)]} {
9289 return 0
9293 set todo [list $a $b]
9294 set anc($a) a
9295 set anc($b) b
9296 for {set i 0} {$i < [llength $todo]} {incr i} {
9297 set x [lindex $todo $i]
9298 if {$anc($x) eq {}} {
9299 continue
9301 foreach arc $arcnos($x) {
9302 set xd $arcstart($arc)
9303 if {$xd eq $bend} {
9304 set cached_isanc($a,$bend) 1
9305 set cached_isanc($b,$aend) 0
9306 return 1
9307 } elseif {$xd eq $aend} {
9308 set cached_isanc($b,$aend) 1
9309 set cached_isanc($a,$bend) 0
9310 return -1
9312 if {![info exists anc($xd)]} {
9313 set anc($xd) $anc($x)
9314 lappend todo $xd
9315 } elseif {$anc($xd) ne $anc($x)} {
9316 set anc($xd) {}
9320 set cached_isanc($a,$bend) 0
9321 set cached_isanc($b,$aend) 0
9322 return 0
9325 # This identifies whether $desc has an ancestor that is
9326 # a growing tip of the graph and which is not an ancestor of $anc
9327 # and returns 0 if so and 1 if not.
9328 # If we subsequently discover a tag on such a growing tip, and that
9329 # turns out to be a descendent of $anc (which it could, since we
9330 # don't necessarily see children before parents), then $desc
9331 # isn't a good choice to display as a descendent tag of
9332 # $anc (since it is the descendent of another tag which is
9333 # a descendent of $anc). Similarly, $anc isn't a good choice to
9334 # display as a ancestor tag of $desc.
9336 proc is_certain {desc anc} {
9337 global arcnos arcout arcstart arcend growing problems
9339 set certain {}
9340 if {[llength $arcnos($anc)] == 1} {
9341 # tags on the same arc are certain
9342 if {$arcnos($desc) eq $arcnos($anc)} {
9343 return 1
9345 if {![info exists arcout($anc)]} {
9346 # if $anc is partway along an arc, use the start of the arc instead
9347 set a [lindex $arcnos($anc) 0]
9348 set anc $arcstart($a)
9351 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9352 set x $desc
9353 } else {
9354 set a [lindex $arcnos($desc) 0]
9355 set x $arcend($a)
9357 if {$x == $anc} {
9358 return 1
9360 set anclist [list $x]
9361 set dl($x) 1
9362 set nnh 1
9363 set ngrowanc 0
9364 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9365 set x [lindex $anclist $i]
9366 if {$dl($x)} {
9367 incr nnh -1
9369 set done($x) 1
9370 foreach a $arcout($x) {
9371 if {[info exists growing($a)]} {
9372 if {![info exists growanc($x)] && $dl($x)} {
9373 set growanc($x) 1
9374 incr ngrowanc
9376 } else {
9377 set y $arcend($a)
9378 if {[info exists dl($y)]} {
9379 if {$dl($y)} {
9380 if {!$dl($x)} {
9381 set dl($y) 0
9382 if {![info exists done($y)]} {
9383 incr nnh -1
9385 if {[info exists growanc($x)]} {
9386 incr ngrowanc -1
9388 set xl [list $y]
9389 for {set k 0} {$k < [llength $xl]} {incr k} {
9390 set z [lindex $xl $k]
9391 foreach c $arcout($z) {
9392 if {[info exists arcend($c)]} {
9393 set v $arcend($c)
9394 if {[info exists dl($v)] && $dl($v)} {
9395 set dl($v) 0
9396 if {![info exists done($v)]} {
9397 incr nnh -1
9399 if {[info exists growanc($v)]} {
9400 incr ngrowanc -1
9402 lappend xl $v
9409 } elseif {$y eq $anc || !$dl($x)} {
9410 set dl($y) 0
9411 lappend anclist $y
9412 } else {
9413 set dl($y) 1
9414 lappend anclist $y
9415 incr nnh
9420 foreach x [array names growanc] {
9421 if {$dl($x)} {
9422 return 0
9424 return 0
9426 return 1
9429 proc validate_arctags {a} {
9430 global arctags idtags
9432 set i -1
9433 set na $arctags($a)
9434 foreach id $arctags($a) {
9435 incr i
9436 if {![info exists idtags($id)]} {
9437 set na [lreplace $na $i $i]
9438 incr i -1
9441 set arctags($a) $na
9444 proc validate_archeads {a} {
9445 global archeads idheads
9447 set i -1
9448 set na $archeads($a)
9449 foreach id $archeads($a) {
9450 incr i
9451 if {![info exists idheads($id)]} {
9452 set na [lreplace $na $i $i]
9453 incr i -1
9456 set archeads($a) $na
9459 # Return the list of IDs that have tags that are descendents of id,
9460 # ignoring IDs that are descendents of IDs already reported.
9461 proc desctags {id} {
9462 global arcnos arcstart arcids arctags idtags allparents
9463 global growing cached_dtags
9465 if {![info exists allparents($id)]} {
9466 return {}
9468 set t1 [clock clicks -milliseconds]
9469 set argid $id
9470 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9471 # part-way along an arc; check that arc first
9472 set a [lindex $arcnos($id) 0]
9473 if {$arctags($a) ne {}} {
9474 validate_arctags $a
9475 set i [lsearch -exact $arcids($a) $id]
9476 set tid {}
9477 foreach t $arctags($a) {
9478 set j [lsearch -exact $arcids($a) $t]
9479 if {$j >= $i} break
9480 set tid $t
9482 if {$tid ne {}} {
9483 return $tid
9486 set id $arcstart($a)
9487 if {[info exists idtags($id)]} {
9488 return $id
9491 if {[info exists cached_dtags($id)]} {
9492 return $cached_dtags($id)
9495 set origid $id
9496 set todo [list $id]
9497 set queued($id) 1
9498 set nc 1
9499 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9500 set id [lindex $todo $i]
9501 set done($id) 1
9502 set ta [info exists hastaggedancestor($id)]
9503 if {!$ta} {
9504 incr nc -1
9506 # ignore tags on starting node
9507 if {!$ta && $i > 0} {
9508 if {[info exists idtags($id)]} {
9509 set tagloc($id) $id
9510 set ta 1
9511 } elseif {[info exists cached_dtags($id)]} {
9512 set tagloc($id) $cached_dtags($id)
9513 set ta 1
9516 foreach a $arcnos($id) {
9517 set d $arcstart($a)
9518 if {!$ta && $arctags($a) ne {}} {
9519 validate_arctags $a
9520 if {$arctags($a) ne {}} {
9521 lappend tagloc($id) [lindex $arctags($a) end]
9524 if {$ta || $arctags($a) ne {}} {
9525 set tomark [list $d]
9526 for {set j 0} {$j < [llength $tomark]} {incr j} {
9527 set dd [lindex $tomark $j]
9528 if {![info exists hastaggedancestor($dd)]} {
9529 if {[info exists done($dd)]} {
9530 foreach b $arcnos($dd) {
9531 lappend tomark $arcstart($b)
9533 if {[info exists tagloc($dd)]} {
9534 unset tagloc($dd)
9536 } elseif {[info exists queued($dd)]} {
9537 incr nc -1
9539 set hastaggedancestor($dd) 1
9543 if {![info exists queued($d)]} {
9544 lappend todo $d
9545 set queued($d) 1
9546 if {![info exists hastaggedancestor($d)]} {
9547 incr nc
9552 set tags {}
9553 foreach id [array names tagloc] {
9554 if {![info exists hastaggedancestor($id)]} {
9555 foreach t $tagloc($id) {
9556 if {[lsearch -exact $tags $t] < 0} {
9557 lappend tags $t
9562 set t2 [clock clicks -milliseconds]
9563 set loopix $i
9565 # remove tags that are descendents of other tags
9566 for {set i 0} {$i < [llength $tags]} {incr i} {
9567 set a [lindex $tags $i]
9568 for {set j 0} {$j < $i} {incr j} {
9569 set b [lindex $tags $j]
9570 set r [anc_or_desc $a $b]
9571 if {$r == 1} {
9572 set tags [lreplace $tags $j $j]
9573 incr j -1
9574 incr i -1
9575 } elseif {$r == -1} {
9576 set tags [lreplace $tags $i $i]
9577 incr i -1
9578 break
9583 if {[array names growing] ne {}} {
9584 # graph isn't finished, need to check if any tag could get
9585 # eclipsed by another tag coming later. Simply ignore any
9586 # tags that could later get eclipsed.
9587 set ctags {}
9588 foreach t $tags {
9589 if {[is_certain $t $origid]} {
9590 lappend ctags $t
9593 if {$tags eq $ctags} {
9594 set cached_dtags($origid) $tags
9595 } else {
9596 set tags $ctags
9598 } else {
9599 set cached_dtags($origid) $tags
9601 set t3 [clock clicks -milliseconds]
9602 if {0 && $t3 - $t1 >= 100} {
9603 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9604 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9606 return $tags
9609 proc anctags {id} {
9610 global arcnos arcids arcout arcend arctags idtags allparents
9611 global growing cached_atags
9613 if {![info exists allparents($id)]} {
9614 return {}
9616 set t1 [clock clicks -milliseconds]
9617 set argid $id
9618 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9619 # part-way along an arc; check that arc first
9620 set a [lindex $arcnos($id) 0]
9621 if {$arctags($a) ne {}} {
9622 validate_arctags $a
9623 set i [lsearch -exact $arcids($a) $id]
9624 foreach t $arctags($a) {
9625 set j [lsearch -exact $arcids($a) $t]
9626 if {$j > $i} {
9627 return $t
9631 if {![info exists arcend($a)]} {
9632 return {}
9634 set id $arcend($a)
9635 if {[info exists idtags($id)]} {
9636 return $id
9639 if {[info exists cached_atags($id)]} {
9640 return $cached_atags($id)
9643 set origid $id
9644 set todo [list $id]
9645 set queued($id) 1
9646 set taglist {}
9647 set nc 1
9648 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9649 set id [lindex $todo $i]
9650 set done($id) 1
9651 set td [info exists hastaggeddescendent($id)]
9652 if {!$td} {
9653 incr nc -1
9655 # ignore tags on starting node
9656 if {!$td && $i > 0} {
9657 if {[info exists idtags($id)]} {
9658 set tagloc($id) $id
9659 set td 1
9660 } elseif {[info exists cached_atags($id)]} {
9661 set tagloc($id) $cached_atags($id)
9662 set td 1
9665 foreach a $arcout($id) {
9666 if {!$td && $arctags($a) ne {}} {
9667 validate_arctags $a
9668 if {$arctags($a) ne {}} {
9669 lappend tagloc($id) [lindex $arctags($a) 0]
9672 if {![info exists arcend($a)]} continue
9673 set d $arcend($a)
9674 if {$td || $arctags($a) ne {}} {
9675 set tomark [list $d]
9676 for {set j 0} {$j < [llength $tomark]} {incr j} {
9677 set dd [lindex $tomark $j]
9678 if {![info exists hastaggeddescendent($dd)]} {
9679 if {[info exists done($dd)]} {
9680 foreach b $arcout($dd) {
9681 if {[info exists arcend($b)]} {
9682 lappend tomark $arcend($b)
9685 if {[info exists tagloc($dd)]} {
9686 unset tagloc($dd)
9688 } elseif {[info exists queued($dd)]} {
9689 incr nc -1
9691 set hastaggeddescendent($dd) 1
9695 if {![info exists queued($d)]} {
9696 lappend todo $d
9697 set queued($d) 1
9698 if {![info exists hastaggeddescendent($d)]} {
9699 incr nc
9704 set t2 [clock clicks -milliseconds]
9705 set loopix $i
9706 set tags {}
9707 foreach id [array names tagloc] {
9708 if {![info exists hastaggeddescendent($id)]} {
9709 foreach t $tagloc($id) {
9710 if {[lsearch -exact $tags $t] < 0} {
9711 lappend tags $t
9717 # remove tags that are ancestors of other tags
9718 for {set i 0} {$i < [llength $tags]} {incr i} {
9719 set a [lindex $tags $i]
9720 for {set j 0} {$j < $i} {incr j} {
9721 set b [lindex $tags $j]
9722 set r [anc_or_desc $a $b]
9723 if {$r == -1} {
9724 set tags [lreplace $tags $j $j]
9725 incr j -1
9726 incr i -1
9727 } elseif {$r == 1} {
9728 set tags [lreplace $tags $i $i]
9729 incr i -1
9730 break
9735 if {[array names growing] ne {}} {
9736 # graph isn't finished, need to check if any tag could get
9737 # eclipsed by another tag coming later. Simply ignore any
9738 # tags that could later get eclipsed.
9739 set ctags {}
9740 foreach t $tags {
9741 if {[is_certain $origid $t]} {
9742 lappend ctags $t
9745 if {$tags eq $ctags} {
9746 set cached_atags($origid) $tags
9747 } else {
9748 set tags $ctags
9750 } else {
9751 set cached_atags($origid) $tags
9753 set t3 [clock clicks -milliseconds]
9754 if {0 && $t3 - $t1 >= 100} {
9755 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9756 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9758 return $tags
9761 # Return the list of IDs that have heads that are descendents of id,
9762 # including id itself if it has a head.
9763 proc descheads {id} {
9764 global arcnos arcstart arcids archeads idheads cached_dheads
9765 global allparents
9767 if {![info exists allparents($id)]} {
9768 return {}
9770 set aret {}
9771 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9772 # part-way along an arc; check it first
9773 set a [lindex $arcnos($id) 0]
9774 if {$archeads($a) ne {}} {
9775 validate_archeads $a
9776 set i [lsearch -exact $arcids($a) $id]
9777 foreach t $archeads($a) {
9778 set j [lsearch -exact $arcids($a) $t]
9779 if {$j > $i} break
9780 lappend aret $t
9783 set id $arcstart($a)
9785 set origid $id
9786 set todo [list $id]
9787 set seen($id) 1
9788 set ret {}
9789 for {set i 0} {$i < [llength $todo]} {incr i} {
9790 set id [lindex $todo $i]
9791 if {[info exists cached_dheads($id)]} {
9792 set ret [concat $ret $cached_dheads($id)]
9793 } else {
9794 if {[info exists idheads($id)]} {
9795 lappend ret $id
9797 foreach a $arcnos($id) {
9798 if {$archeads($a) ne {}} {
9799 validate_archeads $a
9800 if {$archeads($a) ne {}} {
9801 set ret [concat $ret $archeads($a)]
9804 set d $arcstart($a)
9805 if {![info exists seen($d)]} {
9806 lappend todo $d
9807 set seen($d) 1
9812 set ret [lsort -unique $ret]
9813 set cached_dheads($origid) $ret
9814 return [concat $ret $aret]
9817 proc addedtag {id} {
9818 global arcnos arcout cached_dtags cached_atags
9820 if {![info exists arcnos($id)]} return
9821 if {![info exists arcout($id)]} {
9822 recalcarc [lindex $arcnos($id) 0]
9824 catch {unset cached_dtags}
9825 catch {unset cached_atags}
9828 proc addedhead {hid head} {
9829 global arcnos arcout cached_dheads
9831 if {![info exists arcnos($hid)]} return
9832 if {![info exists arcout($hid)]} {
9833 recalcarc [lindex $arcnos($hid) 0]
9835 catch {unset cached_dheads}
9838 proc removedhead {hid head} {
9839 global cached_dheads
9841 catch {unset cached_dheads}
9844 proc movedhead {hid head} {
9845 global arcnos arcout cached_dheads
9847 if {![info exists arcnos($hid)]} return
9848 if {![info exists arcout($hid)]} {
9849 recalcarc [lindex $arcnos($hid) 0]
9851 catch {unset cached_dheads}
9854 proc changedrefs {} {
9855 global cached_dheads cached_dtags cached_atags
9856 global arctags archeads arcnos arcout idheads idtags
9858 foreach id [concat [array names idheads] [array names idtags]] {
9859 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9860 set a [lindex $arcnos($id) 0]
9861 if {![info exists donearc($a)]} {
9862 recalcarc $a
9863 set donearc($a) 1
9867 catch {unset cached_dtags}
9868 catch {unset cached_atags}
9869 catch {unset cached_dheads}
9872 proc rereadrefs {} {
9873 global idtags idheads idotherrefs mainheadid
9875 set refids [concat [array names idtags] \
9876 [array names idheads] [array names idotherrefs]]
9877 foreach id $refids {
9878 if {![info exists ref($id)]} {
9879 set ref($id) [listrefs $id]
9882 set oldmainhead $mainheadid
9883 readrefs
9884 changedrefs
9885 set refids [lsort -unique [concat $refids [array names idtags] \
9886 [array names idheads] [array names idotherrefs]]]
9887 foreach id $refids {
9888 set v [listrefs $id]
9889 if {![info exists ref($id)] || $ref($id) != $v} {
9890 redrawtags $id
9893 if {$oldmainhead ne $mainheadid} {
9894 redrawtags $oldmainhead
9895 redrawtags $mainheadid
9897 run refill_reflist
9900 proc listrefs {id} {
9901 global idtags idheads idotherrefs
9903 set x {}
9904 if {[info exists idtags($id)]} {
9905 set x $idtags($id)
9907 set y {}
9908 if {[info exists idheads($id)]} {
9909 set y $idheads($id)
9911 set z {}
9912 if {[info exists idotherrefs($id)]} {
9913 set z $idotherrefs($id)
9915 return [list $x $y $z]
9918 proc showtag {tag isnew} {
9919 global ctext tagcontents tagids linknum tagobjid
9921 if {$isnew} {
9922 addtohistory [list showtag $tag 0]
9924 $ctext conf -state normal
9925 clear_ctext
9926 settabs 0
9927 set linknum 0
9928 if {![info exists tagcontents($tag)]} {
9929 catch {
9930 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9933 if {[info exists tagcontents($tag)]} {
9934 set text $tagcontents($tag)
9935 } else {
9936 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9938 appendwithlinks $text {}
9939 $ctext conf -state disabled
9940 init_flist {}
9943 proc doquit {} {
9944 global stopped
9945 global gitktmpdir
9947 set stopped 100
9948 savestuff .
9949 destroy .
9951 if {[info exists gitktmpdir]} {
9952 catch {file delete -force $gitktmpdir}
9956 proc mkfontdisp {font top which} {
9957 global fontattr fontpref $font
9959 set fontpref($font) [set $font]
9960 button $top.${font}but -text $which -font optionfont \
9961 -command [list choosefont $font $which]
9962 label $top.$font -relief flat -font $font \
9963 -text $fontattr($font,family) -justify left
9964 grid x $top.${font}but $top.$font -sticky w
9967 proc choosefont {font which} {
9968 global fontparam fontlist fonttop fontattr
9969 global prefstop
9971 set fontparam(which) $which
9972 set fontparam(font) $font
9973 set fontparam(family) [font actual $font -family]
9974 set fontparam(size) $fontattr($font,size)
9975 set fontparam(weight) $fontattr($font,weight)
9976 set fontparam(slant) $fontattr($font,slant)
9977 set top .gitkfont
9978 set fonttop $top
9979 if {![winfo exists $top]} {
9980 font create sample
9981 eval font config sample [font actual $font]
9982 toplevel $top
9983 make_transient $top $prefstop
9984 wm title $top [mc "Gitk font chooser"]
9985 label $top.l -textvariable fontparam(which)
9986 pack $top.l -side top
9987 set fontlist [lsort [font families]]
9988 frame $top.f
9989 listbox $top.f.fam -listvariable fontlist \
9990 -yscrollcommand [list $top.f.sb set]
9991 bind $top.f.fam <<ListboxSelect>> selfontfam
9992 scrollbar $top.f.sb -command [list $top.f.fam yview]
9993 pack $top.f.sb -side right -fill y
9994 pack $top.f.fam -side left -fill both -expand 1
9995 pack $top.f -side top -fill both -expand 1
9996 frame $top.g
9997 spinbox $top.g.size -from 4 -to 40 -width 4 \
9998 -textvariable fontparam(size) \
9999 -validatecommand {string is integer -strict %s}
10000 checkbutton $top.g.bold -padx 5 \
10001 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10002 -variable fontparam(weight) -onvalue bold -offvalue normal
10003 checkbutton $top.g.ital -padx 5 \
10004 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10005 -variable fontparam(slant) -onvalue italic -offvalue roman
10006 pack $top.g.size $top.g.bold $top.g.ital -side left
10007 pack $top.g -side top
10008 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10009 -background white
10010 $top.c create text 100 25 -anchor center -text $which -font sample \
10011 -fill black -tags text
10012 bind $top.c <Configure> [list centertext $top.c]
10013 pack $top.c -side top -fill x
10014 frame $top.buts
10015 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10016 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10017 bind $top <Key-Return> fontok
10018 bind $top <Key-Escape> fontcan
10019 grid $top.buts.ok $top.buts.can
10020 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10021 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10022 pack $top.buts -side bottom -fill x
10023 trace add variable fontparam write chg_fontparam
10024 } else {
10025 raise $top
10026 $top.c itemconf text -text $which
10028 set i [lsearch -exact $fontlist $fontparam(family)]
10029 if {$i >= 0} {
10030 $top.f.fam selection set $i
10031 $top.f.fam see $i
10035 proc centertext {w} {
10036 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10039 proc fontok {} {
10040 global fontparam fontpref prefstop
10042 set f $fontparam(font)
10043 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10044 if {$fontparam(weight) eq "bold"} {
10045 lappend fontpref($f) "bold"
10047 if {$fontparam(slant) eq "italic"} {
10048 lappend fontpref($f) "italic"
10050 set w $prefstop.$f
10051 $w conf -text $fontparam(family) -font $fontpref($f)
10053 fontcan
10056 proc fontcan {} {
10057 global fonttop fontparam
10059 if {[info exists fonttop]} {
10060 catch {destroy $fonttop}
10061 catch {font delete sample}
10062 unset fonttop
10063 unset fontparam
10067 proc selfontfam {} {
10068 global fonttop fontparam
10070 set i [$fonttop.f.fam curselection]
10071 if {$i ne {}} {
10072 set fontparam(family) [$fonttop.f.fam get $i]
10076 proc chg_fontparam {v sub op} {
10077 global fontparam
10079 font config sample -$sub $fontparam($sub)
10082 proc doprefs {} {
10083 global maxwidth maxgraphpct
10084 global oldprefs prefstop showneartags showlocalchanges
10085 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10086 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10088 set top .gitkprefs
10089 set prefstop $top
10090 if {[winfo exists $top]} {
10091 raise $top
10092 return
10094 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10095 limitdiffs tabstop perfile_attrs} {
10096 set oldprefs($v) [set $v]
10098 toplevel $top
10099 wm title $top [mc "Gitk preferences"]
10100 make_transient $top .
10101 label $top.ldisp -text [mc "Commit list display options"]
10102 grid $top.ldisp - -sticky w -pady 10
10103 label $top.spacer -text " "
10104 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10105 -font optionfont
10106 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10107 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10108 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10109 -font optionfont
10110 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10111 grid x $top.maxpctl $top.maxpct -sticky w
10112 checkbutton $top.showlocal -text [mc "Show local changes"] \
10113 -font optionfont -variable showlocalchanges
10114 grid x $top.showlocal -sticky w
10115 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10116 -font optionfont -variable autoselect
10117 grid x $top.autoselect -sticky w
10119 label $top.ddisp -text [mc "Diff display options"]
10120 grid $top.ddisp - -sticky w -pady 10
10121 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10122 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10123 grid x $top.tabstopl $top.tabstop -sticky w
10124 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10125 -font optionfont -variable showneartags
10126 grid x $top.ntag -sticky w
10127 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10128 -font optionfont -variable limitdiffs
10129 grid x $top.ldiff -sticky w
10130 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10131 -font optionfont -variable perfile_attrs
10132 grid x $top.lattr -sticky w
10134 entry $top.extdifft -textvariable extdifftool
10135 frame $top.extdifff
10136 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10137 -padx 10
10138 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10139 -command choose_extdiff
10140 pack $top.extdifff.l $top.extdifff.b -side left
10141 grid x $top.extdifff $top.extdifft -sticky w
10143 label $top.cdisp -text [mc "Colors: press to choose"]
10144 grid $top.cdisp - -sticky w -pady 10
10145 label $top.bg -padx 40 -relief sunk -background $bgcolor
10146 button $top.bgbut -text [mc "Background"] -font optionfont \
10147 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10148 grid x $top.bgbut $top.bg -sticky w
10149 label $top.fg -padx 40 -relief sunk -background $fgcolor
10150 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10151 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10152 grid x $top.fgbut $top.fg -sticky w
10153 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10154 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10155 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10156 [list $ctext tag conf d0 -foreground]]
10157 grid x $top.diffoldbut $top.diffold -sticky w
10158 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10159 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10160 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10161 [list $ctext tag conf dresult -foreground]]
10162 grid x $top.diffnewbut $top.diffnew -sticky w
10163 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10164 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10165 -command [list choosecolor diffcolors 2 $top.hunksep \
10166 [mc "diff hunk header"] \
10167 [list $ctext tag conf hunksep -foreground]]
10168 grid x $top.hunksepbut $top.hunksep -sticky w
10169 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10170 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10171 -command [list choosecolor markbgcolor {} $top.markbgsep \
10172 [mc "marked line background"] \
10173 [list $ctext tag conf omark -background]]
10174 grid x $top.markbgbut $top.markbgsep -sticky w
10175 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10176 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10177 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10178 grid x $top.selbgbut $top.selbgsep -sticky w
10180 label $top.cfont -text [mc "Fonts: press to choose"]
10181 grid $top.cfont - -sticky w -pady 10
10182 mkfontdisp mainfont $top [mc "Main font"]
10183 mkfontdisp textfont $top [mc "Diff display font"]
10184 mkfontdisp uifont $top [mc "User interface font"]
10186 frame $top.buts
10187 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10188 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10189 bind $top <Key-Return> prefsok
10190 bind $top <Key-Escape> prefscan
10191 grid $top.buts.ok $top.buts.can
10192 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10193 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10194 grid $top.buts - - -pady 10 -sticky ew
10195 bind $top <Visibility> "focus $top.buts.ok"
10198 proc choose_extdiff {} {
10199 global extdifftool
10201 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10202 if {$prog ne {}} {
10203 set extdifftool $prog
10207 proc choosecolor {v vi w x cmd} {
10208 global $v
10210 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10211 -title [mc "Gitk: choose color for %s" $x]]
10212 if {$c eq {}} return
10213 $w conf -background $c
10214 lset $v $vi $c
10215 eval $cmd $c
10218 proc setselbg {c} {
10219 global bglist cflist
10220 foreach w $bglist {
10221 $w configure -selectbackground $c
10223 $cflist tag configure highlight \
10224 -background [$cflist cget -selectbackground]
10225 allcanvs itemconf secsel -fill $c
10228 proc setbg {c} {
10229 global bglist
10231 foreach w $bglist {
10232 $w conf -background $c
10236 proc setfg {c} {
10237 global fglist canv
10239 foreach w $fglist {
10240 $w conf -foreground $c
10242 allcanvs itemconf text -fill $c
10243 $canv itemconf circle -outline $c
10246 proc prefscan {} {
10247 global oldprefs prefstop
10249 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10250 limitdiffs tabstop perfile_attrs} {
10251 global $v
10252 set $v $oldprefs($v)
10254 catch {destroy $prefstop}
10255 unset prefstop
10256 fontcan
10259 proc prefsok {} {
10260 global maxwidth maxgraphpct
10261 global oldprefs prefstop showneartags showlocalchanges
10262 global fontpref mainfont textfont uifont
10263 global limitdiffs treediffs perfile_attrs
10265 catch {destroy $prefstop}
10266 unset prefstop
10267 fontcan
10268 set fontchanged 0
10269 if {$mainfont ne $fontpref(mainfont)} {
10270 set mainfont $fontpref(mainfont)
10271 parsefont mainfont $mainfont
10272 eval font configure mainfont [fontflags mainfont]
10273 eval font configure mainfontbold [fontflags mainfont 1]
10274 setcoords
10275 set fontchanged 1
10277 if {$textfont ne $fontpref(textfont)} {
10278 set textfont $fontpref(textfont)
10279 parsefont textfont $textfont
10280 eval font configure textfont [fontflags textfont]
10281 eval font configure textfontbold [fontflags textfont 1]
10283 if {$uifont ne $fontpref(uifont)} {
10284 set uifont $fontpref(uifont)
10285 parsefont uifont $uifont
10286 eval font configure uifont [fontflags uifont]
10288 settabs
10289 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10290 if {$showlocalchanges} {
10291 doshowlocalchanges
10292 } else {
10293 dohidelocalchanges
10296 if {$limitdiffs != $oldprefs(limitdiffs) ||
10297 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10298 # treediffs elements are limited by path;
10299 # won't have encodings cached if perfile_attrs was just turned on
10300 catch {unset treediffs}
10302 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10303 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10304 redisplay
10305 } elseif {$showneartags != $oldprefs(showneartags) ||
10306 $limitdiffs != $oldprefs(limitdiffs)} {
10307 reselectline
10311 proc formatdate {d} {
10312 global datetimeformat
10313 if {$d ne {}} {
10314 set d [clock format $d -format $datetimeformat]
10316 return $d
10319 # This list of encoding names and aliases is distilled from
10320 # http://www.iana.org/assignments/character-sets.
10321 # Not all of them are supported by Tcl.
10322 set encoding_aliases {
10323 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10324 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10325 { ISO-10646-UTF-1 csISO10646UTF1 }
10326 { ISO_646.basic:1983 ref csISO646basic1983 }
10327 { INVARIANT csINVARIANT }
10328 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10329 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10330 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10331 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10332 { NATS-DANO iso-ir-9-1 csNATSDANO }
10333 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10334 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10335 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10336 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10337 { ISO-2022-KR csISO2022KR }
10338 { EUC-KR csEUCKR }
10339 { ISO-2022-JP csISO2022JP }
10340 { ISO-2022-JP-2 csISO2022JP2 }
10341 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10342 csISO13JISC6220jp }
10343 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10344 { IT iso-ir-15 ISO646-IT csISO15Italian }
10345 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10346 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10347 { greek7-old iso-ir-18 csISO18Greek7Old }
10348 { latin-greek iso-ir-19 csISO19LatinGreek }
10349 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10350 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10351 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10352 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10353 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10354 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10355 { INIS iso-ir-49 csISO49INIS }
10356 { INIS-8 iso-ir-50 csISO50INIS8 }
10357 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10358 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10359 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10360 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10361 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10362 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10363 csISO60Norwegian1 }
10364 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10365 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10366 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10367 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10368 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10369 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10370 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10371 { greek7 iso-ir-88 csISO88Greek7 }
10372 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10373 { iso-ir-90 csISO90 }
10374 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10375 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10376 csISO92JISC62991984b }
10377 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10378 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10379 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10380 csISO95JIS62291984handadd }
10381 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10382 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10383 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10384 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10385 CP819 csISOLatin1 }
10386 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10387 { T.61-7bit iso-ir-102 csISO102T617bit }
10388 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10389 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10390 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10391 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10392 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10393 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10394 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10395 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10396 arabic csISOLatinArabic }
10397 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10398 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10399 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10400 greek greek8 csISOLatinGreek }
10401 { T.101-G2 iso-ir-128 csISO128T101G2 }
10402 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10403 csISOLatinHebrew }
10404 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10405 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10406 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10407 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10408 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10409 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10410 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10411 csISOLatinCyrillic }
10412 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10413 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10414 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10415 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10416 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10417 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10418 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10419 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10420 { ISO_10367-box iso-ir-155 csISO10367Box }
10421 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10422 { latin-lap lap iso-ir-158 csISO158Lap }
10423 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10424 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10425 { us-dk csUSDK }
10426 { dk-us csDKUS }
10427 { JIS_X0201 X0201 csHalfWidthKatakana }
10428 { KSC5636 ISO646-KR csKSC5636 }
10429 { ISO-10646-UCS-2 csUnicode }
10430 { ISO-10646-UCS-4 csUCS4 }
10431 { DEC-MCS dec csDECMCS }
10432 { hp-roman8 roman8 r8 csHPRoman8 }
10433 { macintosh mac csMacintosh }
10434 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10435 csIBM037 }
10436 { IBM038 EBCDIC-INT cp038 csIBM038 }
10437 { IBM273 CP273 csIBM273 }
10438 { IBM274 EBCDIC-BE CP274 csIBM274 }
10439 { IBM275 EBCDIC-BR cp275 csIBM275 }
10440 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10441 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10442 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10443 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10444 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10445 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10446 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10447 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10448 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10449 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10450 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10451 { IBM437 cp437 437 csPC8CodePage437 }
10452 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10453 { IBM775 cp775 csPC775Baltic }
10454 { IBM850 cp850 850 csPC850Multilingual }
10455 { IBM851 cp851 851 csIBM851 }
10456 { IBM852 cp852 852 csPCp852 }
10457 { IBM855 cp855 855 csIBM855 }
10458 { IBM857 cp857 857 csIBM857 }
10459 { IBM860 cp860 860 csIBM860 }
10460 { IBM861 cp861 861 cp-is csIBM861 }
10461 { IBM862 cp862 862 csPC862LatinHebrew }
10462 { IBM863 cp863 863 csIBM863 }
10463 { IBM864 cp864 csIBM864 }
10464 { IBM865 cp865 865 csIBM865 }
10465 { IBM866 cp866 866 csIBM866 }
10466 { IBM868 CP868 cp-ar csIBM868 }
10467 { IBM869 cp869 869 cp-gr csIBM869 }
10468 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10469 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10470 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10471 { IBM891 cp891 csIBM891 }
10472 { IBM903 cp903 csIBM903 }
10473 { IBM904 cp904 904 csIBBM904 }
10474 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10475 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10476 { IBM1026 CP1026 csIBM1026 }
10477 { EBCDIC-AT-DE csIBMEBCDICATDE }
10478 { EBCDIC-AT-DE-A csEBCDICATDEA }
10479 { EBCDIC-CA-FR csEBCDICCAFR }
10480 { EBCDIC-DK-NO csEBCDICDKNO }
10481 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10482 { EBCDIC-FI-SE csEBCDICFISE }
10483 { EBCDIC-FI-SE-A csEBCDICFISEA }
10484 { EBCDIC-FR csEBCDICFR }
10485 { EBCDIC-IT csEBCDICIT }
10486 { EBCDIC-PT csEBCDICPT }
10487 { EBCDIC-ES csEBCDICES }
10488 { EBCDIC-ES-A csEBCDICESA }
10489 { EBCDIC-ES-S csEBCDICESS }
10490 { EBCDIC-UK csEBCDICUK }
10491 { EBCDIC-US csEBCDICUS }
10492 { UNKNOWN-8BIT csUnknown8BiT }
10493 { MNEMONIC csMnemonic }
10494 { MNEM csMnem }
10495 { VISCII csVISCII }
10496 { VIQR csVIQR }
10497 { KOI8-R csKOI8R }
10498 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10499 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10500 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10501 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10502 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10503 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10504 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10505 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10506 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10507 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10508 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10509 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10510 { IBM1047 IBM-1047 }
10511 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10512 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10513 { UNICODE-1-1 csUnicode11 }
10514 { CESU-8 csCESU-8 }
10515 { BOCU-1 csBOCU-1 }
10516 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10517 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10518 l8 }
10519 { ISO-8859-15 ISO_8859-15 Latin-9 }
10520 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10521 { GBK CP936 MS936 windows-936 }
10522 { JIS_Encoding csJISEncoding }
10523 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10524 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10525 EUC-JP }
10526 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10527 { ISO-10646-UCS-Basic csUnicodeASCII }
10528 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10529 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10530 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10531 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10532 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10533 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10534 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10535 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10536 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10537 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10538 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10539 { Ventura-US csVenturaUS }
10540 { Ventura-International csVenturaInternational }
10541 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10542 { PC8-Turkish csPC8Turkish }
10543 { IBM-Symbols csIBMSymbols }
10544 { IBM-Thai csIBMThai }
10545 { HP-Legal csHPLegal }
10546 { HP-Pi-font csHPPiFont }
10547 { HP-Math8 csHPMath8 }
10548 { Adobe-Symbol-Encoding csHPPSMath }
10549 { HP-DeskTop csHPDesktop }
10550 { Ventura-Math csVenturaMath }
10551 { Microsoft-Publishing csMicrosoftPublishing }
10552 { Windows-31J csWindows31J }
10553 { GB2312 csGB2312 }
10554 { Big5 csBig5 }
10557 proc tcl_encoding {enc} {
10558 global encoding_aliases tcl_encoding_cache
10559 if {[info exists tcl_encoding_cache($enc)]} {
10560 return $tcl_encoding_cache($enc)
10562 set names [encoding names]
10563 set lcnames [string tolower $names]
10564 set enc [string tolower $enc]
10565 set i [lsearch -exact $lcnames $enc]
10566 if {$i < 0} {
10567 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10568 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10569 set i [lsearch -exact $lcnames $encx]
10572 if {$i < 0} {
10573 foreach l $encoding_aliases {
10574 set ll [string tolower $l]
10575 if {[lsearch -exact $ll $enc] < 0} continue
10576 # look through the aliases for one that tcl knows about
10577 foreach e $ll {
10578 set i [lsearch -exact $lcnames $e]
10579 if {$i < 0} {
10580 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10581 set i [lsearch -exact $lcnames $ex]
10584 if {$i >= 0} break
10586 break
10589 set tclenc {}
10590 if {$i >= 0} {
10591 set tclenc [lindex $names $i]
10593 set tcl_encoding_cache($enc) $tclenc
10594 return $tclenc
10597 proc gitattr {path attr default} {
10598 global path_attr_cache
10599 if {[info exists path_attr_cache($attr,$path)]} {
10600 set r $path_attr_cache($attr,$path)
10601 } else {
10602 set r "unspecified"
10603 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10604 regexp "(.*): encoding: (.*)" $line m f r
10606 set path_attr_cache($attr,$path) $r
10608 if {$r eq "unspecified"} {
10609 return $default
10611 return $r
10614 proc cache_gitattr {attr pathlist} {
10615 global path_attr_cache
10616 set newlist {}
10617 foreach path $pathlist {
10618 if {![info exists path_attr_cache($attr,$path)]} {
10619 lappend newlist $path
10622 set lim 1000
10623 if {[tk windowingsystem] == "win32"} {
10624 # windows has a 32k limit on the arguments to a command...
10625 set lim 30
10627 while {$newlist ne {}} {
10628 set head [lrange $newlist 0 [expr {$lim - 1}]]
10629 set newlist [lrange $newlist $lim end]
10630 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10631 foreach row [split $rlist "\n"] {
10632 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10633 if {[string index $path 0] eq "\""} {
10634 set path [encoding convertfrom [lindex $path 0]]
10636 set path_attr_cache($attr,$path) $value
10643 proc get_path_encoding {path} {
10644 global gui_encoding perfile_attrs
10645 set tcl_enc $gui_encoding
10646 if {$path ne {} && $perfile_attrs} {
10647 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10648 if {$enc2 ne {}} {
10649 set tcl_enc $enc2
10652 return $tcl_enc
10655 # First check that Tcl/Tk is recent enough
10656 if {[catch {package require Tk 8.4} err]} {
10657 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10658 Gitk requires at least Tcl/Tk 8.4."]
10659 exit 1
10662 # defaults...
10663 set wrcomcmd "git diff-tree --stdin -p --pretty"
10665 set gitencoding {}
10666 catch {
10667 set gitencoding [exec git config --get i18n.commitencoding]
10669 catch {
10670 set gitencoding [exec git config --get i18n.logoutputencoding]
10672 if {$gitencoding == ""} {
10673 set gitencoding "utf-8"
10675 set tclencoding [tcl_encoding $gitencoding]
10676 if {$tclencoding == {}} {
10677 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10680 set gui_encoding [encoding system]
10681 catch {
10682 set enc [exec git config --get gui.encoding]
10683 if {$enc ne {}} {
10684 set tclenc [tcl_encoding $enc]
10685 if {$tclenc ne {}} {
10686 set gui_encoding $tclenc
10687 } else {
10688 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10693 set mainfont {Helvetica 9}
10694 set textfont {Courier 9}
10695 set uifont {Helvetica 9 bold}
10696 set tabstop 8
10697 set findmergefiles 0
10698 set maxgraphpct 50
10699 set maxwidth 16
10700 set revlistorder 0
10701 set fastdate 0
10702 set uparrowlen 5
10703 set downarrowlen 5
10704 set mingaplen 100
10705 set cmitmode "patch"
10706 set wrapcomment "none"
10707 set showneartags 1
10708 set maxrefs 20
10709 set maxlinelen 200
10710 set showlocalchanges 1
10711 set limitdiffs 1
10712 set datetimeformat "%Y-%m-%d %H:%M:%S"
10713 set autoselect 1
10714 set perfile_attrs 0
10716 set extdifftool "meld"
10718 set colors {green red blue magenta darkgrey brown orange}
10719 set bgcolor white
10720 set fgcolor black
10721 set diffcolors {red "#00a000" blue}
10722 set diffcontext 3
10723 set ignorespace 0
10724 set selectbgcolor gray85
10725 set markbgcolor "#e0e0ff"
10727 set circlecolors {white blue gray blue blue}
10729 # button for popping up context menus
10730 if {[tk windowingsystem] eq "aqua"} {
10731 set ctxbut <Button-2>
10732 } else {
10733 set ctxbut <Button-3>
10736 ## For msgcat loading, first locate the installation location.
10737 if { [info exists ::env(GITK_MSGSDIR)] } {
10738 ## Msgsdir was manually set in the environment.
10739 set gitk_msgsdir $::env(GITK_MSGSDIR)
10740 } else {
10741 ## Let's guess the prefix from argv0.
10742 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10743 set gitk_libdir [file join $gitk_prefix share gitk lib]
10744 set gitk_msgsdir [file join $gitk_libdir msgs]
10745 unset gitk_prefix
10748 ## Internationalization (i18n) through msgcat and gettext. See
10749 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10750 package require msgcat
10751 namespace import ::msgcat::mc
10752 ## And eventually load the actual message catalog
10753 ::msgcat::mcload $gitk_msgsdir
10755 catch {source ~/.gitk}
10757 font create optionfont -family sans-serif -size -12
10759 parsefont mainfont $mainfont
10760 eval font create mainfont [fontflags mainfont]
10761 eval font create mainfontbold [fontflags mainfont 1]
10763 parsefont textfont $textfont
10764 eval font create textfont [fontflags textfont]
10765 eval font create textfontbold [fontflags textfont 1]
10767 parsefont uifont $uifont
10768 eval font create uifont [fontflags uifont]
10770 setoptions
10772 # check that we can find a .git directory somewhere...
10773 if {[catch {set gitdir [gitdir]}]} {
10774 show_error {} . [mc "Cannot find a git repository here."]
10775 exit 1
10777 if {![file isdirectory $gitdir]} {
10778 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10779 exit 1
10782 set selecthead {}
10783 set selectheadid {}
10785 set revtreeargs {}
10786 set cmdline_files {}
10787 set i 0
10788 set revtreeargscmd {}
10789 foreach arg $argv {
10790 switch -glob -- $arg {
10791 "" { }
10792 "--" {
10793 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10794 break
10796 "--select-commit=*" {
10797 set selecthead [string range $arg 16 end]
10799 "--argscmd=*" {
10800 set revtreeargscmd [string range $arg 10 end]
10802 default {
10803 lappend revtreeargs $arg
10806 incr i
10809 if {$selecthead eq "HEAD"} {
10810 set selecthead {}
10813 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10814 # no -- on command line, but some arguments (other than --argscmd)
10815 if {[catch {
10816 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10817 set cmdline_files [split $f "\n"]
10818 set n [llength $cmdline_files]
10819 set revtreeargs [lrange $revtreeargs 0 end-$n]
10820 # Unfortunately git rev-parse doesn't produce an error when
10821 # something is both a revision and a filename. To be consistent
10822 # with git log and git rev-list, check revtreeargs for filenames.
10823 foreach arg $revtreeargs {
10824 if {[file exists $arg]} {
10825 show_error {} . [mc "Ambiguous argument '%s': both revision\
10826 and filename" $arg]
10827 exit 1
10830 } err]} {
10831 # unfortunately we get both stdout and stderr in $err,
10832 # so look for "fatal:".
10833 set i [string first "fatal:" $err]
10834 if {$i > 0} {
10835 set err [string range $err [expr {$i + 6}] end]
10837 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10838 exit 1
10842 set nullid "0000000000000000000000000000000000000000"
10843 set nullid2 "0000000000000000000000000000000000000001"
10844 set nullfile "/dev/null"
10846 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10848 set runq {}
10849 set history {}
10850 set historyindex 0
10851 set fh_serial 0
10852 set nhl_names {}
10853 set highlight_paths {}
10854 set findpattern {}
10855 set searchdirn -forwards
10856 set boldids {}
10857 set boldnameids {}
10858 set diffelide {0 0}
10859 set markingmatches 0
10860 set linkentercount 0
10861 set need_redisplay 0
10862 set nrows_drawn 0
10863 set firsttabstop 0
10865 set nextviewnum 1
10866 set curview 0
10867 set selectedview 0
10868 set selectedhlview [mc "None"]
10869 set highlight_related [mc "None"]
10870 set highlight_files {}
10871 set viewfiles(0) {}
10872 set viewperm(0) 0
10873 set viewargs(0) {}
10874 set viewargscmd(0) {}
10876 set selectedline {}
10877 set numcommits 0
10878 set loginstance 0
10879 set cmdlineok 0
10880 set stopped 0
10881 set stuffsaved 0
10882 set patchnum 0
10883 set lserial 0
10884 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10885 setcoords
10886 makewindow
10887 # wait for the window to become visible
10888 tkwait visibility .
10889 wm title . "[file tail $argv0]: [file tail [pwd]]"
10890 readrefs
10892 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10893 # create a view for the files/dirs specified on the command line
10894 set curview 1
10895 set selectedview 1
10896 set nextviewnum 2
10897 set viewname(1) [mc "Command line"]
10898 set viewfiles(1) $cmdline_files
10899 set viewargs(1) $revtreeargs
10900 set viewargscmd(1) $revtreeargscmd
10901 set viewperm(1) 0
10902 set vdatemode(1) 0
10903 addviewmenu 1
10904 .bar.view entryconf [mca "Edit view..."] -state normal
10905 .bar.view entryconf [mca "Delete view"] -state normal
10908 if {[info exists permviews]} {
10909 foreach v $permviews {
10910 set n $nextviewnum
10911 incr nextviewnum
10912 set viewname($n) [lindex $v 0]
10913 set viewfiles($n) [lindex $v 1]
10914 set viewargs($n) [lindex $v 2]
10915 set viewargscmd($n) [lindex $v 3]
10916 set viewperm($n) 1
10917 addviewmenu $n
10921 if {[tk windowingsystem] eq "win32"} {
10922 focus -force .
10925 getcommits {}