gitk: Make line origin search update the busy status
[alt-git.git] / gitk
blobb8b5e80927102cc75e27fddc65b31585d3e67a45
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
183 lappend glflags $arg
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191 # These mean that we get a subset of the commits
192 set filtered 1
193 lappend glflags $arg
195 "-n" {
196 # This appears to be the only one that has a value as a
197 # separate word following it
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" - "--all" {
203 lappend revargs $arg
205 "--merge" {
206 set vmergeonly($n) 1
207 # git rev-parse doesn't understand --merge
208 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
210 "-*" {
211 # Other flag arguments including -<n>
212 if {[string is digit -strict [string range $arg 1 end]]} {
213 set filtered 1
214 } else {
215 # a flag argument that we don't recognize;
216 # that means we can't optimize
217 set allknown 0
219 lappend glflags $arg
221 default {
222 # Non-flag arguments specify commits or ranges of commits
223 if {[string match "*...*" $arg]} {
224 lappend revargs --gitk-symmetric-diff-marker
226 lappend revargs $arg
230 set vdflags($n) $diffargs
231 set vflags($n) $glflags
232 set vrevs($n) $revargs
233 set vfiltered($n) $filtered
234 set vorigargs($n) $origargs
235 return $allknown
238 proc parseviewrevs {view revs} {
239 global vposids vnegids
241 if {$revs eq {}} {
242 set revs HEAD
244 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
245 # we get stdout followed by stderr in $err
246 # for an unknown rev, git rev-parse echoes it and then errors out
247 set errlines [split $err "\n"]
248 set badrev {}
249 for {set l 0} {$l < [llength $errlines]} {incr l} {
250 set line [lindex $errlines $l]
251 if {!([string length $line] == 40 && [string is xdigit $line])} {
252 if {[string match "fatal:*" $line]} {
253 if {[string match "fatal: ambiguous argument*" $line]
254 && $badrev ne {}} {
255 if {[llength $badrev] == 1} {
256 set err "unknown revision $badrev"
257 } else {
258 set err "unknown revisions: [join $badrev ", "]"
260 } else {
261 set err [join [lrange $errlines $l end] "\n"]
263 break
265 lappend badrev $line
268 error_popup "[mc "Error parsing revisions:"] $err"
269 return {}
271 set ret {}
272 set pos {}
273 set neg {}
274 set sdm 0
275 foreach id [split $ids "\n"] {
276 if {$id eq "--gitk-symmetric-diff-marker"} {
277 set sdm 4
278 } elseif {[string match "^*" $id]} {
279 if {$sdm != 1} {
280 lappend ret $id
281 if {$sdm == 3} {
282 set sdm 0
285 lappend neg [string range $id 1 end]
286 } else {
287 if {$sdm != 2} {
288 lappend ret $id
289 } else {
290 lset ret end [lindex $ret end]...$id
292 lappend pos $id
294 incr sdm -1
296 set vposids($view) $pos
297 set vnegids($view) $neg
298 return $ret
301 # Start off a git log process and arrange to read its output
302 proc start_rev_list {view} {
303 global startmsecs commitidx viewcomplete curview
304 global tclencoding
305 global viewargs viewargscmd viewfiles vfilelimit
306 global showlocalchanges
307 global viewactive viewinstances vmergeonly
308 global mainheadid viewmainheadid viewmainheadid_orig
309 global vcanopt vflags vrevs vorigargs
311 set startmsecs [clock clicks -milliseconds]
312 set commitidx($view) 0
313 # these are set this way for the error exits
314 set viewcomplete($view) 1
315 set viewactive($view) 0
316 varcinit $view
318 set args $viewargs($view)
319 if {$viewargscmd($view) ne {}} {
320 if {[catch {
321 set str [exec sh -c $viewargscmd($view)]
322 } err]} {
323 error_popup "[mc "Error executing --argscmd command:"] $err"
324 return 0
326 set args [concat $args [split $str "\n"]]
328 set vcanopt($view) [parseviewargs $view $args]
330 set files $viewfiles($view)
331 if {$vmergeonly($view)} {
332 set files [unmerged_files $files]
333 if {$files eq {}} {
334 global nr_unmerged
335 if {$nr_unmerged == 0} {
336 error_popup [mc "No files selected: --merge specified but\
337 no files are unmerged."]
338 } else {
339 error_popup [mc "No files selected: --merge specified but\
340 no unmerged files are within file limit."]
342 return 0
345 set vfilelimit($view) $files
347 if {$vcanopt($view)} {
348 set revs [parseviewrevs $view $vrevs($view)]
349 if {$revs eq {}} {
350 return 0
352 set args [concat $vflags($view) $revs]
353 } else {
354 set args $vorigargs($view)
357 if {[catch {
358 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
359 --boundary $args "--" $files] r]
360 } err]} {
361 error_popup "[mc "Error executing git log:"] $err"
362 return 0
364 set i [reg_instance $fd]
365 set viewinstances($view) [list $i]
366 set viewmainheadid($view) $mainheadid
367 set viewmainheadid_orig($view) $mainheadid
368 if {$files ne {} && $mainheadid ne {}} {
369 get_viewmainhead $view
371 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
372 interestedin $viewmainheadid($view) dodiffindex
374 fconfigure $fd -blocking 0 -translation lf -eofchar {}
375 if {$tclencoding != {}} {
376 fconfigure $fd -encoding $tclencoding
378 filerun $fd [list getcommitlines $fd $i $view 0]
379 nowbusy $view [mc "Reading"]
380 set viewcomplete($view) 0
381 set viewactive($view) 1
382 return 1
385 proc stop_instance {inst} {
386 global commfd leftover
388 set fd $commfd($inst)
389 catch {
390 set pid [pid $fd]
392 if {$::tcl_platform(platform) eq {windows}} {
393 exec kill -f $pid
394 } else {
395 exec kill $pid
398 catch {close $fd}
399 nukefile $fd
400 unset commfd($inst)
401 unset leftover($inst)
404 proc stop_backends {} {
405 global commfd
407 foreach inst [array names commfd] {
408 stop_instance $inst
412 proc stop_rev_list {view} {
413 global viewinstances
415 foreach inst $viewinstances($view) {
416 stop_instance $inst
418 set viewinstances($view) {}
421 proc reset_pending_select {selid} {
422 global pending_select mainheadid selectheadid
424 if {$selid ne {}} {
425 set pending_select $selid
426 } elseif {$selectheadid ne {}} {
427 set pending_select $selectheadid
428 } else {
429 set pending_select $mainheadid
433 proc getcommits {selid} {
434 global canv curview need_redisplay viewactive
436 initlayout
437 if {[start_rev_list $curview]} {
438 reset_pending_select $selid
439 show_status [mc "Reading commits..."]
440 set need_redisplay 1
441 } else {
442 show_status [mc "No commits selected"]
446 proc updatecommits {} {
447 global curview vcanopt vorigargs vfilelimit viewinstances
448 global viewactive viewcomplete tclencoding
449 global startmsecs showneartags showlocalchanges
450 global mainheadid viewmainheadid viewmainheadid_orig pending_select
451 global isworktree
452 global varcid vposids vnegids vflags vrevs
454 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
455 rereadrefs
456 set view $curview
457 if {$mainheadid ne $viewmainheadid_orig($view)} {
458 if {$showlocalchanges} {
459 dohidelocalchanges
461 set viewmainheadid($view) $mainheadid
462 set viewmainheadid_orig($view) $mainheadid
463 if {$vfilelimit($view) ne {}} {
464 get_viewmainhead $view
467 if {$showlocalchanges} {
468 doshowlocalchanges
470 if {$vcanopt($view)} {
471 set oldpos $vposids($view)
472 set oldneg $vnegids($view)
473 set revs [parseviewrevs $view $vrevs($view)]
474 if {$revs eq {}} {
475 return
477 # note: getting the delta when negative refs change is hard,
478 # and could require multiple git log invocations, so in that
479 # case we ask git log for all the commits (not just the delta)
480 if {$oldneg eq $vnegids($view)} {
481 set newrevs {}
482 set npos 0
483 # take out positive refs that we asked for before or
484 # that we have already seen
485 foreach rev $revs {
486 if {[string length $rev] == 40} {
487 if {[lsearch -exact $oldpos $rev] < 0
488 && ![info exists varcid($view,$rev)]} {
489 lappend newrevs $rev
490 incr npos
492 } else {
493 lappend $newrevs $rev
496 if {$npos == 0} return
497 set revs $newrevs
498 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
500 set args [concat $vflags($view) $revs --not $oldpos]
501 } else {
502 set args $vorigargs($view)
504 if {[catch {
505 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
506 --boundary $args "--" $vfilelimit($view)] r]
507 } err]} {
508 error_popup "[mc "Error executing git log:"] $err"
509 return
511 if {$viewactive($view) == 0} {
512 set startmsecs [clock clicks -milliseconds]
514 set i [reg_instance $fd]
515 lappend viewinstances($view) $i
516 fconfigure $fd -blocking 0 -translation lf -eofchar {}
517 if {$tclencoding != {}} {
518 fconfigure $fd -encoding $tclencoding
520 filerun $fd [list getcommitlines $fd $i $view 1]
521 incr viewactive($view)
522 set viewcomplete($view) 0
523 reset_pending_select {}
524 nowbusy $view "Reading"
525 if {$showneartags} {
526 getallcommits
530 proc reloadcommits {} {
531 global curview viewcomplete selectedline currentid thickerline
532 global showneartags treediffs commitinterest cached_commitrow
533 global targetid
535 set selid {}
536 if {$selectedline ne {}} {
537 set selid $currentid
540 if {!$viewcomplete($curview)} {
541 stop_rev_list $curview
543 resetvarcs $curview
544 set selectedline {}
545 catch {unset currentid}
546 catch {unset thickerline}
547 catch {unset treediffs}
548 readrefs
549 changedrefs
550 if {$showneartags} {
551 getallcommits
553 clear_display
554 catch {unset commitinterest}
555 catch {unset cached_commitrow}
556 catch {unset targetid}
557 setcanvscroll
558 getcommits $selid
559 return 0
562 # This makes a string representation of a positive integer which
563 # sorts as a string in numerical order
564 proc strrep {n} {
565 if {$n < 16} {
566 return [format "%x" $n]
567 } elseif {$n < 256} {
568 return [format "x%.2x" $n]
569 } elseif {$n < 65536} {
570 return [format "y%.4x" $n]
572 return [format "z%.8x" $n]
575 # Procedures used in reordering commits from git log (without
576 # --topo-order) into the order for display.
578 proc varcinit {view} {
579 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
580 global vtokmod varcmod vrowmod varcix vlastins
582 set varcstart($view) {{}}
583 set vupptr($view) {0}
584 set vdownptr($view) {0}
585 set vleftptr($view) {0}
586 set vbackptr($view) {0}
587 set varctok($view) {{}}
588 set varcrow($view) {{}}
589 set vtokmod($view) {}
590 set varcmod($view) 0
591 set vrowmod($view) 0
592 set varcix($view) {{}}
593 set vlastins($view) {0}
596 proc resetvarcs {view} {
597 global varcid varccommits parents children vseedcount ordertok
599 foreach vid [array names varcid $view,*] {
600 unset varcid($vid)
601 unset children($vid)
602 unset parents($vid)
604 # some commits might have children but haven't been seen yet
605 foreach vid [array names children $view,*] {
606 unset children($vid)
608 foreach va [array names varccommits $view,*] {
609 unset varccommits($va)
611 foreach vd [array names vseedcount $view,*] {
612 unset vseedcount($vd)
614 catch {unset ordertok}
617 # returns a list of the commits with no children
618 proc seeds {v} {
619 global vdownptr vleftptr varcstart
621 set ret {}
622 set a [lindex $vdownptr($v) 0]
623 while {$a != 0} {
624 lappend ret [lindex $varcstart($v) $a]
625 set a [lindex $vleftptr($v) $a]
627 return $ret
630 proc newvarc {view id} {
631 global varcid varctok parents children vdatemode
632 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
633 global commitdata commitinfo vseedcount varccommits vlastins
635 set a [llength $varctok($view)]
636 set vid $view,$id
637 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
638 if {![info exists commitinfo($id)]} {
639 parsecommit $id $commitdata($id) 1
641 set cdate [lindex $commitinfo($id) 4]
642 if {![string is integer -strict $cdate]} {
643 set cdate 0
645 if {![info exists vseedcount($view,$cdate)]} {
646 set vseedcount($view,$cdate) -1
648 set c [incr vseedcount($view,$cdate)]
649 set cdate [expr {$cdate ^ 0xffffffff}]
650 set tok "s[strrep $cdate][strrep $c]"
651 } else {
652 set tok {}
654 set ka 0
655 if {[llength $children($vid)] > 0} {
656 set kid [lindex $children($vid) end]
657 set k $varcid($view,$kid)
658 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
659 set ki $kid
660 set ka $k
661 set tok [lindex $varctok($view) $k]
664 if {$ka != 0} {
665 set i [lsearch -exact $parents($view,$ki) $id]
666 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
667 append tok [strrep $j]
669 set c [lindex $vlastins($view) $ka]
670 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
671 set c $ka
672 set b [lindex $vdownptr($view) $ka]
673 } else {
674 set b [lindex $vleftptr($view) $c]
676 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
677 set c $b
678 set b [lindex $vleftptr($view) $c]
680 if {$c == $ka} {
681 lset vdownptr($view) $ka $a
682 lappend vbackptr($view) 0
683 } else {
684 lset vleftptr($view) $c $a
685 lappend vbackptr($view) $c
687 lset vlastins($view) $ka $a
688 lappend vupptr($view) $ka
689 lappend vleftptr($view) $b
690 if {$b != 0} {
691 lset vbackptr($view) $b $a
693 lappend varctok($view) $tok
694 lappend varcstart($view) $id
695 lappend vdownptr($view) 0
696 lappend varcrow($view) {}
697 lappend varcix($view) {}
698 set varccommits($view,$a) {}
699 lappend vlastins($view) 0
700 return $a
703 proc splitvarc {p v} {
704 global varcid varcstart varccommits varctok
705 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707 set oa $varcid($v,$p)
708 set ac $varccommits($v,$oa)
709 set i [lsearch -exact $varccommits($v,$oa) $p]
710 if {$i <= 0} return
711 set na [llength $varctok($v)]
712 # "%" sorts before "0"...
713 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
714 lappend varctok($v) $tok
715 lappend varcrow($v) {}
716 lappend varcix($v) {}
717 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
718 set varccommits($v,$na) [lrange $ac $i end]
719 lappend varcstart($v) $p
720 foreach id $varccommits($v,$na) {
721 set varcid($v,$id) $na
723 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
724 lappend vlastins($v) [lindex $vlastins($v) $oa]
725 lset vdownptr($v) $oa $na
726 lset vlastins($v) $oa 0
727 lappend vupptr($v) $oa
728 lappend vleftptr($v) 0
729 lappend vbackptr($v) 0
730 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
731 lset vupptr($v) $b $na
735 proc renumbervarc {a v} {
736 global parents children varctok varcstart varccommits
737 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
739 set t1 [clock clicks -milliseconds]
740 set todo {}
741 set isrelated($a) 1
742 set kidchanged($a) 1
743 set ntot 0
744 while {$a != 0} {
745 if {[info exists isrelated($a)]} {
746 lappend todo $a
747 set id [lindex $varccommits($v,$a) end]
748 foreach p $parents($v,$id) {
749 if {[info exists varcid($v,$p)]} {
750 set isrelated($varcid($v,$p)) 1
754 incr ntot
755 set b [lindex $vdownptr($v) $a]
756 if {$b == 0} {
757 while {$a != 0} {
758 set b [lindex $vleftptr($v) $a]
759 if {$b != 0} break
760 set a [lindex $vupptr($v) $a]
763 set a $b
765 foreach a $todo {
766 if {![info exists kidchanged($a)]} continue
767 set id [lindex $varcstart($v) $a]
768 if {[llength $children($v,$id)] > 1} {
769 set children($v,$id) [lsort -command [list vtokcmp $v] \
770 $children($v,$id)]
772 set oldtok [lindex $varctok($v) $a]
773 if {!$vdatemode($v)} {
774 set tok {}
775 } else {
776 set tok $oldtok
778 set ka 0
779 set kid [last_real_child $v,$id]
780 if {$kid ne {}} {
781 set k $varcid($v,$kid)
782 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
783 set ki $kid
784 set ka $k
785 set tok [lindex $varctok($v) $k]
788 if {$ka != 0} {
789 set i [lsearch -exact $parents($v,$ki) $id]
790 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
791 append tok [strrep $j]
793 if {$tok eq $oldtok} {
794 continue
796 set id [lindex $varccommits($v,$a) end]
797 foreach p $parents($v,$id) {
798 if {[info exists varcid($v,$p)]} {
799 set kidchanged($varcid($v,$p)) 1
800 } else {
801 set sortkids($p) 1
804 lset varctok($v) $a $tok
805 set b [lindex $vupptr($v) $a]
806 if {$b != $ka} {
807 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
808 modify_arc $v $ka
810 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
811 modify_arc $v $b
813 set c [lindex $vbackptr($v) $a]
814 set d [lindex $vleftptr($v) $a]
815 if {$c == 0} {
816 lset vdownptr($v) $b $d
817 } else {
818 lset vleftptr($v) $c $d
820 if {$d != 0} {
821 lset vbackptr($v) $d $c
823 if {[lindex $vlastins($v) $b] == $a} {
824 lset vlastins($v) $b $c
826 lset vupptr($v) $a $ka
827 set c [lindex $vlastins($v) $ka]
828 if {$c == 0 || \
829 [string compare $tok [lindex $varctok($v) $c]] < 0} {
830 set c $ka
831 set b [lindex $vdownptr($v) $ka]
832 } else {
833 set b [lindex $vleftptr($v) $c]
835 while {$b != 0 && \
836 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
837 set c $b
838 set b [lindex $vleftptr($v) $c]
840 if {$c == $ka} {
841 lset vdownptr($v) $ka $a
842 lset vbackptr($v) $a 0
843 } else {
844 lset vleftptr($v) $c $a
845 lset vbackptr($v) $a $c
847 lset vleftptr($v) $a $b
848 if {$b != 0} {
849 lset vbackptr($v) $b $a
851 lset vlastins($v) $ka $a
854 foreach id [array names sortkids] {
855 if {[llength $children($v,$id)] > 1} {
856 set children($v,$id) [lsort -command [list vtokcmp $v] \
857 $children($v,$id)]
860 set t2 [clock clicks -milliseconds]
861 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
864 # Fix up the graph after we have found out that in view $v,
865 # $p (a commit that we have already seen) is actually the parent
866 # of the last commit in arc $a.
867 proc fix_reversal {p a v} {
868 global varcid varcstart varctok vupptr
870 set pa $varcid($v,$p)
871 if {$p ne [lindex $varcstart($v) $pa]} {
872 splitvarc $p $v
873 set pa $varcid($v,$p)
875 # seeds always need to be renumbered
876 if {[lindex $vupptr($v) $pa] == 0 ||
877 [string compare [lindex $varctok($v) $a] \
878 [lindex $varctok($v) $pa]] > 0} {
879 renumbervarc $pa $v
883 proc insertrow {id p v} {
884 global cmitlisted children parents varcid varctok vtokmod
885 global varccommits ordertok commitidx numcommits curview
886 global targetid targetrow
888 readcommit $id
889 set vid $v,$id
890 set cmitlisted($vid) 1
891 set children($vid) {}
892 set parents($vid) [list $p]
893 set a [newvarc $v $id]
894 set varcid($vid) $a
895 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
896 modify_arc $v $a
898 lappend varccommits($v,$a) $id
899 set vp $v,$p
900 if {[llength [lappend children($vp) $id]] > 1} {
901 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
902 catch {unset ordertok}
904 fix_reversal $p $a $v
905 incr commitidx($v)
906 if {$v == $curview} {
907 set numcommits $commitidx($v)
908 setcanvscroll
909 if {[info exists targetid]} {
910 if {![comes_before $targetid $p]} {
911 incr targetrow
917 proc insertfakerow {id p} {
918 global varcid varccommits parents children cmitlisted
919 global commitidx varctok vtokmod targetid targetrow curview numcommits
921 set v $curview
922 set a $varcid($v,$p)
923 set i [lsearch -exact $varccommits($v,$a) $p]
924 if {$i < 0} {
925 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
926 return
928 set children($v,$id) {}
929 set parents($v,$id) [list $p]
930 set varcid($v,$id) $a
931 lappend children($v,$p) $id
932 set cmitlisted($v,$id) 1
933 set numcommits [incr commitidx($v)]
934 # note we deliberately don't update varcstart($v) even if $i == 0
935 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
936 modify_arc $v $a $i
937 if {[info exists targetid]} {
938 if {![comes_before $targetid $p]} {
939 incr targetrow
942 setcanvscroll
943 drawvisible
946 proc removefakerow {id} {
947 global varcid varccommits parents children commitidx
948 global varctok vtokmod cmitlisted currentid selectedline
949 global targetid curview numcommits
951 set v $curview
952 if {[llength $parents($v,$id)] != 1} {
953 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
954 return
956 set p [lindex $parents($v,$id) 0]
957 set a $varcid($v,$id)
958 set i [lsearch -exact $varccommits($v,$a) $id]
959 if {$i < 0} {
960 puts "oops: removefakerow can't find [shortids $id] on arc $a"
961 return
963 unset varcid($v,$id)
964 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
965 unset parents($v,$id)
966 unset children($v,$id)
967 unset cmitlisted($v,$id)
968 set numcommits [incr commitidx($v) -1]
969 set j [lsearch -exact $children($v,$p) $id]
970 if {$j >= 0} {
971 set children($v,$p) [lreplace $children($v,$p) $j $j]
973 modify_arc $v $a $i
974 if {[info exist currentid] && $id eq $currentid} {
975 unset currentid
976 set selectedline {}
978 if {[info exists targetid] && $targetid eq $id} {
979 set targetid $p
981 setcanvscroll
982 drawvisible
985 proc first_real_child {vp} {
986 global children nullid nullid2
988 foreach id $children($vp) {
989 if {$id ne $nullid && $id ne $nullid2} {
990 return $id
993 return {}
996 proc last_real_child {vp} {
997 global children nullid nullid2
999 set kids $children($vp)
1000 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1001 set id [lindex $kids $i]
1002 if {$id ne $nullid && $id ne $nullid2} {
1003 return $id
1006 return {}
1009 proc vtokcmp {v a b} {
1010 global varctok varcid
1012 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1013 [lindex $varctok($v) $varcid($v,$b)]]
1016 # This assumes that if lim is not given, the caller has checked that
1017 # arc a's token is less than $vtokmod($v)
1018 proc modify_arc {v a {lim {}}} {
1019 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1021 if {$lim ne {}} {
1022 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1023 if {$c > 0} return
1024 if {$c == 0} {
1025 set r [lindex $varcrow($v) $a]
1026 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1029 set vtokmod($v) [lindex $varctok($v) $a]
1030 set varcmod($v) $a
1031 if {$v == $curview} {
1032 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1033 set a [lindex $vupptr($v) $a]
1034 set lim {}
1036 set r 0
1037 if {$a != 0} {
1038 if {$lim eq {}} {
1039 set lim [llength $varccommits($v,$a)]
1041 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1043 set vrowmod($v) $r
1044 undolayout $r
1048 proc update_arcrows {v} {
1049 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1050 global varcid vrownum varcorder varcix varccommits
1051 global vupptr vdownptr vleftptr varctok
1052 global displayorder parentlist curview cached_commitrow
1054 if {$vrowmod($v) == $commitidx($v)} return
1055 if {$v == $curview} {
1056 if {[llength $displayorder] > $vrowmod($v)} {
1057 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1058 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1060 catch {unset cached_commitrow}
1062 set narctot [expr {[llength $varctok($v)] - 1}]
1063 set a $varcmod($v)
1064 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1065 # go up the tree until we find something that has a row number,
1066 # or we get to a seed
1067 set a [lindex $vupptr($v) $a]
1069 if {$a == 0} {
1070 set a [lindex $vdownptr($v) 0]
1071 if {$a == 0} return
1072 set vrownum($v) {0}
1073 set varcorder($v) [list $a]
1074 lset varcix($v) $a 0
1075 lset varcrow($v) $a 0
1076 set arcn 0
1077 set row 0
1078 } else {
1079 set arcn [lindex $varcix($v) $a]
1080 if {[llength $vrownum($v)] > $arcn + 1} {
1081 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1082 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1084 set row [lindex $varcrow($v) $a]
1086 while {1} {
1087 set p $a
1088 incr row [llength $varccommits($v,$a)]
1089 # go down if possible
1090 set b [lindex $vdownptr($v) $a]
1091 if {$b == 0} {
1092 # if not, go left, or go up until we can go left
1093 while {$a != 0} {
1094 set b [lindex $vleftptr($v) $a]
1095 if {$b != 0} break
1096 set a [lindex $vupptr($v) $a]
1098 if {$a == 0} break
1100 set a $b
1101 incr arcn
1102 lappend vrownum($v) $row
1103 lappend varcorder($v) $a
1104 lset varcix($v) $a $arcn
1105 lset varcrow($v) $a $row
1107 set vtokmod($v) [lindex $varctok($v) $p]
1108 set varcmod($v) $p
1109 set vrowmod($v) $row
1110 if {[info exists currentid]} {
1111 set selectedline [rowofcommit $currentid]
1115 # Test whether view $v contains commit $id
1116 proc commitinview {id v} {
1117 global varcid
1119 return [info exists varcid($v,$id)]
1122 # Return the row number for commit $id in the current view
1123 proc rowofcommit {id} {
1124 global varcid varccommits varcrow curview cached_commitrow
1125 global varctok vtokmod
1127 set v $curview
1128 if {![info exists varcid($v,$id)]} {
1129 puts "oops rowofcommit no arc for [shortids $id]"
1130 return {}
1132 set a $varcid($v,$id)
1133 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1134 update_arcrows $v
1136 if {[info exists cached_commitrow($id)]} {
1137 return $cached_commitrow($id)
1139 set i [lsearch -exact $varccommits($v,$a) $id]
1140 if {$i < 0} {
1141 puts "oops didn't find commit [shortids $id] in arc $a"
1142 return {}
1144 incr i [lindex $varcrow($v) $a]
1145 set cached_commitrow($id) $i
1146 return $i
1149 # Returns 1 if a is on an earlier row than b, otherwise 0
1150 proc comes_before {a b} {
1151 global varcid varctok curview
1153 set v $curview
1154 if {$a eq $b || ![info exists varcid($v,$a)] || \
1155 ![info exists varcid($v,$b)]} {
1156 return 0
1158 if {$varcid($v,$a) != $varcid($v,$b)} {
1159 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1160 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1162 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1165 proc bsearch {l elt} {
1166 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1167 return 0
1169 set lo 0
1170 set hi [llength $l]
1171 while {$hi - $lo > 1} {
1172 set mid [expr {int(($lo + $hi) / 2)}]
1173 set t [lindex $l $mid]
1174 if {$elt < $t} {
1175 set hi $mid
1176 } elseif {$elt > $t} {
1177 set lo $mid
1178 } else {
1179 return $mid
1182 return $lo
1185 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1186 proc make_disporder {start end} {
1187 global vrownum curview commitidx displayorder parentlist
1188 global varccommits varcorder parents vrowmod varcrow
1189 global d_valid_start d_valid_end
1191 if {$end > $vrowmod($curview)} {
1192 update_arcrows $curview
1194 set ai [bsearch $vrownum($curview) $start]
1195 set start [lindex $vrownum($curview) $ai]
1196 set narc [llength $vrownum($curview)]
1197 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1198 set a [lindex $varcorder($curview) $ai]
1199 set l [llength $displayorder]
1200 set al [llength $varccommits($curview,$a)]
1201 if {$l < $r + $al} {
1202 if {$l < $r} {
1203 set pad [ntimes [expr {$r - $l}] {}]
1204 set displayorder [concat $displayorder $pad]
1205 set parentlist [concat $parentlist $pad]
1206 } elseif {$l > $r} {
1207 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1208 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1210 foreach id $varccommits($curview,$a) {
1211 lappend displayorder $id
1212 lappend parentlist $parents($curview,$id)
1214 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1215 set i $r
1216 foreach id $varccommits($curview,$a) {
1217 lset displayorder $i $id
1218 lset parentlist $i $parents($curview,$id)
1219 incr i
1222 incr r $al
1226 proc commitonrow {row} {
1227 global displayorder
1229 set id [lindex $displayorder $row]
1230 if {$id eq {}} {
1231 make_disporder $row [expr {$row + 1}]
1232 set id [lindex $displayorder $row]
1234 return $id
1237 proc closevarcs {v} {
1238 global varctok varccommits varcid parents children
1239 global cmitlisted commitidx vtokmod
1241 set missing_parents 0
1242 set scripts {}
1243 set narcs [llength $varctok($v)]
1244 for {set a 1} {$a < $narcs} {incr a} {
1245 set id [lindex $varccommits($v,$a) end]
1246 foreach p $parents($v,$id) {
1247 if {[info exists varcid($v,$p)]} continue
1248 # add p as a new commit
1249 incr missing_parents
1250 set cmitlisted($v,$p) 0
1251 set parents($v,$p) {}
1252 if {[llength $children($v,$p)] == 1 &&
1253 [llength $parents($v,$id)] == 1} {
1254 set b $a
1255 } else {
1256 set b [newvarc $v $p]
1258 set varcid($v,$p) $b
1259 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1260 modify_arc $v $b
1262 lappend varccommits($v,$b) $p
1263 incr commitidx($v)
1264 set scripts [check_interest $p $scripts]
1267 if {$missing_parents > 0} {
1268 foreach s $scripts {
1269 eval $s
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch $children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i [lsearch -exact $parents($v,$ch) $id]
1282 if {$i < 0} {
1283 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a $varcid($v,$ch)
1293 fix_reversal $rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1300 # Mechanism for registering a command to be executed when we come
1301 # across a particular commit. To handle the case when only the
1302 # prefix of the commit is known, the commitinterest array is now
1303 # indexed by the first 4 characters of the ID. Each element is a
1304 # list of id, cmd pairs.
1305 proc interestedin {id cmd} {
1306 global commitinterest
1308 lappend commitinterest([string range $id 0 3]) $id $cmd
1311 proc check_interest {id scripts} {
1312 global commitinterest
1314 set prefix [string range $id 0 3]
1315 if {[info exists commitinterest($prefix)]} {
1316 set newlist {}
1317 foreach {i script} $commitinterest($prefix) {
1318 if {[string match "$i*" $id]} {
1319 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1320 } else {
1321 lappend newlist $i $script
1324 if {$newlist ne {}} {
1325 set commitinterest($prefix) $newlist
1326 } else {
1327 unset commitinterest($prefix)
1330 return $scripts
1333 proc getcommitlines {fd inst view updating} {
1334 global cmitlisted leftover
1335 global commitidx commitdata vdatemode
1336 global parents children curview hlview
1337 global idpending ordertok
1338 global varccommits varcid varctok vtokmod vfilelimit
1340 set stuff [read $fd 500000]
1341 # git log doesn't terminate the last commit with a null...
1342 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1343 set stuff "\0"
1345 if {$stuff == {}} {
1346 if {![eof $fd]} {
1347 return 1
1349 global commfd viewcomplete viewactive viewname
1350 global viewinstances
1351 unset commfd($inst)
1352 set i [lsearch -exact $viewinstances($view) $inst]
1353 if {$i >= 0} {
1354 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1356 # set it blocking so we wait for the process to terminate
1357 fconfigure $fd -blocking 1
1358 if {[catch {close $fd} err]} {
1359 set fv {}
1360 if {$view != $curview} {
1361 set fv " for the \"$viewname($view)\" view"
1363 if {[string range $err 0 4] == "usage"} {
1364 set err "Gitk: error reading commits$fv:\
1365 bad arguments to git log."
1366 if {$viewname($view) eq "Command line"} {
1367 append err \
1368 " (Note: arguments to gitk are passed to git log\
1369 to allow selection of commits to be displayed.)"
1371 } else {
1372 set err "Error reading commits$fv: $err"
1374 error_popup $err
1376 if {[incr viewactive($view) -1] <= 0} {
1377 set viewcomplete($view) 1
1378 # Check if we have seen any ids listed as parents that haven't
1379 # appeared in the list
1380 closevarcs $view
1381 notbusy $view
1383 if {$view == $curview} {
1384 run chewcommits
1386 return 0
1388 set start 0
1389 set gotsome 0
1390 set scripts {}
1391 while 1 {
1392 set i [string first "\0" $stuff $start]
1393 if {$i < 0} {
1394 append leftover($inst) [string range $stuff $start end]
1395 break
1397 if {$start == 0} {
1398 set cmit $leftover($inst)
1399 append cmit [string range $stuff 0 [expr {$i - 1}]]
1400 set leftover($inst) {}
1401 } else {
1402 set cmit [string range $stuff $start [expr {$i - 1}]]
1404 set start [expr {$i + 1}]
1405 set j [string first "\n" $cmit]
1406 set ok 0
1407 set listed 1
1408 if {$j >= 0 && [string match "commit *" $cmit]} {
1409 set ids [string range $cmit 7 [expr {$j - 1}]]
1410 if {[string match {[-^<>]*} $ids]} {
1411 switch -- [string index $ids 0] {
1412 "-" {set listed 0}
1413 "^" {set listed 2}
1414 "<" {set listed 3}
1415 ">" {set listed 4}
1417 set ids [string range $ids 1 end]
1419 set ok 1
1420 foreach id $ids {
1421 if {[string length $id] != 40} {
1422 set ok 0
1423 break
1427 if {!$ok} {
1428 set shortcmit $cmit
1429 if {[string length $shortcmit] > 80} {
1430 set shortcmit "[string range $shortcmit 0 80]..."
1432 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1433 exit 1
1435 set id [lindex $ids 0]
1436 set vid $view,$id
1438 if {!$listed && $updating && ![info exists varcid($vid)] &&
1439 $vfilelimit($view) ne {}} {
1440 # git log doesn't rewrite parents for unlisted commits
1441 # when doing path limiting, so work around that here
1442 # by working out the rewritten parent with git rev-list
1443 # and if we already know about it, using the rewritten
1444 # parent as a substitute parent for $id's children.
1445 if {![catch {
1446 set rwid [exec git rev-list --first-parent --max-count=1 \
1447 $id -- $vfilelimit($view)]
1448 }]} {
1449 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1450 # use $rwid in place of $id
1451 rewrite_commit $view $id $rwid
1452 continue
1457 set a 0
1458 if {[info exists varcid($vid)]} {
1459 if {$cmitlisted($vid) || !$listed} continue
1460 set a $varcid($vid)
1462 if {$listed} {
1463 set olds [lrange $ids 1 end]
1464 } else {
1465 set olds {}
1467 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1468 set cmitlisted($vid) $listed
1469 set parents($vid) $olds
1470 if {![info exists children($vid)]} {
1471 set children($vid) {}
1472 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1473 set k [lindex $children($vid) 0]
1474 if {[llength $parents($view,$k)] == 1 &&
1475 (!$vdatemode($view) ||
1476 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1477 set a $varcid($view,$k)
1480 if {$a == 0} {
1481 # new arc
1482 set a [newvarc $view $id]
1484 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1485 modify_arc $view $a
1487 if {![info exists varcid($vid)]} {
1488 set varcid($vid) $a
1489 lappend varccommits($view,$a) $id
1490 incr commitidx($view)
1493 set i 0
1494 foreach p $olds {
1495 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1496 set vp $view,$p
1497 if {[llength [lappend children($vp) $id]] > 1 &&
1498 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1499 set children($vp) [lsort -command [list vtokcmp $view] \
1500 $children($vp)]
1501 catch {unset ordertok}
1503 if {[info exists varcid($view,$p)]} {
1504 fix_reversal $p $a $view
1507 incr i
1510 set scripts [check_interest $id $scripts]
1511 set gotsome 1
1513 if {$gotsome} {
1514 global numcommits hlview
1516 if {$view == $curview} {
1517 set numcommits $commitidx($view)
1518 run chewcommits
1520 if {[info exists hlview] && $view == $hlview} {
1521 # we never actually get here...
1522 run vhighlightmore
1524 foreach s $scripts {
1525 eval $s
1528 return 2
1531 proc chewcommits {} {
1532 global curview hlview viewcomplete
1533 global pending_select
1535 layoutmore
1536 if {$viewcomplete($curview)} {
1537 global commitidx varctok
1538 global numcommits startmsecs
1540 if {[info exists pending_select]} {
1541 update
1542 reset_pending_select {}
1544 if {[commitinview $pending_select $curview]} {
1545 selectline [rowofcommit $pending_select] 1
1546 } else {
1547 set row [first_real_row]
1548 selectline $row 1
1551 if {$commitidx($curview) > 0} {
1552 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1553 #puts "overall $ms ms for $numcommits commits"
1554 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1555 } else {
1556 show_status [mc "No commits selected"]
1558 notbusy layout
1560 return 0
1563 proc do_readcommit {id} {
1564 global tclencoding
1566 # Invoke git-log to handle automatic encoding conversion
1567 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1568 # Read the results using i18n.logoutputencoding
1569 fconfigure $fd -translation lf -eofchar {}
1570 if {$tclencoding != {}} {
1571 fconfigure $fd -encoding $tclencoding
1573 set contents [read $fd]
1574 close $fd
1575 # Remove the heading line
1576 regsub {^commit [0-9a-f]+\n} $contents {} contents
1578 return $contents
1581 proc readcommit {id} {
1582 if {[catch {set contents [do_readcommit $id]}]} return
1583 parsecommit $id $contents 1
1586 proc parsecommit {id contents listed} {
1587 global commitinfo cdate
1589 set inhdr 1
1590 set comment {}
1591 set headline {}
1592 set auname {}
1593 set audate {}
1594 set comname {}
1595 set comdate {}
1596 set hdrend [string first "\n\n" $contents]
1597 if {$hdrend < 0} {
1598 # should never happen...
1599 set hdrend [string length $contents]
1601 set header [string range $contents 0 [expr {$hdrend - 1}]]
1602 set comment [string range $contents [expr {$hdrend + 2}] end]
1603 foreach line [split $header "\n"] {
1604 set tag [lindex $line 0]
1605 if {$tag == "author"} {
1606 set audate [lindex $line end-1]
1607 set auname [lrange $line 1 end-2]
1608 } elseif {$tag == "committer"} {
1609 set comdate [lindex $line end-1]
1610 set comname [lrange $line 1 end-2]
1613 set headline {}
1614 # take the first non-blank line of the comment as the headline
1615 set headline [string trimleft $comment]
1616 set i [string first "\n" $headline]
1617 if {$i >= 0} {
1618 set headline [string range $headline 0 $i]
1620 set headline [string trimright $headline]
1621 set i [string first "\r" $headline]
1622 if {$i >= 0} {
1623 set headline [string trimright [string range $headline 0 $i]]
1625 if {!$listed} {
1626 # git log indents the comment by 4 spaces;
1627 # if we got this via git cat-file, add the indentation
1628 set newcomment {}
1629 foreach line [split $comment "\n"] {
1630 append newcomment " "
1631 append newcomment $line
1632 append newcomment "\n"
1634 set comment $newcomment
1636 if {$comdate != {}} {
1637 set cdate($id) $comdate
1639 set commitinfo($id) [list $headline $auname $audate \
1640 $comname $comdate $comment]
1643 proc getcommit {id} {
1644 global commitdata commitinfo
1646 if {[info exists commitdata($id)]} {
1647 parsecommit $id $commitdata($id) 1
1648 } else {
1649 readcommit $id
1650 if {![info exists commitinfo($id)]} {
1651 set commitinfo($id) [list [mc "No commit information available"]]
1654 return 1
1657 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1658 # and are present in the current view.
1659 # This is fairly slow...
1660 proc longid {prefix} {
1661 global varcid curview
1663 set ids {}
1664 foreach match [array names varcid "$curview,$prefix*"] {
1665 lappend ids [lindex [split $match ","] 1]
1667 return $ids
1670 proc readrefs {} {
1671 global tagids idtags headids idheads tagobjid
1672 global otherrefids idotherrefs mainhead mainheadid
1673 global selecthead selectheadid
1675 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1676 catch {unset $v}
1678 set refd [open [list | git show-ref -d] r]
1679 while {[gets $refd line] >= 0} {
1680 if {[string index $line 40] ne " "} continue
1681 set id [string range $line 0 39]
1682 set ref [string range $line 41 end]
1683 if {![string match "refs/*" $ref]} continue
1684 set name [string range $ref 5 end]
1685 if {[string match "remotes/*" $name]} {
1686 if {![string match "*/HEAD" $name]} {
1687 set headids($name) $id
1688 lappend idheads($id) $name
1690 } elseif {[string match "heads/*" $name]} {
1691 set name [string range $name 6 end]
1692 set headids($name) $id
1693 lappend idheads($id) $name
1694 } elseif {[string match "tags/*" $name]} {
1695 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1696 # which is what we want since the former is the commit ID
1697 set name [string range $name 5 end]
1698 if {[string match "*^{}" $name]} {
1699 set name [string range $name 0 end-3]
1700 } else {
1701 set tagobjid($name) $id
1703 set tagids($name) $id
1704 lappend idtags($id) $name
1705 } else {
1706 set otherrefids($name) $id
1707 lappend idotherrefs($id) $name
1710 catch {close $refd}
1711 set mainhead {}
1712 set mainheadid {}
1713 catch {
1714 set mainheadid [exec git rev-parse HEAD]
1715 set thehead [exec git symbolic-ref HEAD]
1716 if {[string match "refs/heads/*" $thehead]} {
1717 set mainhead [string range $thehead 11 end]
1720 set selectheadid {}
1721 if {$selecthead ne {}} {
1722 catch {
1723 set selectheadid [exec git rev-parse --verify $selecthead]
1728 # skip over fake commits
1729 proc first_real_row {} {
1730 global nullid nullid2 numcommits
1732 for {set row 0} {$row < $numcommits} {incr row} {
1733 set id [commitonrow $row]
1734 if {$id ne $nullid && $id ne $nullid2} {
1735 break
1738 return $row
1741 # update things for a head moved to a child of its previous location
1742 proc movehead {id name} {
1743 global headids idheads
1745 removehead $headids($name) $name
1746 set headids($name) $id
1747 lappend idheads($id) $name
1750 # update things when a head has been removed
1751 proc removehead {id name} {
1752 global headids idheads
1754 if {$idheads($id) eq $name} {
1755 unset idheads($id)
1756 } else {
1757 set i [lsearch -exact $idheads($id) $name]
1758 if {$i >= 0} {
1759 set idheads($id) [lreplace $idheads($id) $i $i]
1762 unset headids($name)
1765 proc make_transient {window origin} {
1766 global have_tk85
1768 # In MacOS Tk 8.4 transient appears to work by setting
1769 # overrideredirect, which is utterly useless, since the
1770 # windows get no border, and are not even kept above
1771 # the parent.
1772 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1774 wm transient $window $origin
1776 # Windows fails to place transient windows normally, so
1777 # schedule a callback to center them on the parent.
1778 if {[tk windowingsystem] eq {win32}} {
1779 after idle [list tk::PlaceWindow $window widget $origin]
1783 proc show_error {w top msg} {
1784 message $w.m -text $msg -justify center -aspect 400
1785 pack $w.m -side top -fill x -padx 20 -pady 20
1786 button $w.ok -text [mc OK] -command "destroy $top"
1787 pack $w.ok -side bottom -fill x
1788 bind $top <Visibility> "grab $top; focus $top"
1789 bind $top <Key-Return> "destroy $top"
1790 bind $top <Key-space> "destroy $top"
1791 bind $top <Key-Escape> "destroy $top"
1792 tkwait window $top
1795 proc error_popup {msg {owner .}} {
1796 set w .error
1797 toplevel $w
1798 make_transient $w $owner
1799 show_error $w $w $msg
1802 proc confirm_popup {msg {owner .}} {
1803 global confirm_ok
1804 set confirm_ok 0
1805 set w .confirm
1806 toplevel $w
1807 make_transient $w $owner
1808 message $w.m -text $msg -justify center -aspect 400
1809 pack $w.m -side top -fill x -padx 20 -pady 20
1810 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1811 pack $w.ok -side left -fill x
1812 button $w.cancel -text [mc Cancel] -command "destroy $w"
1813 pack $w.cancel -side right -fill x
1814 bind $w <Visibility> "grab $w; focus $w"
1815 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1816 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1817 bind $w <Key-Escape> "destroy $w"
1818 tkwait window $w
1819 return $confirm_ok
1822 proc setoptions {} {
1823 option add *Panedwindow.showHandle 1 startupFile
1824 option add *Panedwindow.sashRelief raised startupFile
1825 option add *Button.font uifont startupFile
1826 option add *Checkbutton.font uifont startupFile
1827 option add *Radiobutton.font uifont startupFile
1828 option add *Menu.font uifont startupFile
1829 option add *Menubutton.font uifont startupFile
1830 option add *Label.font uifont startupFile
1831 option add *Message.font uifont startupFile
1832 option add *Entry.font uifont startupFile
1835 # Make a menu and submenus.
1836 # m is the window name for the menu, items is the list of menu items to add.
1837 # Each item is a list {mc label type description options...}
1838 # mc is ignored; it's so we can put mc there to alert xgettext
1839 # label is the string that appears in the menu
1840 # type is cascade, command or radiobutton (should add checkbutton)
1841 # description depends on type; it's the sublist for cascade, the
1842 # command to invoke for command, or {variable value} for radiobutton
1843 proc makemenu {m items} {
1844 menu $m
1845 if {[tk windowingsystem] eq {aqua}} {
1846 set Meta1 Cmd
1847 } else {
1848 set Meta1 Ctrl
1850 foreach i $items {
1851 set name [mc [lindex $i 1]]
1852 set type [lindex $i 2]
1853 set thing [lindex $i 3]
1854 set params [list $type]
1855 if {$name ne {}} {
1856 set u [string first "&" [string map {&& x} $name]]
1857 lappend params -label [string map {&& & & {}} $name]
1858 if {$u >= 0} {
1859 lappend params -underline $u
1862 switch -- $type {
1863 "cascade" {
1864 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1865 lappend params -menu $m.$submenu
1867 "command" {
1868 lappend params -command $thing
1870 "radiobutton" {
1871 lappend params -variable [lindex $thing 0] \
1872 -value [lindex $thing 1]
1875 set tail [lrange $i 4 end]
1876 regsub -all {\yMeta1\y} $tail $Meta1 tail
1877 eval $m add $params $tail
1878 if {$type eq "cascade"} {
1879 makemenu $m.$submenu $thing
1884 # translate string and remove ampersands
1885 proc mca {str} {
1886 return [string map {&& & & {}} [mc $str]]
1889 proc makewindow {} {
1890 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1891 global tabstop
1892 global findtype findtypemenu findloc findstring fstring geometry
1893 global entries sha1entry sha1string sha1but
1894 global diffcontextstring diffcontext
1895 global ignorespace
1896 global maincursor textcursor curtextcursor
1897 global rowctxmenu fakerowmenu mergemax wrapcomment
1898 global highlight_files gdttype
1899 global searchstring sstring
1900 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1901 global headctxmenu progresscanv progressitem progresscoords statusw
1902 global fprogitem fprogcoord lastprogupdate progupdatepending
1903 global rprogitem rprogcoord rownumsel numcommits
1904 global have_tk85
1906 # The "mc" arguments here are purely so that xgettext
1907 # sees the following string as needing to be translated
1908 makemenu .bar {
1909 {mc "File" cascade {
1910 {mc "Update" command updatecommits -accelerator F5}
1911 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1912 {mc "Reread references" command rereadrefs}
1913 {mc "List references" command showrefs -accelerator F2}
1914 {mc "Quit" command doquit -accelerator Meta1-Q}
1916 {mc "Edit" cascade {
1917 {mc "Preferences" command doprefs}
1919 {mc "View" cascade {
1920 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1921 {mc "Edit view..." command editview -state disabled -accelerator F4}
1922 {mc "Delete view" command delview -state disabled}
1923 {xx "" separator}
1924 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1926 {mc "Help" cascade {
1927 {mc "About gitk" command about}
1928 {mc "Key bindings" command keys}
1931 . configure -menu .bar
1933 # the gui has upper and lower half, parts of a paned window.
1934 panedwindow .ctop -orient vertical
1936 # possibly use assumed geometry
1937 if {![info exists geometry(pwsash0)]} {
1938 set geometry(topheight) [expr {15 * $linespc}]
1939 set geometry(topwidth) [expr {80 * $charspc}]
1940 set geometry(botheight) [expr {15 * $linespc}]
1941 set geometry(botwidth) [expr {50 * $charspc}]
1942 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1943 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1946 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1947 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1948 frame .tf.histframe
1949 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1951 # create three canvases
1952 set cscroll .tf.histframe.csb
1953 set canv .tf.histframe.pwclist.canv
1954 canvas $canv \
1955 -selectbackground $selectbgcolor \
1956 -background $bgcolor -bd 0 \
1957 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1958 .tf.histframe.pwclist add $canv
1959 set canv2 .tf.histframe.pwclist.canv2
1960 canvas $canv2 \
1961 -selectbackground $selectbgcolor \
1962 -background $bgcolor -bd 0 -yscrollincr $linespc
1963 .tf.histframe.pwclist add $canv2
1964 set canv3 .tf.histframe.pwclist.canv3
1965 canvas $canv3 \
1966 -selectbackground $selectbgcolor \
1967 -background $bgcolor -bd 0 -yscrollincr $linespc
1968 .tf.histframe.pwclist add $canv3
1969 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1970 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1972 # a scroll bar to rule them
1973 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1974 pack $cscroll -side right -fill y
1975 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1976 lappend bglist $canv $canv2 $canv3
1977 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1979 # we have two button bars at bottom of top frame. Bar 1
1980 frame .tf.bar
1981 frame .tf.lbar -height 15
1983 set sha1entry .tf.bar.sha1
1984 set entries $sha1entry
1985 set sha1but .tf.bar.sha1label
1986 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1987 -command gotocommit -width 8
1988 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1989 pack .tf.bar.sha1label -side left
1990 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1991 trace add variable sha1string write sha1change
1992 pack $sha1entry -side left -pady 2
1994 image create bitmap bm-left -data {
1995 #define left_width 16
1996 #define left_height 16
1997 static unsigned char left_bits[] = {
1998 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1999 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2000 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2002 image create bitmap bm-right -data {
2003 #define right_width 16
2004 #define right_height 16
2005 static unsigned char right_bits[] = {
2006 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2007 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2008 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2010 button .tf.bar.leftbut -image bm-left -command goback \
2011 -state disabled -width 26
2012 pack .tf.bar.leftbut -side left -fill y
2013 button .tf.bar.rightbut -image bm-right -command goforw \
2014 -state disabled -width 26
2015 pack .tf.bar.rightbut -side left -fill y
2017 label .tf.bar.rowlabel -text [mc "Row"]
2018 set rownumsel {}
2019 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2020 -relief sunken -anchor e
2021 label .tf.bar.rowlabel2 -text "/"
2022 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2023 -relief sunken -anchor e
2024 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2025 -side left
2026 global selectedline
2027 trace add variable selectedline write selectedline_change
2029 # Status label and progress bar
2030 set statusw .tf.bar.status
2031 label $statusw -width 15 -relief sunken
2032 pack $statusw -side left -padx 5
2033 set h [expr {[font metrics uifont -linespace] + 2}]
2034 set progresscanv .tf.bar.progress
2035 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2036 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2037 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2038 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2039 pack $progresscanv -side right -expand 1 -fill x
2040 set progresscoords {0 0}
2041 set fprogcoord 0
2042 set rprogcoord 0
2043 bind $progresscanv <Configure> adjustprogress
2044 set lastprogupdate [clock clicks -milliseconds]
2045 set progupdatepending 0
2047 # build up the bottom bar of upper window
2048 label .tf.lbar.flabel -text "[mc "Find"] "
2049 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2050 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2051 label .tf.lbar.flab2 -text " [mc "commit"] "
2052 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2053 -side left -fill y
2054 set gdttype [mc "containing:"]
2055 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2056 [mc "containing:"] \
2057 [mc "touching paths:"] \
2058 [mc "adding/removing string:"]]
2059 trace add variable gdttype write gdttype_change
2060 pack .tf.lbar.gdttype -side left -fill y
2062 set findstring {}
2063 set fstring .tf.lbar.findstring
2064 lappend entries $fstring
2065 entry $fstring -width 30 -font textfont -textvariable findstring
2066 trace add variable findstring write find_change
2067 set findtype [mc "Exact"]
2068 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2069 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2070 trace add variable findtype write findcom_change
2071 set findloc [mc "All fields"]
2072 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2073 [mc "Comments"] [mc "Author"] [mc "Committer"]
2074 trace add variable findloc write find_change
2075 pack .tf.lbar.findloc -side right
2076 pack .tf.lbar.findtype -side right
2077 pack $fstring -side left -expand 1 -fill x
2079 # Finish putting the upper half of the viewer together
2080 pack .tf.lbar -in .tf -side bottom -fill x
2081 pack .tf.bar -in .tf -side bottom -fill x
2082 pack .tf.histframe -fill both -side top -expand 1
2083 .ctop add .tf
2084 .ctop paneconfigure .tf -height $geometry(topheight)
2085 .ctop paneconfigure .tf -width $geometry(topwidth)
2087 # now build up the bottom
2088 panedwindow .pwbottom -orient horizontal
2090 # lower left, a text box over search bar, scroll bar to the right
2091 # if we know window height, then that will set the lower text height, otherwise
2092 # we set lower text height which will drive window height
2093 if {[info exists geometry(main)]} {
2094 frame .bleft -width $geometry(botwidth)
2095 } else {
2096 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2098 frame .bleft.top
2099 frame .bleft.mid
2100 frame .bleft.bottom
2102 button .bleft.top.search -text [mc "Search"] -command dosearch
2103 pack .bleft.top.search -side left -padx 5
2104 set sstring .bleft.top.sstring
2105 entry $sstring -width 20 -font textfont -textvariable searchstring
2106 lappend entries $sstring
2107 trace add variable searchstring write incrsearch
2108 pack $sstring -side left -expand 1 -fill x
2109 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2110 -command changediffdisp -variable diffelide -value {0 0}
2111 radiobutton .bleft.mid.old -text [mc "Old version"] \
2112 -command changediffdisp -variable diffelide -value {0 1}
2113 radiobutton .bleft.mid.new -text [mc "New version"] \
2114 -command changediffdisp -variable diffelide -value {1 0}
2115 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2116 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2117 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2118 -from 1 -increment 1 -to 10000000 \
2119 -validate all -validatecommand "diffcontextvalidate %P" \
2120 -textvariable diffcontextstring
2121 .bleft.mid.diffcontext set $diffcontext
2122 trace add variable diffcontextstring write diffcontextchange
2123 lappend entries .bleft.mid.diffcontext
2124 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2125 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2126 -command changeignorespace -variable ignorespace
2127 pack .bleft.mid.ignspace -side left -padx 5
2128 set ctext .bleft.bottom.ctext
2129 text $ctext -background $bgcolor -foreground $fgcolor \
2130 -state disabled -font textfont \
2131 -yscrollcommand scrolltext -wrap none \
2132 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2133 if {$have_tk85} {
2134 $ctext conf -tabstyle wordprocessor
2136 scrollbar .bleft.bottom.sb -command "$ctext yview"
2137 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2138 -width 10
2139 pack .bleft.top -side top -fill x
2140 pack .bleft.mid -side top -fill x
2141 grid $ctext .bleft.bottom.sb -sticky nsew
2142 grid .bleft.bottom.sbhorizontal -sticky ew
2143 grid columnconfigure .bleft.bottom 0 -weight 1
2144 grid rowconfigure .bleft.bottom 0 -weight 1
2145 grid rowconfigure .bleft.bottom 1 -weight 0
2146 pack .bleft.bottom -side top -fill both -expand 1
2147 lappend bglist $ctext
2148 lappend fglist $ctext
2150 $ctext tag conf comment -wrap $wrapcomment
2151 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2152 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2153 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2154 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2155 $ctext tag conf m0 -fore red
2156 $ctext tag conf m1 -fore blue
2157 $ctext tag conf m2 -fore green
2158 $ctext tag conf m3 -fore purple
2159 $ctext tag conf m4 -fore brown
2160 $ctext tag conf m5 -fore "#009090"
2161 $ctext tag conf m6 -fore magenta
2162 $ctext tag conf m7 -fore "#808000"
2163 $ctext tag conf m8 -fore "#009000"
2164 $ctext tag conf m9 -fore "#ff0080"
2165 $ctext tag conf m10 -fore cyan
2166 $ctext tag conf m11 -fore "#b07070"
2167 $ctext tag conf m12 -fore "#70b0f0"
2168 $ctext tag conf m13 -fore "#70f0b0"
2169 $ctext tag conf m14 -fore "#f0b070"
2170 $ctext tag conf m15 -fore "#ff70b0"
2171 $ctext tag conf mmax -fore darkgrey
2172 set mergemax 16
2173 $ctext tag conf mresult -font textfontbold
2174 $ctext tag conf msep -font textfontbold
2175 $ctext tag conf found -back yellow
2177 .pwbottom add .bleft
2178 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2180 # lower right
2181 frame .bright
2182 frame .bright.mode
2183 radiobutton .bright.mode.patch -text [mc "Patch"] \
2184 -command reselectline -variable cmitmode -value "patch"
2185 radiobutton .bright.mode.tree -text [mc "Tree"] \
2186 -command reselectline -variable cmitmode -value "tree"
2187 grid .bright.mode.patch .bright.mode.tree -sticky ew
2188 pack .bright.mode -side top -fill x
2189 set cflist .bright.cfiles
2190 set indent [font measure mainfont "nn"]
2191 text $cflist \
2192 -selectbackground $selectbgcolor \
2193 -background $bgcolor -foreground $fgcolor \
2194 -font mainfont \
2195 -tabs [list $indent [expr {2 * $indent}]] \
2196 -yscrollcommand ".bright.sb set" \
2197 -cursor [. cget -cursor] \
2198 -spacing1 1 -spacing3 1
2199 lappend bglist $cflist
2200 lappend fglist $cflist
2201 scrollbar .bright.sb -command "$cflist yview"
2202 pack .bright.sb -side right -fill y
2203 pack $cflist -side left -fill both -expand 1
2204 $cflist tag configure highlight \
2205 -background [$cflist cget -selectbackground]
2206 $cflist tag configure bold -font mainfontbold
2208 .pwbottom add .bright
2209 .ctop add .pwbottom
2211 # restore window width & height if known
2212 if {[info exists geometry(main)]} {
2213 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2214 if {$w > [winfo screenwidth .]} {
2215 set w [winfo screenwidth .]
2217 if {$h > [winfo screenheight .]} {
2218 set h [winfo screenheight .]
2220 wm geometry . "${w}x$h"
2224 if {[tk windowingsystem] eq {aqua}} {
2225 set M1B M1
2226 } else {
2227 set M1B Control
2230 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2231 pack .ctop -fill both -expand 1
2232 bindall <1> {selcanvline %W %x %y}
2233 #bindall <B1-Motion> {selcanvline %W %x %y}
2234 if {[tk windowingsystem] == "win32"} {
2235 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2236 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2237 } else {
2238 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2239 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2240 if {[tk windowingsystem] eq "aqua"} {
2241 bindall <MouseWheel> {
2242 set delta [expr {- (%D)}]
2243 allcanvs yview scroll $delta units
2247 bindall <2> "canvscan mark %W %x %y"
2248 bindall <B2-Motion> "canvscan dragto %W %x %y"
2249 bindkey <Home> selfirstline
2250 bindkey <End> sellastline
2251 bind . <Key-Up> "selnextline -1"
2252 bind . <Key-Down> "selnextline 1"
2253 bind . <Shift-Key-Up> "dofind -1 0"
2254 bind . <Shift-Key-Down> "dofind 1 0"
2255 bindkey <Key-Right> "goforw"
2256 bindkey <Key-Left> "goback"
2257 bind . <Key-Prior> "selnextpage -1"
2258 bind . <Key-Next> "selnextpage 1"
2259 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2260 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2261 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2262 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2263 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2264 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2265 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2266 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2267 bindkey <Key-space> "$ctext yview scroll 1 pages"
2268 bindkey p "selnextline -1"
2269 bindkey n "selnextline 1"
2270 bindkey z "goback"
2271 bindkey x "goforw"
2272 bindkey i "selnextline -1"
2273 bindkey k "selnextline 1"
2274 bindkey j "goback"
2275 bindkey l "goforw"
2276 bindkey b prevfile
2277 bindkey d "$ctext yview scroll 18 units"
2278 bindkey u "$ctext yview scroll -18 units"
2279 bindkey / {dofind 1 1}
2280 bindkey <Key-Return> {dofind 1 1}
2281 bindkey ? {dofind -1 1}
2282 bindkey f nextfile
2283 bind . <F5> updatecommits
2284 bind . <$M1B-F5> reloadcommits
2285 bind . <F2> showrefs
2286 bind . <Shift-F4> {newview 0}
2287 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2288 bind . <F4> edit_or_newview
2289 bind . <$M1B-q> doquit
2290 bind . <$M1B-f> {dofind 1 1}
2291 bind . <$M1B-g> {dofind 1 0}
2292 bind . <$M1B-r> dosearchback
2293 bind . <$M1B-s> dosearch
2294 bind . <$M1B-equal> {incrfont 1}
2295 bind . <$M1B-plus> {incrfont 1}
2296 bind . <$M1B-KP_Add> {incrfont 1}
2297 bind . <$M1B-minus> {incrfont -1}
2298 bind . <$M1B-KP_Subtract> {incrfont -1}
2299 wm protocol . WM_DELETE_WINDOW doquit
2300 bind . <Destroy> {stop_backends}
2301 bind . <Button-1> "click %W"
2302 bind $fstring <Key-Return> {dofind 1 1}
2303 bind $sha1entry <Key-Return> {gotocommit; break}
2304 bind $sha1entry <<PasteSelection>> clearsha1
2305 bind $cflist <1> {sel_flist %W %x %y; break}
2306 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2307 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2308 global ctxbut
2309 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2310 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2312 set maincursor [. cget -cursor]
2313 set textcursor [$ctext cget -cursor]
2314 set curtextcursor $textcursor
2316 set rowctxmenu .rowctxmenu
2317 makemenu $rowctxmenu {
2318 {mc "Diff this -> selected" command {diffvssel 0}}
2319 {mc "Diff selected -> this" command {diffvssel 1}}
2320 {mc "Make patch" command mkpatch}
2321 {mc "Create tag" command mktag}
2322 {mc "Write commit to file" command writecommit}
2323 {mc "Create new branch" command mkbranch}
2324 {mc "Cherry-pick this commit" command cherrypick}
2325 {mc "Reset HEAD branch to here" command resethead}
2327 $rowctxmenu configure -tearoff 0
2329 set fakerowmenu .fakerowmenu
2330 makemenu $fakerowmenu {
2331 {mc "Diff this -> selected" command {diffvssel 0}}
2332 {mc "Diff selected -> this" command {diffvssel 1}}
2333 {mc "Make patch" command mkpatch}
2335 $fakerowmenu configure -tearoff 0
2337 set headctxmenu .headctxmenu
2338 makemenu $headctxmenu {
2339 {mc "Check out this branch" command cobranch}
2340 {mc "Remove this branch" command rmbranch}
2342 $headctxmenu configure -tearoff 0
2344 global flist_menu
2345 set flist_menu .flistctxmenu
2346 makemenu $flist_menu {
2347 {mc "Highlight this too" command {flist_hl 0}}
2348 {mc "Highlight this only" command {flist_hl 1}}
2349 {mc "External diff" command {external_diff}}
2350 {mc "Blame parent commit" command {external_blame 1}}
2352 $flist_menu configure -tearoff 0
2354 global diff_menu
2355 set diff_menu .diffctxmenu
2356 makemenu $diff_menu {
2357 {mc "Show origin of this line" command show_line_source}
2358 {mc "Run git gui blame on this line" command {external_blame_diff}}
2360 $diff_menu configure -tearoff 0
2363 # Windows sends all mouse wheel events to the current focused window, not
2364 # the one where the mouse hovers, so bind those events here and redirect
2365 # to the correct window
2366 proc windows_mousewheel_redirector {W X Y D} {
2367 global canv canv2 canv3
2368 set w [winfo containing -displayof $W $X $Y]
2369 if {$w ne ""} {
2370 set u [expr {$D < 0 ? 5 : -5}]
2371 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2372 allcanvs yview scroll $u units
2373 } else {
2374 catch {
2375 $w yview scroll $u units
2381 # Update row number label when selectedline changes
2382 proc selectedline_change {n1 n2 op} {
2383 global selectedline rownumsel
2385 if {$selectedline eq {}} {
2386 set rownumsel {}
2387 } else {
2388 set rownumsel [expr {$selectedline + 1}]
2392 # mouse-2 makes all windows scan vertically, but only the one
2393 # the cursor is in scans horizontally
2394 proc canvscan {op w x y} {
2395 global canv canv2 canv3
2396 foreach c [list $canv $canv2 $canv3] {
2397 if {$c == $w} {
2398 $c scan $op $x $y
2399 } else {
2400 $c scan $op 0 $y
2405 proc scrollcanv {cscroll f0 f1} {
2406 $cscroll set $f0 $f1
2407 drawvisible
2408 flushhighlights
2411 # when we make a key binding for the toplevel, make sure
2412 # it doesn't get triggered when that key is pressed in the
2413 # find string entry widget.
2414 proc bindkey {ev script} {
2415 global entries
2416 bind . $ev $script
2417 set escript [bind Entry $ev]
2418 if {$escript == {}} {
2419 set escript [bind Entry <Key>]
2421 foreach e $entries {
2422 bind $e $ev "$escript; break"
2426 # set the focus back to the toplevel for any click outside
2427 # the entry widgets
2428 proc click {w} {
2429 global ctext entries
2430 foreach e [concat $entries $ctext] {
2431 if {$w == $e} return
2433 focus .
2436 # Adjust the progress bar for a change in requested extent or canvas size
2437 proc adjustprogress {} {
2438 global progresscanv progressitem progresscoords
2439 global fprogitem fprogcoord lastprogupdate progupdatepending
2440 global rprogitem rprogcoord
2442 set w [expr {[winfo width $progresscanv] - 4}]
2443 set x0 [expr {$w * [lindex $progresscoords 0]}]
2444 set x1 [expr {$w * [lindex $progresscoords 1]}]
2445 set h [winfo height $progresscanv]
2446 $progresscanv coords $progressitem $x0 0 $x1 $h
2447 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2448 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2449 set now [clock clicks -milliseconds]
2450 if {$now >= $lastprogupdate + 100} {
2451 set progupdatepending 0
2452 update
2453 } elseif {!$progupdatepending} {
2454 set progupdatepending 1
2455 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2459 proc doprogupdate {} {
2460 global lastprogupdate progupdatepending
2462 if {$progupdatepending} {
2463 set progupdatepending 0
2464 set lastprogupdate [clock clicks -milliseconds]
2465 update
2469 proc savestuff {w} {
2470 global canv canv2 canv3 mainfont textfont uifont tabstop
2471 global stuffsaved findmergefiles maxgraphpct
2472 global maxwidth showneartags showlocalchanges
2473 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2474 global cmitmode wrapcomment datetimeformat limitdiffs
2475 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2476 global autoselect extdifftool perfile_attrs markbgcolor
2478 if {$stuffsaved} return
2479 if {![winfo viewable .]} return
2480 catch {
2481 set f [open "~/.gitk-new" w]
2482 puts $f [list set mainfont $mainfont]
2483 puts $f [list set textfont $textfont]
2484 puts $f [list set uifont $uifont]
2485 puts $f [list set tabstop $tabstop]
2486 puts $f [list set findmergefiles $findmergefiles]
2487 puts $f [list set maxgraphpct $maxgraphpct]
2488 puts $f [list set maxwidth $maxwidth]
2489 puts $f [list set cmitmode $cmitmode]
2490 puts $f [list set wrapcomment $wrapcomment]
2491 puts $f [list set autoselect $autoselect]
2492 puts $f [list set showneartags $showneartags]
2493 puts $f [list set showlocalchanges $showlocalchanges]
2494 puts $f [list set datetimeformat $datetimeformat]
2495 puts $f [list set limitdiffs $limitdiffs]
2496 puts $f [list set bgcolor $bgcolor]
2497 puts $f [list set fgcolor $fgcolor]
2498 puts $f [list set colors $colors]
2499 puts $f [list set diffcolors $diffcolors]
2500 puts $f [list set markbgcolor $markbgcolor]
2501 puts $f [list set diffcontext $diffcontext]
2502 puts $f [list set selectbgcolor $selectbgcolor]
2503 puts $f [list set extdifftool $extdifftool]
2504 puts $f [list set perfile_attrs $perfile_attrs]
2506 puts $f "set geometry(main) [wm geometry .]"
2507 puts $f "set geometry(topwidth) [winfo width .tf]"
2508 puts $f "set geometry(topheight) [winfo height .tf]"
2509 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2510 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2511 puts $f "set geometry(botwidth) [winfo width .bleft]"
2512 puts $f "set geometry(botheight) [winfo height .bleft]"
2514 puts -nonewline $f "set permviews {"
2515 for {set v 0} {$v < $nextviewnum} {incr v} {
2516 if {$viewperm($v)} {
2517 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2520 puts $f "}"
2521 close $f
2522 file rename -force "~/.gitk-new" "~/.gitk"
2524 set stuffsaved 1
2527 proc resizeclistpanes {win w} {
2528 global oldwidth
2529 if {[info exists oldwidth($win)]} {
2530 set s0 [$win sash coord 0]
2531 set s1 [$win sash coord 1]
2532 if {$w < 60} {
2533 set sash0 [expr {int($w/2 - 2)}]
2534 set sash1 [expr {int($w*5/6 - 2)}]
2535 } else {
2536 set factor [expr {1.0 * $w / $oldwidth($win)}]
2537 set sash0 [expr {int($factor * [lindex $s0 0])}]
2538 set sash1 [expr {int($factor * [lindex $s1 0])}]
2539 if {$sash0 < 30} {
2540 set sash0 30
2542 if {$sash1 < $sash0 + 20} {
2543 set sash1 [expr {$sash0 + 20}]
2545 if {$sash1 > $w - 10} {
2546 set sash1 [expr {$w - 10}]
2547 if {$sash0 > $sash1 - 20} {
2548 set sash0 [expr {$sash1 - 20}]
2552 $win sash place 0 $sash0 [lindex $s0 1]
2553 $win sash place 1 $sash1 [lindex $s1 1]
2555 set oldwidth($win) $w
2558 proc resizecdetpanes {win w} {
2559 global oldwidth
2560 if {[info exists oldwidth($win)]} {
2561 set s0 [$win sash coord 0]
2562 if {$w < 60} {
2563 set sash0 [expr {int($w*3/4 - 2)}]
2564 } else {
2565 set factor [expr {1.0 * $w / $oldwidth($win)}]
2566 set sash0 [expr {int($factor * [lindex $s0 0])}]
2567 if {$sash0 < 45} {
2568 set sash0 45
2570 if {$sash0 > $w - 15} {
2571 set sash0 [expr {$w - 15}]
2574 $win sash place 0 $sash0 [lindex $s0 1]
2576 set oldwidth($win) $w
2579 proc allcanvs args {
2580 global canv canv2 canv3
2581 eval $canv $args
2582 eval $canv2 $args
2583 eval $canv3 $args
2586 proc bindall {event action} {
2587 global canv canv2 canv3
2588 bind $canv $event $action
2589 bind $canv2 $event $action
2590 bind $canv3 $event $action
2593 proc about {} {
2594 global uifont
2595 set w .about
2596 if {[winfo exists $w]} {
2597 raise $w
2598 return
2600 toplevel $w
2601 wm title $w [mc "About gitk"]
2602 make_transient $w .
2603 message $w.m -text [mc "
2604 Gitk - a commit viewer for git
2606 Copyright © 2005-2008 Paul Mackerras
2608 Use and redistribute under the terms of the GNU General Public License"] \
2609 -justify center -aspect 400 -border 2 -bg white -relief groove
2610 pack $w.m -side top -fill x -padx 2 -pady 2
2611 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2612 pack $w.ok -side bottom
2613 bind $w <Visibility> "focus $w.ok"
2614 bind $w <Key-Escape> "destroy $w"
2615 bind $w <Key-Return> "destroy $w"
2618 proc keys {} {
2619 set w .keys
2620 if {[winfo exists $w]} {
2621 raise $w
2622 return
2624 if {[tk windowingsystem] eq {aqua}} {
2625 set M1T Cmd
2626 } else {
2627 set M1T Ctrl
2629 toplevel $w
2630 wm title $w [mc "Gitk key bindings"]
2631 make_transient $w .
2632 message $w.m -text "
2633 [mc "Gitk key bindings:"]
2635 [mc "<%s-Q> Quit" $M1T]
2636 [mc "<Home> Move to first commit"]
2637 [mc "<End> Move to last commit"]
2638 [mc "<Up>, p, i Move up one commit"]
2639 [mc "<Down>, n, k Move down one commit"]
2640 [mc "<Left>, z, j Go back in history list"]
2641 [mc "<Right>, x, l Go forward in history list"]
2642 [mc "<PageUp> Move up one page in commit list"]
2643 [mc "<PageDown> Move down one page in commit list"]
2644 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2645 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2646 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2647 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2648 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2649 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2650 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2651 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2652 [mc "<Delete>, b Scroll diff view up one page"]
2653 [mc "<Backspace> Scroll diff view up one page"]
2654 [mc "<Space> Scroll diff view down one page"]
2655 [mc "u Scroll diff view up 18 lines"]
2656 [mc "d Scroll diff view down 18 lines"]
2657 [mc "<%s-F> Find" $M1T]
2658 [mc "<%s-G> Move to next find hit" $M1T]
2659 [mc "<Return> Move to next find hit"]
2660 [mc "/ Move to next find hit, or redo find"]
2661 [mc "? Move to previous find hit"]
2662 [mc "f Scroll diff view to next file"]
2663 [mc "<%s-S> Search for next hit in diff view" $M1T]
2664 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2665 [mc "<%s-KP+> Increase font size" $M1T]
2666 [mc "<%s-plus> Increase font size" $M1T]
2667 [mc "<%s-KP-> Decrease font size" $M1T]
2668 [mc "<%s-minus> Decrease font size" $M1T]
2669 [mc "<F5> Update"]
2671 -justify left -bg white -border 2 -relief groove
2672 pack $w.m -side top -fill both -padx 2 -pady 2
2673 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2674 bind $w <Key-Escape> [list destroy $w]
2675 pack $w.ok -side bottom
2676 bind $w <Visibility> "focus $w.ok"
2677 bind $w <Key-Escape> "destroy $w"
2678 bind $w <Key-Return> "destroy $w"
2681 # Procedures for manipulating the file list window at the
2682 # bottom right of the overall window.
2684 proc treeview {w l openlevs} {
2685 global treecontents treediropen treeheight treeparent treeindex
2687 set ix 0
2688 set treeindex() 0
2689 set lev 0
2690 set prefix {}
2691 set prefixend -1
2692 set prefendstack {}
2693 set htstack {}
2694 set ht 0
2695 set treecontents() {}
2696 $w conf -state normal
2697 foreach f $l {
2698 while {[string range $f 0 $prefixend] ne $prefix} {
2699 if {$lev <= $openlevs} {
2700 $w mark set e:$treeindex($prefix) "end -1c"
2701 $w mark gravity e:$treeindex($prefix) left
2703 set treeheight($prefix) $ht
2704 incr ht [lindex $htstack end]
2705 set htstack [lreplace $htstack end end]
2706 set prefixend [lindex $prefendstack end]
2707 set prefendstack [lreplace $prefendstack end end]
2708 set prefix [string range $prefix 0 $prefixend]
2709 incr lev -1
2711 set tail [string range $f [expr {$prefixend+1}] end]
2712 while {[set slash [string first "/" $tail]] >= 0} {
2713 lappend htstack $ht
2714 set ht 0
2715 lappend prefendstack $prefixend
2716 incr prefixend [expr {$slash + 1}]
2717 set d [string range $tail 0 $slash]
2718 lappend treecontents($prefix) $d
2719 set oldprefix $prefix
2720 append prefix $d
2721 set treecontents($prefix) {}
2722 set treeindex($prefix) [incr ix]
2723 set treeparent($prefix) $oldprefix
2724 set tail [string range $tail [expr {$slash+1}] end]
2725 if {$lev <= $openlevs} {
2726 set ht 1
2727 set treediropen($prefix) [expr {$lev < $openlevs}]
2728 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2729 $w mark set d:$ix "end -1c"
2730 $w mark gravity d:$ix left
2731 set str "\n"
2732 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2733 $w insert end $str
2734 $w image create end -align center -image $bm -padx 1 \
2735 -name a:$ix
2736 $w insert end $d [highlight_tag $prefix]
2737 $w mark set s:$ix "end -1c"
2738 $w mark gravity s:$ix left
2740 incr lev
2742 if {$tail ne {}} {
2743 if {$lev <= $openlevs} {
2744 incr ht
2745 set str "\n"
2746 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2747 $w insert end $str
2748 $w insert end $tail [highlight_tag $f]
2750 lappend treecontents($prefix) $tail
2753 while {$htstack ne {}} {
2754 set treeheight($prefix) $ht
2755 incr ht [lindex $htstack end]
2756 set htstack [lreplace $htstack end end]
2757 set prefixend [lindex $prefendstack end]
2758 set prefendstack [lreplace $prefendstack end end]
2759 set prefix [string range $prefix 0 $prefixend]
2761 $w conf -state disabled
2764 proc linetoelt {l} {
2765 global treeheight treecontents
2767 set y 2
2768 set prefix {}
2769 while {1} {
2770 foreach e $treecontents($prefix) {
2771 if {$y == $l} {
2772 return "$prefix$e"
2774 set n 1
2775 if {[string index $e end] eq "/"} {
2776 set n $treeheight($prefix$e)
2777 if {$y + $n > $l} {
2778 append prefix $e
2779 incr y
2780 break
2783 incr y $n
2788 proc highlight_tree {y prefix} {
2789 global treeheight treecontents cflist
2791 foreach e $treecontents($prefix) {
2792 set path $prefix$e
2793 if {[highlight_tag $path] ne {}} {
2794 $cflist tag add bold $y.0 "$y.0 lineend"
2796 incr y
2797 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2798 set y [highlight_tree $y $path]
2801 return $y
2804 proc treeclosedir {w dir} {
2805 global treediropen treeheight treeparent treeindex
2807 set ix $treeindex($dir)
2808 $w conf -state normal
2809 $w delete s:$ix e:$ix
2810 set treediropen($dir) 0
2811 $w image configure a:$ix -image tri-rt
2812 $w conf -state disabled
2813 set n [expr {1 - $treeheight($dir)}]
2814 while {$dir ne {}} {
2815 incr treeheight($dir) $n
2816 set dir $treeparent($dir)
2820 proc treeopendir {w dir} {
2821 global treediropen treeheight treeparent treecontents treeindex
2823 set ix $treeindex($dir)
2824 $w conf -state normal
2825 $w image configure a:$ix -image tri-dn
2826 $w mark set e:$ix s:$ix
2827 $w mark gravity e:$ix right
2828 set lev 0
2829 set str "\n"
2830 set n [llength $treecontents($dir)]
2831 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2832 incr lev
2833 append str "\t"
2834 incr treeheight($x) $n
2836 foreach e $treecontents($dir) {
2837 set de $dir$e
2838 if {[string index $e end] eq "/"} {
2839 set iy $treeindex($de)
2840 $w mark set d:$iy e:$ix
2841 $w mark gravity d:$iy left
2842 $w insert e:$ix $str
2843 set treediropen($de) 0
2844 $w image create e:$ix -align center -image tri-rt -padx 1 \
2845 -name a:$iy
2846 $w insert e:$ix $e [highlight_tag $de]
2847 $w mark set s:$iy e:$ix
2848 $w mark gravity s:$iy left
2849 set treeheight($de) 1
2850 } else {
2851 $w insert e:$ix $str
2852 $w insert e:$ix $e [highlight_tag $de]
2855 $w mark gravity e:$ix right
2856 $w conf -state disabled
2857 set treediropen($dir) 1
2858 set top [lindex [split [$w index @0,0] .] 0]
2859 set ht [$w cget -height]
2860 set l [lindex [split [$w index s:$ix] .] 0]
2861 if {$l < $top} {
2862 $w yview $l.0
2863 } elseif {$l + $n + 1 > $top + $ht} {
2864 set top [expr {$l + $n + 2 - $ht}]
2865 if {$l < $top} {
2866 set top $l
2868 $w yview $top.0
2872 proc treeclick {w x y} {
2873 global treediropen cmitmode ctext cflist cflist_top
2875 if {$cmitmode ne "tree"} return
2876 if {![info exists cflist_top]} return
2877 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2878 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2879 $cflist tag add highlight $l.0 "$l.0 lineend"
2880 set cflist_top $l
2881 if {$l == 1} {
2882 $ctext yview 1.0
2883 return
2885 set e [linetoelt $l]
2886 if {[string index $e end] ne "/"} {
2887 showfile $e
2888 } elseif {$treediropen($e)} {
2889 treeclosedir $w $e
2890 } else {
2891 treeopendir $w $e
2895 proc setfilelist {id} {
2896 global treefilelist cflist jump_to_here
2898 treeview $cflist $treefilelist($id) 0
2899 if {$jump_to_here ne {}} {
2900 set f [lindex $jump_to_here 0]
2901 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2902 showfile $f
2907 image create bitmap tri-rt -background black -foreground blue -data {
2908 #define tri-rt_width 13
2909 #define tri-rt_height 13
2910 static unsigned char tri-rt_bits[] = {
2911 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2912 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2913 0x00, 0x00};
2914 } -maskdata {
2915 #define tri-rt-mask_width 13
2916 #define tri-rt-mask_height 13
2917 static unsigned char tri-rt-mask_bits[] = {
2918 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2919 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2920 0x08, 0x00};
2922 image create bitmap tri-dn -background black -foreground blue -data {
2923 #define tri-dn_width 13
2924 #define tri-dn_height 13
2925 static unsigned char tri-dn_bits[] = {
2926 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2927 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2928 0x00, 0x00};
2929 } -maskdata {
2930 #define tri-dn-mask_width 13
2931 #define tri-dn-mask_height 13
2932 static unsigned char tri-dn-mask_bits[] = {
2933 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2934 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2935 0x00, 0x00};
2938 image create bitmap reficon-T -background black -foreground yellow -data {
2939 #define tagicon_width 13
2940 #define tagicon_height 9
2941 static unsigned char tagicon_bits[] = {
2942 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2943 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2944 } -maskdata {
2945 #define tagicon-mask_width 13
2946 #define tagicon-mask_height 9
2947 static unsigned char tagicon-mask_bits[] = {
2948 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2949 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2951 set rectdata {
2952 #define headicon_width 13
2953 #define headicon_height 9
2954 static unsigned char headicon_bits[] = {
2955 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2956 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2958 set rectmask {
2959 #define headicon-mask_width 13
2960 #define headicon-mask_height 9
2961 static unsigned char headicon-mask_bits[] = {
2962 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2963 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2965 image create bitmap reficon-H -background black -foreground green \
2966 -data $rectdata -maskdata $rectmask
2967 image create bitmap reficon-o -background black -foreground "#ddddff" \
2968 -data $rectdata -maskdata $rectmask
2970 proc init_flist {first} {
2971 global cflist cflist_top difffilestart
2973 $cflist conf -state normal
2974 $cflist delete 0.0 end
2975 if {$first ne {}} {
2976 $cflist insert end $first
2977 set cflist_top 1
2978 $cflist tag add highlight 1.0 "1.0 lineend"
2979 } else {
2980 catch {unset cflist_top}
2982 $cflist conf -state disabled
2983 set difffilestart {}
2986 proc highlight_tag {f} {
2987 global highlight_paths
2989 foreach p $highlight_paths {
2990 if {[string match $p $f]} {
2991 return "bold"
2994 return {}
2997 proc highlight_filelist {} {
2998 global cmitmode cflist
3000 $cflist conf -state normal
3001 if {$cmitmode ne "tree"} {
3002 set end [lindex [split [$cflist index end] .] 0]
3003 for {set l 2} {$l < $end} {incr l} {
3004 set line [$cflist get $l.0 "$l.0 lineend"]
3005 if {[highlight_tag $line] ne {}} {
3006 $cflist tag add bold $l.0 "$l.0 lineend"
3009 } else {
3010 highlight_tree 2 {}
3012 $cflist conf -state disabled
3015 proc unhighlight_filelist {} {
3016 global cflist
3018 $cflist conf -state normal
3019 $cflist tag remove bold 1.0 end
3020 $cflist conf -state disabled
3023 proc add_flist {fl} {
3024 global cflist
3026 $cflist conf -state normal
3027 foreach f $fl {
3028 $cflist insert end "\n"
3029 $cflist insert end $f [highlight_tag $f]
3031 $cflist conf -state disabled
3034 proc sel_flist {w x y} {
3035 global ctext difffilestart cflist cflist_top cmitmode
3037 if {$cmitmode eq "tree"} return
3038 if {![info exists cflist_top]} return
3039 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3040 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3041 $cflist tag add highlight $l.0 "$l.0 lineend"
3042 set cflist_top $l
3043 if {$l == 1} {
3044 $ctext yview 1.0
3045 } else {
3046 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3050 proc pop_flist_menu {w X Y x y} {
3051 global ctext cflist cmitmode flist_menu flist_menu_file
3052 global treediffs diffids
3054 stopfinding
3055 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3056 if {$l <= 1} return
3057 if {$cmitmode eq "tree"} {
3058 set e [linetoelt $l]
3059 if {[string index $e end] eq "/"} return
3060 } else {
3061 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3063 set flist_menu_file $e
3064 set xdiffstate "normal"
3065 if {$cmitmode eq "tree"} {
3066 set xdiffstate "disabled"
3068 # Disable "External diff" item in tree mode
3069 $flist_menu entryconf 2 -state $xdiffstate
3070 tk_popup $flist_menu $X $Y
3073 proc find_ctext_fileinfo {line} {
3074 global ctext_file_names ctext_file_lines
3076 set ok [bsearch $ctext_file_lines $line]
3077 set tline [lindex $ctext_file_lines $ok]
3079 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3080 return {}
3081 } else {
3082 return [list [lindex $ctext_file_names $ok] $tline]
3086 proc pop_diff_menu {w X Y x y} {
3087 global ctext diff_menu flist_menu_file
3088 global diff_menu_txtpos diff_menu_line
3089 global diff_menu_filebase
3091 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3092 set diff_menu_line [lindex $diff_menu_txtpos 0]
3093 # don't pop up the menu on hunk-separator or file-separator lines
3094 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3095 return
3097 stopfinding
3098 set f [find_ctext_fileinfo $diff_menu_line]
3099 if {$f eq {}} return
3100 set flist_menu_file [lindex $f 0]
3101 set diff_menu_filebase [lindex $f 1]
3102 tk_popup $diff_menu $X $Y
3105 proc flist_hl {only} {
3106 global flist_menu_file findstring gdttype
3108 set x [shellquote $flist_menu_file]
3109 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3110 set findstring $x
3111 } else {
3112 append findstring " " $x
3114 set gdttype [mc "touching paths:"]
3117 proc save_file_from_commit {filename output what} {
3118 global nullfile
3120 if {[catch {exec git show $filename -- > $output} err]} {
3121 if {[string match "fatal: bad revision *" $err]} {
3122 return $nullfile
3124 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3125 return {}
3127 return $output
3130 proc external_diff_get_one_file {diffid filename diffdir} {
3131 global nullid nullid2 nullfile
3132 global gitdir
3134 if {$diffid == $nullid} {
3135 set difffile [file join [file dirname $gitdir] $filename]
3136 if {[file exists $difffile]} {
3137 return $difffile
3139 return $nullfile
3141 if {$diffid == $nullid2} {
3142 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3143 return [save_file_from_commit :$filename $difffile index]
3145 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3146 return [save_file_from_commit $diffid:$filename $difffile \
3147 "revision $diffid"]
3150 proc external_diff {} {
3151 global gitktmpdir nullid nullid2
3152 global flist_menu_file
3153 global diffids
3154 global diffnum
3155 global gitdir extdifftool
3157 if {[llength $diffids] == 1} {
3158 # no reference commit given
3159 set diffidto [lindex $diffids 0]
3160 if {$diffidto eq $nullid} {
3161 # diffing working copy with index
3162 set diffidfrom $nullid2
3163 } elseif {$diffidto eq $nullid2} {
3164 # diffing index with HEAD
3165 set diffidfrom "HEAD"
3166 } else {
3167 # use first parent commit
3168 global parentlist selectedline
3169 set diffidfrom [lindex $parentlist $selectedline 0]
3171 } else {
3172 set diffidfrom [lindex $diffids 0]
3173 set diffidto [lindex $diffids 1]
3176 # make sure that several diffs wont collide
3177 if {![info exists gitktmpdir]} {
3178 set gitktmpdir [file join [file dirname $gitdir] \
3179 [format ".gitk-tmp.%s" [pid]]]
3180 if {[catch {file mkdir $gitktmpdir} err]} {
3181 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3182 unset gitktmpdir
3183 return
3185 set diffnum 0
3187 incr diffnum
3188 set diffdir [file join $gitktmpdir $diffnum]
3189 if {[catch {file mkdir $diffdir} err]} {
3190 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3191 return
3194 # gather files to diff
3195 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3196 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3198 if {$difffromfile ne {} && $difftofile ne {}} {
3199 set cmd [concat | [shellsplit $extdifftool] \
3200 [list $difffromfile $difftofile]]
3201 if {[catch {set fl [open $cmd r]} err]} {
3202 file delete -force $diffdir
3203 error_popup "$extdifftool: [mc "command failed:"] $err"
3204 } else {
3205 fconfigure $fl -blocking 0
3206 filerun $fl [list delete_at_eof $fl $diffdir]
3211 proc find_hunk_blamespec {base line} {
3212 global ctext
3214 # Find and parse the hunk header
3215 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3216 if {$s_lix eq {}} return
3218 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3219 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3220 s_line old_specs osz osz1 new_line nsz]} {
3221 return
3224 # base lines for the parents
3225 set base_lines [list $new_line]
3226 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3227 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3228 old_spec old_line osz]} {
3229 return
3231 lappend base_lines $old_line
3234 # Now scan the lines to determine offset within the hunk
3235 set max_parent [expr {[llength $base_lines]-2}]
3236 set dline 0
3237 set s_lno [lindex [split $s_lix "."] 0]
3239 # Determine if the line is removed
3240 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3241 if {[string match {[-+ ]*} $chunk]} {
3242 set removed_idx [string first "-" $chunk]
3243 # Choose a parent index
3244 if {$removed_idx >= 0} {
3245 set parent $removed_idx
3246 } else {
3247 set unchanged_idx [string first " " $chunk]
3248 if {$unchanged_idx >= 0} {
3249 set parent $unchanged_idx
3250 } else {
3251 # blame the current commit
3252 set parent -1
3255 # then count other lines that belong to it
3256 for {set i $line} {[incr i -1] > $s_lno} {} {
3257 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3258 # Determine if the line is removed
3259 set removed_idx [string first "-" $chunk]
3260 if {$parent >= 0} {
3261 set code [string index $chunk $parent]
3262 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3263 incr dline
3265 } else {
3266 if {$removed_idx < 0} {
3267 incr dline
3271 incr parent
3272 } else {
3273 set parent 0
3276 incr dline [lindex $base_lines $parent]
3277 return [list $parent $dline]
3280 proc external_blame_diff {} {
3281 global currentid cmitmode
3282 global diff_menu_txtpos diff_menu_line
3283 global diff_menu_filebase flist_menu_file
3285 if {$cmitmode eq "tree"} {
3286 set parent_idx 0
3287 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3288 } else {
3289 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3290 if {$hinfo ne {}} {
3291 set parent_idx [lindex $hinfo 0]
3292 set line [lindex $hinfo 1]
3293 } else {
3294 set parent_idx 0
3295 set line 0
3299 external_blame $parent_idx $line
3302 # Find the SHA1 ID of the blob for file $fname in the index
3303 # at stage 0 or 2
3304 proc index_sha1 {fname} {
3305 set f [open [list | git ls-files -s $fname] r]
3306 while {[gets $f line] >= 0} {
3307 set info [lindex [split $line "\t"] 0]
3308 set stage [lindex $info 2]
3309 if {$stage eq "0" || $stage eq "2"} {
3310 close $f
3311 return [lindex $info 1]
3314 close $f
3315 return {}
3318 proc external_blame {parent_idx {line {}}} {
3319 global flist_menu_file
3320 global nullid nullid2
3321 global parentlist selectedline currentid
3323 if {$parent_idx > 0} {
3324 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3325 } else {
3326 set base_commit $currentid
3329 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3330 error_popup [mc "No such commit"]
3331 return
3334 set cmdline [list git gui blame]
3335 if {$line ne {} && $line > 1} {
3336 lappend cmdline "--line=$line"
3338 lappend cmdline $base_commit $flist_menu_file
3339 if {[catch {eval exec $cmdline &} err]} {
3340 error_popup "[mc "git gui blame: command failed:"] $err"
3344 proc show_line_source {} {
3345 global cmitmode currentid parents curview blamestuff blameinst
3346 global diff_menu_line diff_menu_filebase flist_menu_file
3347 global nullid nullid2 gitdir
3349 set from_index {}
3350 if {$cmitmode eq "tree"} {
3351 set id $currentid
3352 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3353 } else {
3354 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3355 if {$h eq {}} return
3356 set pi [lindex $h 0]
3357 if {$pi == 0} {
3358 mark_ctext_line $diff_menu_line
3359 return
3361 incr pi -1
3362 if {$currentid eq $nullid} {
3363 if {$pi > 0} {
3364 # must be a merge in progress...
3365 if {[catch {
3366 # get the last line from .git/MERGE_HEAD
3367 set f [open [file join $gitdir MERGE_HEAD] r]
3368 set id [lindex [split [read $f] "\n"] end-1]
3369 close $f
3370 } err]} {
3371 error_popup [mc "Couldn't read merge head: %s" $err]
3372 return
3374 } elseif {$parents($curview,$currentid) eq $nullid2} {
3375 # need to do the blame from the index
3376 if {[catch {
3377 set from_index [index_sha1 $flist_menu_file]
3378 } err]} {
3379 error_popup [mc "Error reading index: %s" $err]
3380 return
3383 } else {
3384 set id [lindex $parents($curview,$currentid) $pi]
3386 set line [lindex $h 1]
3388 set blameargs {}
3389 if {$from_index ne {}} {
3390 lappend blameargs | git cat-file blob $from_index
3392 lappend blameargs | git blame -p -L$line,+1
3393 if {$from_index ne {}} {
3394 lappend blameargs --contents -
3395 } else {
3396 lappend blameargs $id
3398 lappend blameargs -- $flist_menu_file
3399 if {[catch {
3400 set f [open $blameargs r]
3401 } err]} {
3402 error_popup [mc "Couldn't start git blame: %s" $err]
3403 return
3405 nowbusy blaming [mc "Searching"]
3406 fconfigure $f -blocking 0
3407 set i [reg_instance $f]
3408 set blamestuff($i) {}
3409 set blameinst $i
3410 filerun $f [list read_line_source $f $i]
3413 proc stopblaming {} {
3414 global blameinst
3416 if {[info exists blameinst]} {
3417 stop_instance $blameinst
3418 unset blameinst
3419 notbusy blaming
3423 proc read_line_source {fd inst} {
3424 global blamestuff curview commfd blameinst nullid nullid2
3426 while {[gets $fd line] >= 0} {
3427 lappend blamestuff($inst) $line
3429 if {![eof $fd]} {
3430 return 1
3432 unset commfd($inst)
3433 unset blameinst
3434 notbusy blaming
3435 fconfigure $fd -blocking 1
3436 if {[catch {close $fd} err]} {
3437 error_popup [mc "Error running git blame: %s" $err]
3438 return 0
3441 set fname {}
3442 set line [split [lindex $blamestuff($inst) 0] " "]
3443 set id [lindex $line 0]
3444 set lnum [lindex $line 1]
3445 if {[string length $id] == 40 && [string is xdigit $id] &&
3446 [string is digit -strict $lnum]} {
3447 # look for "filename" line
3448 foreach l $blamestuff($inst) {
3449 if {[string match "filename *" $l]} {
3450 set fname [string range $l 9 end]
3451 break
3455 if {$fname ne {}} {
3456 # all looks good, select it
3457 if {$id eq $nullid} {
3458 # blame uses all-zeroes to mean not committed,
3459 # which would mean a change in the index
3460 set id $nullid2
3462 if {[commitinview $id $curview]} {
3463 selectline [rowofcommit $id] 1 [list $fname $lnum]
3464 } else {
3465 error_popup [mc "That line comes from commit %s, \
3466 which is not in this view" [shortids $id]]
3468 } else {
3469 puts "oops couldn't parse git blame output"
3471 return 0
3474 # delete $dir when we see eof on $f (presumably because the child has exited)
3475 proc delete_at_eof {f dir} {
3476 while {[gets $f line] >= 0} {}
3477 if {[eof $f]} {
3478 if {[catch {close $f} err]} {
3479 error_popup "[mc "External diff viewer failed:"] $err"
3481 file delete -force $dir
3482 return 0
3484 return 1
3487 # Functions for adding and removing shell-type quoting
3489 proc shellquote {str} {
3490 if {![string match "*\['\"\\ \t]*" $str]} {
3491 return $str
3493 if {![string match "*\['\"\\]*" $str]} {
3494 return "\"$str\""
3496 if {![string match "*'*" $str]} {
3497 return "'$str'"
3499 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3502 proc shellarglist {l} {
3503 set str {}
3504 foreach a $l {
3505 if {$str ne {}} {
3506 append str " "
3508 append str [shellquote $a]
3510 return $str
3513 proc shelldequote {str} {
3514 set ret {}
3515 set used -1
3516 while {1} {
3517 incr used
3518 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3519 append ret [string range $str $used end]
3520 set used [string length $str]
3521 break
3523 set first [lindex $first 0]
3524 set ch [string index $str $first]
3525 if {$first > $used} {
3526 append ret [string range $str $used [expr {$first - 1}]]
3527 set used $first
3529 if {$ch eq " " || $ch eq "\t"} break
3530 incr used
3531 if {$ch eq "'"} {
3532 set first [string first "'" $str $used]
3533 if {$first < 0} {
3534 error "unmatched single-quote"
3536 append ret [string range $str $used [expr {$first - 1}]]
3537 set used $first
3538 continue
3540 if {$ch eq "\\"} {
3541 if {$used >= [string length $str]} {
3542 error "trailing backslash"
3544 append ret [string index $str $used]
3545 continue
3547 # here ch == "\""
3548 while {1} {
3549 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3550 error "unmatched double-quote"
3552 set first [lindex $first 0]
3553 set ch [string index $str $first]
3554 if {$first > $used} {
3555 append ret [string range $str $used [expr {$first - 1}]]
3556 set used $first
3558 if {$ch eq "\""} break
3559 incr used
3560 append ret [string index $str $used]
3561 incr used
3564 return [list $used $ret]
3567 proc shellsplit {str} {
3568 set l {}
3569 while {1} {
3570 set str [string trimleft $str]
3571 if {$str eq {}} break
3572 set dq [shelldequote $str]
3573 set n [lindex $dq 0]
3574 set word [lindex $dq 1]
3575 set str [string range $str $n end]
3576 lappend l $word
3578 return $l
3581 # Code to implement multiple views
3583 proc newview {ishighlight} {
3584 global nextviewnum newviewname newishighlight
3585 global revtreeargs viewargscmd newviewopts curview
3587 set newishighlight $ishighlight
3588 set top .gitkview
3589 if {[winfo exists $top]} {
3590 raise $top
3591 return
3593 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3594 set newviewopts($nextviewnum,perm) 0
3595 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3596 decode_view_opts $nextviewnum $revtreeargs
3597 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3600 set known_view_options {
3601 {perm b . {} {mc "Remember this view"}}
3602 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3603 {all b * "--all" {mc "Use all refs"}}
3604 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3605 {lright b . "--left-right" {mc "Mark branch sides"}}
3606 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3607 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3608 {limit t10 + "--max-count=*" {mc "Max count:"}}
3609 {skip t10 . "--skip=*" {mc "Skip:"}}
3610 {first b . "--first-parent" {mc "Limit to first parent"}}
3611 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3614 proc encode_view_opts {n} {
3615 global known_view_options newviewopts
3617 set rargs [list]
3618 foreach opt $known_view_options {
3619 set patterns [lindex $opt 3]
3620 if {$patterns eq {}} continue
3621 set pattern [lindex $patterns 0]
3623 set val $newviewopts($n,[lindex $opt 0])
3625 if {[lindex $opt 1] eq "b"} {
3626 if {$val} {
3627 lappend rargs $pattern
3629 } else {
3630 set val [string trim $val]
3631 if {$val ne {}} {
3632 set pfix [string range $pattern 0 end-1]
3633 lappend rargs $pfix$val
3637 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3640 proc decode_view_opts {n view_args} {
3641 global known_view_options newviewopts
3643 foreach opt $known_view_options {
3644 if {[lindex $opt 1] eq "b"} {
3645 set val 0
3646 } else {
3647 set val {}
3649 set newviewopts($n,[lindex $opt 0]) $val
3651 set oargs [list]
3652 foreach arg $view_args {
3653 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3654 && ![info exists found(limit)]} {
3655 set newviewopts($n,limit) $cnt
3656 set found(limit) 1
3657 continue
3659 catch { unset val }
3660 foreach opt $known_view_options {
3661 set id [lindex $opt 0]
3662 if {[info exists found($id)]} continue
3663 foreach pattern [lindex $opt 3] {
3664 if {![string match $pattern $arg]} continue
3665 if {[lindex $opt 1] ne "b"} {
3666 set size [string length $pattern]
3667 set val [string range $arg [expr {$size-1}] end]
3668 } else {
3669 set val 1
3671 set newviewopts($n,$id) $val
3672 set found($id) 1
3673 break
3675 if {[info exists val]} break
3677 if {[info exists val]} continue
3678 lappend oargs $arg
3680 set newviewopts($n,args) [shellarglist $oargs]
3683 proc edit_or_newview {} {
3684 global curview
3686 if {$curview > 0} {
3687 editview
3688 } else {
3689 newview 0
3693 proc editview {} {
3694 global curview
3695 global viewname viewperm newviewname newviewopts
3696 global viewargs viewargscmd
3698 set top .gitkvedit-$curview
3699 if {[winfo exists $top]} {
3700 raise $top
3701 return
3703 set newviewname($curview) $viewname($curview)
3704 set newviewopts($curview,perm) $viewperm($curview)
3705 set newviewopts($curview,cmd) $viewargscmd($curview)
3706 decode_view_opts $curview $viewargs($curview)
3707 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3710 proc vieweditor {top n title} {
3711 global newviewname newviewopts viewfiles bgcolor
3712 global known_view_options
3714 toplevel $top
3715 wm title $top $title
3716 make_transient $top .
3718 # View name
3719 frame $top.nfr
3720 label $top.nl -text [mc "Name"]
3721 entry $top.name -width 20 -textvariable newviewname($n)
3722 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3723 pack $top.nl -in $top.nfr -side left -padx {0 30}
3724 pack $top.name -in $top.nfr -side left
3726 # View options
3727 set cframe $top.nfr
3728 set cexpand 0
3729 set cnt 0
3730 foreach opt $known_view_options {
3731 set id [lindex $opt 0]
3732 set type [lindex $opt 1]
3733 set flags [lindex $opt 2]
3734 set title [eval [lindex $opt 4]]
3735 set lxpad 0
3737 if {$flags eq "+" || $flags eq "*"} {
3738 set cframe $top.fr$cnt
3739 incr cnt
3740 frame $cframe
3741 pack $cframe -in $top -fill x -pady 3 -padx 3
3742 set cexpand [expr {$flags eq "*"}]
3743 } else {
3744 set lxpad 5
3747 if {$type eq "b"} {
3748 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3749 pack $cframe.c_$id -in $cframe -side left \
3750 -padx [list $lxpad 0] -expand $cexpand -anchor w
3751 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3752 message $cframe.l_$id -aspect 1500 -text $title
3753 entry $cframe.e_$id -width $sz -background $bgcolor \
3754 -textvariable newviewopts($n,$id)
3755 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3756 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3757 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3758 message $cframe.l_$id -aspect 1500 -text $title
3759 entry $cframe.e_$id -width $sz -background $bgcolor \
3760 -textvariable newviewopts($n,$id)
3761 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3762 pack $cframe.e_$id -in $cframe -side top -fill x
3766 # Path list
3767 message $top.l -aspect 1500 \
3768 -text [mc "Enter files and directories to include, one per line:"]
3769 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3770 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3771 if {[info exists viewfiles($n)]} {
3772 foreach f $viewfiles($n) {
3773 $top.t insert end $f
3774 $top.t insert end "\n"
3776 $top.t delete {end - 1c} end
3777 $top.t mark set insert 0.0
3779 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3780 frame $top.buts
3781 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3782 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3783 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3784 bind $top <Control-Return> [list newviewok $top $n]
3785 bind $top <F5> [list newviewok $top $n 1]
3786 bind $top <Escape> [list destroy $top]
3787 grid $top.buts.ok $top.buts.apply $top.buts.can
3788 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3789 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3790 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3791 pack $top.buts -in $top -side top -fill x
3792 focus $top.t
3795 proc doviewmenu {m first cmd op argv} {
3796 set nmenu [$m index end]
3797 for {set i $first} {$i <= $nmenu} {incr i} {
3798 if {[$m entrycget $i -command] eq $cmd} {
3799 eval $m $op $i $argv
3800 break
3805 proc allviewmenus {n op args} {
3806 # global viewhlmenu
3808 doviewmenu .bar.view 5 [list showview $n] $op $args
3809 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3812 proc newviewok {top n {apply 0}} {
3813 global nextviewnum newviewperm newviewname newishighlight
3814 global viewname viewfiles viewperm selectedview curview
3815 global viewargs viewargscmd newviewopts viewhlmenu
3817 if {[catch {
3818 set newargs [encode_view_opts $n]
3819 } err]} {
3820 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3821 return
3823 set files {}
3824 foreach f [split [$top.t get 0.0 end] "\n"] {
3825 set ft [string trim $f]
3826 if {$ft ne {}} {
3827 lappend files $ft
3830 if {![info exists viewfiles($n)]} {
3831 # creating a new view
3832 incr nextviewnum
3833 set viewname($n) $newviewname($n)
3834 set viewperm($n) $newviewopts($n,perm)
3835 set viewfiles($n) $files
3836 set viewargs($n) $newargs
3837 set viewargscmd($n) $newviewopts($n,cmd)
3838 addviewmenu $n
3839 if {!$newishighlight} {
3840 run showview $n
3841 } else {
3842 run addvhighlight $n
3844 } else {
3845 # editing an existing view
3846 set viewperm($n) $newviewopts($n,perm)
3847 if {$newviewname($n) ne $viewname($n)} {
3848 set viewname($n) $newviewname($n)
3849 doviewmenu .bar.view 5 [list showview $n] \
3850 entryconf [list -label $viewname($n)]
3851 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3852 # entryconf [list -label $viewname($n) -value $viewname($n)]
3854 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3855 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3856 set viewfiles($n) $files
3857 set viewargs($n) $newargs
3858 set viewargscmd($n) $newviewopts($n,cmd)
3859 if {$curview == $n} {
3860 run reloadcommits
3864 if {$apply} return
3865 catch {destroy $top}
3868 proc delview {} {
3869 global curview viewperm hlview selectedhlview
3871 if {$curview == 0} return
3872 if {[info exists hlview] && $hlview == $curview} {
3873 set selectedhlview [mc "None"]
3874 unset hlview
3876 allviewmenus $curview delete
3877 set viewperm($curview) 0
3878 showview 0
3881 proc addviewmenu {n} {
3882 global viewname viewhlmenu
3884 .bar.view add radiobutton -label $viewname($n) \
3885 -command [list showview $n] -variable selectedview -value $n
3886 #$viewhlmenu add radiobutton -label $viewname($n) \
3887 # -command [list addvhighlight $n] -variable selectedhlview
3890 proc showview {n} {
3891 global curview cached_commitrow ordertok
3892 global displayorder parentlist rowidlist rowisopt rowfinal
3893 global colormap rowtextx nextcolor canvxmax
3894 global numcommits viewcomplete
3895 global selectedline currentid canv canvy0
3896 global treediffs
3897 global pending_select mainheadid
3898 global commitidx
3899 global selectedview
3900 global hlview selectedhlview commitinterest
3902 if {$n == $curview} return
3903 set selid {}
3904 set ymax [lindex [$canv cget -scrollregion] 3]
3905 set span [$canv yview]
3906 set ytop [expr {[lindex $span 0] * $ymax}]
3907 set ybot [expr {[lindex $span 1] * $ymax}]
3908 set yscreen [expr {($ybot - $ytop) / 2}]
3909 if {$selectedline ne {}} {
3910 set selid $currentid
3911 set y [yc $selectedline]
3912 if {$ytop < $y && $y < $ybot} {
3913 set yscreen [expr {$y - $ytop}]
3915 } elseif {[info exists pending_select]} {
3916 set selid $pending_select
3917 unset pending_select
3919 unselectline
3920 normalline
3921 catch {unset treediffs}
3922 clear_display
3923 if {[info exists hlview] && $hlview == $n} {
3924 unset hlview
3925 set selectedhlview [mc "None"]
3927 catch {unset commitinterest}
3928 catch {unset cached_commitrow}
3929 catch {unset ordertok}
3931 set curview $n
3932 set selectedview $n
3933 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3934 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3936 run refill_reflist
3937 if {![info exists viewcomplete($n)]} {
3938 getcommits $selid
3939 return
3942 set displayorder {}
3943 set parentlist {}
3944 set rowidlist {}
3945 set rowisopt {}
3946 set rowfinal {}
3947 set numcommits $commitidx($n)
3949 catch {unset colormap}
3950 catch {unset rowtextx}
3951 set nextcolor 0
3952 set canvxmax [$canv cget -width]
3953 set curview $n
3954 set row 0
3955 setcanvscroll
3956 set yf 0
3957 set row {}
3958 if {$selid ne {} && [commitinview $selid $n]} {
3959 set row [rowofcommit $selid]
3960 # try to get the selected row in the same position on the screen
3961 set ymax [lindex [$canv cget -scrollregion] 3]
3962 set ytop [expr {[yc $row] - $yscreen}]
3963 if {$ytop < 0} {
3964 set ytop 0
3966 set yf [expr {$ytop * 1.0 / $ymax}]
3968 allcanvs yview moveto $yf
3969 drawvisible
3970 if {$row ne {}} {
3971 selectline $row 0
3972 } elseif {!$viewcomplete($n)} {
3973 reset_pending_select $selid
3974 } else {
3975 reset_pending_select {}
3977 if {[commitinview $pending_select $curview]} {
3978 selectline [rowofcommit $pending_select] 1
3979 } else {
3980 set row [first_real_row]
3981 if {$row < $numcommits} {
3982 selectline $row 0
3986 if {!$viewcomplete($n)} {
3987 if {$numcommits == 0} {
3988 show_status [mc "Reading commits..."]
3990 } elseif {$numcommits == 0} {
3991 show_status [mc "No commits selected"]
3995 # Stuff relating to the highlighting facility
3997 proc ishighlighted {id} {
3998 global vhighlights fhighlights nhighlights rhighlights
4000 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4001 return $nhighlights($id)
4003 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4004 return $vhighlights($id)
4006 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4007 return $fhighlights($id)
4009 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4010 return $rhighlights($id)
4012 return 0
4015 proc bolden {id font} {
4016 global canv linehtag currentid boldids need_redisplay
4018 # need_redisplay = 1 means the display is stale and about to be redrawn
4019 if {$need_redisplay} return
4020 lappend boldids $id
4021 $canv itemconf $linehtag($id) -font $font
4022 if {[info exists currentid] && $id eq $currentid} {
4023 $canv delete secsel
4024 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4025 -outline {{}} -tags secsel \
4026 -fill [$canv cget -selectbackground]]
4027 $canv lower $t
4031 proc bolden_name {id font} {
4032 global canv2 linentag currentid boldnameids need_redisplay
4034 if {$need_redisplay} return
4035 lappend boldnameids $id
4036 $canv2 itemconf $linentag($id) -font $font
4037 if {[info exists currentid] && $id eq $currentid} {
4038 $canv2 delete secsel
4039 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4040 -outline {{}} -tags secsel \
4041 -fill [$canv2 cget -selectbackground]]
4042 $canv2 lower $t
4046 proc unbolden {} {
4047 global boldids
4049 set stillbold {}
4050 foreach id $boldids {
4051 if {![ishighlighted $id]} {
4052 bolden $id mainfont
4053 } else {
4054 lappend stillbold $id
4057 set boldids $stillbold
4060 proc addvhighlight {n} {
4061 global hlview viewcomplete curview vhl_done commitidx
4063 if {[info exists hlview]} {
4064 delvhighlight
4066 set hlview $n
4067 if {$n != $curview && ![info exists viewcomplete($n)]} {
4068 start_rev_list $n
4070 set vhl_done $commitidx($hlview)
4071 if {$vhl_done > 0} {
4072 drawvisible
4076 proc delvhighlight {} {
4077 global hlview vhighlights
4079 if {![info exists hlview]} return
4080 unset hlview
4081 catch {unset vhighlights}
4082 unbolden
4085 proc vhighlightmore {} {
4086 global hlview vhl_done commitidx vhighlights curview
4088 set max $commitidx($hlview)
4089 set vr [visiblerows]
4090 set r0 [lindex $vr 0]
4091 set r1 [lindex $vr 1]
4092 for {set i $vhl_done} {$i < $max} {incr i} {
4093 set id [commitonrow $i $hlview]
4094 if {[commitinview $id $curview]} {
4095 set row [rowofcommit $id]
4096 if {$r0 <= $row && $row <= $r1} {
4097 if {![highlighted $row]} {
4098 bolden $id mainfontbold
4100 set vhighlights($id) 1
4104 set vhl_done $max
4105 return 0
4108 proc askvhighlight {row id} {
4109 global hlview vhighlights iddrawn
4111 if {[commitinview $id $hlview]} {
4112 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4113 bolden $id mainfontbold
4115 set vhighlights($id) 1
4116 } else {
4117 set vhighlights($id) 0
4121 proc hfiles_change {} {
4122 global highlight_files filehighlight fhighlights fh_serial
4123 global highlight_paths
4125 if {[info exists filehighlight]} {
4126 # delete previous highlights
4127 catch {close $filehighlight}
4128 unset filehighlight
4129 catch {unset fhighlights}
4130 unbolden
4131 unhighlight_filelist
4133 set highlight_paths {}
4134 after cancel do_file_hl $fh_serial
4135 incr fh_serial
4136 if {$highlight_files ne {}} {
4137 after 300 do_file_hl $fh_serial
4141 proc gdttype_change {name ix op} {
4142 global gdttype highlight_files findstring findpattern
4144 stopfinding
4145 if {$findstring ne {}} {
4146 if {$gdttype eq [mc "containing:"]} {
4147 if {$highlight_files ne {}} {
4148 set highlight_files {}
4149 hfiles_change
4151 findcom_change
4152 } else {
4153 if {$findpattern ne {}} {
4154 set findpattern {}
4155 findcom_change
4157 set highlight_files $findstring
4158 hfiles_change
4160 drawvisible
4162 # enable/disable findtype/findloc menus too
4165 proc find_change {name ix op} {
4166 global gdttype findstring highlight_files
4168 stopfinding
4169 if {$gdttype eq [mc "containing:"]} {
4170 findcom_change
4171 } else {
4172 if {$highlight_files ne $findstring} {
4173 set highlight_files $findstring
4174 hfiles_change
4177 drawvisible
4180 proc findcom_change args {
4181 global nhighlights boldnameids
4182 global findpattern findtype findstring gdttype
4184 stopfinding
4185 # delete previous highlights, if any
4186 foreach id $boldnameids {
4187 bolden_name $id mainfont
4189 set boldnameids {}
4190 catch {unset nhighlights}
4191 unbolden
4192 unmarkmatches
4193 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4194 set findpattern {}
4195 } elseif {$findtype eq [mc "Regexp"]} {
4196 set findpattern $findstring
4197 } else {
4198 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4199 $findstring]
4200 set findpattern "*$e*"
4204 proc makepatterns {l} {
4205 set ret {}
4206 foreach e $l {
4207 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4208 if {[string index $ee end] eq "/"} {
4209 lappend ret "$ee*"
4210 } else {
4211 lappend ret $ee
4212 lappend ret "$ee/*"
4215 return $ret
4218 proc do_file_hl {serial} {
4219 global highlight_files filehighlight highlight_paths gdttype fhl_list
4221 if {$gdttype eq [mc "touching paths:"]} {
4222 if {[catch {set paths [shellsplit $highlight_files]}]} return
4223 set highlight_paths [makepatterns $paths]
4224 highlight_filelist
4225 set gdtargs [concat -- $paths]
4226 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4227 set gdtargs [list "-S$highlight_files"]
4228 } else {
4229 # must be "containing:", i.e. we're searching commit info
4230 return
4232 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4233 set filehighlight [open $cmd r+]
4234 fconfigure $filehighlight -blocking 0
4235 filerun $filehighlight readfhighlight
4236 set fhl_list {}
4237 drawvisible
4238 flushhighlights
4241 proc flushhighlights {} {
4242 global filehighlight fhl_list
4244 if {[info exists filehighlight]} {
4245 lappend fhl_list {}
4246 puts $filehighlight ""
4247 flush $filehighlight
4251 proc askfilehighlight {row id} {
4252 global filehighlight fhighlights fhl_list
4254 lappend fhl_list $id
4255 set fhighlights($id) -1
4256 puts $filehighlight $id
4259 proc readfhighlight {} {
4260 global filehighlight fhighlights curview iddrawn
4261 global fhl_list find_dirn
4263 if {![info exists filehighlight]} {
4264 return 0
4266 set nr 0
4267 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4268 set line [string trim $line]
4269 set i [lsearch -exact $fhl_list $line]
4270 if {$i < 0} continue
4271 for {set j 0} {$j < $i} {incr j} {
4272 set id [lindex $fhl_list $j]
4273 set fhighlights($id) 0
4275 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4276 if {$line eq {}} continue
4277 if {![commitinview $line $curview]} continue
4278 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4279 bolden $line mainfontbold
4281 set fhighlights($line) 1
4283 if {[eof $filehighlight]} {
4284 # strange...
4285 puts "oops, git diff-tree died"
4286 catch {close $filehighlight}
4287 unset filehighlight
4288 return 0
4290 if {[info exists find_dirn]} {
4291 run findmore
4293 return 1
4296 proc doesmatch {f} {
4297 global findtype findpattern
4299 if {$findtype eq [mc "Regexp"]} {
4300 return [regexp $findpattern $f]
4301 } elseif {$findtype eq [mc "IgnCase"]} {
4302 return [string match -nocase $findpattern $f]
4303 } else {
4304 return [string match $findpattern $f]
4308 proc askfindhighlight {row id} {
4309 global nhighlights commitinfo iddrawn
4310 global findloc
4311 global markingmatches
4313 if {![info exists commitinfo($id)]} {
4314 getcommit $id
4316 set info $commitinfo($id)
4317 set isbold 0
4318 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4319 foreach f $info ty $fldtypes {
4320 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4321 [doesmatch $f]} {
4322 if {$ty eq [mc "Author"]} {
4323 set isbold 2
4324 break
4326 set isbold 1
4329 if {$isbold && [info exists iddrawn($id)]} {
4330 if {![ishighlighted $id]} {
4331 bolden $id mainfontbold
4332 if {$isbold > 1} {
4333 bolden_name $id mainfontbold
4336 if {$markingmatches} {
4337 markrowmatches $row $id
4340 set nhighlights($id) $isbold
4343 proc markrowmatches {row id} {
4344 global canv canv2 linehtag linentag commitinfo findloc
4346 set headline [lindex $commitinfo($id) 0]
4347 set author [lindex $commitinfo($id) 1]
4348 $canv delete match$row
4349 $canv2 delete match$row
4350 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4351 set m [findmatches $headline]
4352 if {$m ne {}} {
4353 markmatches $canv $row $headline $linehtag($id) $m \
4354 [$canv itemcget $linehtag($id) -font] $row
4357 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4358 set m [findmatches $author]
4359 if {$m ne {}} {
4360 markmatches $canv2 $row $author $linentag($id) $m \
4361 [$canv2 itemcget $linentag($id) -font] $row
4366 proc vrel_change {name ix op} {
4367 global highlight_related
4369 rhighlight_none
4370 if {$highlight_related ne [mc "None"]} {
4371 run drawvisible
4375 # prepare for testing whether commits are descendents or ancestors of a
4376 proc rhighlight_sel {a} {
4377 global descendent desc_todo ancestor anc_todo
4378 global highlight_related
4380 catch {unset descendent}
4381 set desc_todo [list $a]
4382 catch {unset ancestor}
4383 set anc_todo [list $a]
4384 if {$highlight_related ne [mc "None"]} {
4385 rhighlight_none
4386 run drawvisible
4390 proc rhighlight_none {} {
4391 global rhighlights
4393 catch {unset rhighlights}
4394 unbolden
4397 proc is_descendent {a} {
4398 global curview children descendent desc_todo
4400 set v $curview
4401 set la [rowofcommit $a]
4402 set todo $desc_todo
4403 set leftover {}
4404 set done 0
4405 for {set i 0} {$i < [llength $todo]} {incr i} {
4406 set do [lindex $todo $i]
4407 if {[rowofcommit $do] < $la} {
4408 lappend leftover $do
4409 continue
4411 foreach nk $children($v,$do) {
4412 if {![info exists descendent($nk)]} {
4413 set descendent($nk) 1
4414 lappend todo $nk
4415 if {$nk eq $a} {
4416 set done 1
4420 if {$done} {
4421 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4422 return
4425 set descendent($a) 0
4426 set desc_todo $leftover
4429 proc is_ancestor {a} {
4430 global curview parents ancestor anc_todo
4432 set v $curview
4433 set la [rowofcommit $a]
4434 set todo $anc_todo
4435 set leftover {}
4436 set done 0
4437 for {set i 0} {$i < [llength $todo]} {incr i} {
4438 set do [lindex $todo $i]
4439 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4440 lappend leftover $do
4441 continue
4443 foreach np $parents($v,$do) {
4444 if {![info exists ancestor($np)]} {
4445 set ancestor($np) 1
4446 lappend todo $np
4447 if {$np eq $a} {
4448 set done 1
4452 if {$done} {
4453 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4454 return
4457 set ancestor($a) 0
4458 set anc_todo $leftover
4461 proc askrelhighlight {row id} {
4462 global descendent highlight_related iddrawn rhighlights
4463 global selectedline ancestor
4465 if {$selectedline eq {}} return
4466 set isbold 0
4467 if {$highlight_related eq [mc "Descendant"] ||
4468 $highlight_related eq [mc "Not descendant"]} {
4469 if {![info exists descendent($id)]} {
4470 is_descendent $id
4472 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4473 set isbold 1
4475 } elseif {$highlight_related eq [mc "Ancestor"] ||
4476 $highlight_related eq [mc "Not ancestor"]} {
4477 if {![info exists ancestor($id)]} {
4478 is_ancestor $id
4480 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4481 set isbold 1
4484 if {[info exists iddrawn($id)]} {
4485 if {$isbold && ![ishighlighted $id]} {
4486 bolden $id mainfontbold
4489 set rhighlights($id) $isbold
4492 # Graph layout functions
4494 proc shortids {ids} {
4495 set res {}
4496 foreach id $ids {
4497 if {[llength $id] > 1} {
4498 lappend res [shortids $id]
4499 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4500 lappend res [string range $id 0 7]
4501 } else {
4502 lappend res $id
4505 return $res
4508 proc ntimes {n o} {
4509 set ret {}
4510 set o [list $o]
4511 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4512 if {($n & $mask) != 0} {
4513 set ret [concat $ret $o]
4515 set o [concat $o $o]
4517 return $ret
4520 proc ordertoken {id} {
4521 global ordertok curview varcid varcstart varctok curview parents children
4522 global nullid nullid2
4524 if {[info exists ordertok($id)]} {
4525 return $ordertok($id)
4527 set origid $id
4528 set todo {}
4529 while {1} {
4530 if {[info exists varcid($curview,$id)]} {
4531 set a $varcid($curview,$id)
4532 set p [lindex $varcstart($curview) $a]
4533 } else {
4534 set p [lindex $children($curview,$id) 0]
4536 if {[info exists ordertok($p)]} {
4537 set tok $ordertok($p)
4538 break
4540 set id [first_real_child $curview,$p]
4541 if {$id eq {}} {
4542 # it's a root
4543 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4544 break
4546 if {[llength $parents($curview,$id)] == 1} {
4547 lappend todo [list $p {}]
4548 } else {
4549 set j [lsearch -exact $parents($curview,$id) $p]
4550 if {$j < 0} {
4551 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4553 lappend todo [list $p [strrep $j]]
4556 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4557 set p [lindex $todo $i 0]
4558 append tok [lindex $todo $i 1]
4559 set ordertok($p) $tok
4561 set ordertok($origid) $tok
4562 return $tok
4565 # Work out where id should go in idlist so that order-token
4566 # values increase from left to right
4567 proc idcol {idlist id {i 0}} {
4568 set t [ordertoken $id]
4569 if {$i < 0} {
4570 set i 0
4572 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4573 if {$i > [llength $idlist]} {
4574 set i [llength $idlist]
4576 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4577 incr i
4578 } else {
4579 if {$t > [ordertoken [lindex $idlist $i]]} {
4580 while {[incr i] < [llength $idlist] &&
4581 $t >= [ordertoken [lindex $idlist $i]]} {}
4584 return $i
4587 proc initlayout {} {
4588 global rowidlist rowisopt rowfinal displayorder parentlist
4589 global numcommits canvxmax canv
4590 global nextcolor
4591 global colormap rowtextx
4593 set numcommits 0
4594 set displayorder {}
4595 set parentlist {}
4596 set nextcolor 0
4597 set rowidlist {}
4598 set rowisopt {}
4599 set rowfinal {}
4600 set canvxmax [$canv cget -width]
4601 catch {unset colormap}
4602 catch {unset rowtextx}
4603 setcanvscroll
4606 proc setcanvscroll {} {
4607 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4608 global lastscrollset lastscrollrows
4610 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4611 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4612 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4613 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4614 set lastscrollset [clock clicks -milliseconds]
4615 set lastscrollrows $numcommits
4618 proc visiblerows {} {
4619 global canv numcommits linespc
4621 set ymax [lindex [$canv cget -scrollregion] 3]
4622 if {$ymax eq {} || $ymax == 0} return
4623 set f [$canv yview]
4624 set y0 [expr {int([lindex $f 0] * $ymax)}]
4625 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4626 if {$r0 < 0} {
4627 set r0 0
4629 set y1 [expr {int([lindex $f 1] * $ymax)}]
4630 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4631 if {$r1 >= $numcommits} {
4632 set r1 [expr {$numcommits - 1}]
4634 return [list $r0 $r1]
4637 proc layoutmore {} {
4638 global commitidx viewcomplete curview
4639 global numcommits pending_select curview
4640 global lastscrollset lastscrollrows
4642 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4643 [clock clicks -milliseconds] - $lastscrollset > 500} {
4644 setcanvscroll
4646 if {[info exists pending_select] &&
4647 [commitinview $pending_select $curview]} {
4648 update
4649 selectline [rowofcommit $pending_select] 1
4651 drawvisible
4654 # With path limiting, we mightn't get the actual HEAD commit,
4655 # so ask git rev-list what is the first ancestor of HEAD that
4656 # touches a file in the path limit.
4657 proc get_viewmainhead {view} {
4658 global viewmainheadid vfilelimit viewinstances mainheadid
4660 catch {
4661 set rfd [open [concat | git rev-list -1 $mainheadid \
4662 -- $vfilelimit($view)] r]
4663 set j [reg_instance $rfd]
4664 lappend viewinstances($view) $j
4665 fconfigure $rfd -blocking 0
4666 filerun $rfd [list getviewhead $rfd $j $view]
4667 set viewmainheadid($curview) {}
4671 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4672 proc getviewhead {fd inst view} {
4673 global viewmainheadid commfd curview viewinstances showlocalchanges
4675 set id {}
4676 if {[gets $fd line] < 0} {
4677 if {![eof $fd]} {
4678 return 1
4680 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4681 set id $line
4683 set viewmainheadid($view) $id
4684 close $fd
4685 unset commfd($inst)
4686 set i [lsearch -exact $viewinstances($view) $inst]
4687 if {$i >= 0} {
4688 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4690 if {$showlocalchanges && $id ne {} && $view == $curview} {
4691 doshowlocalchanges
4693 return 0
4696 proc doshowlocalchanges {} {
4697 global curview viewmainheadid
4699 if {$viewmainheadid($curview) eq {}} return
4700 if {[commitinview $viewmainheadid($curview) $curview]} {
4701 dodiffindex
4702 } else {
4703 interestedin $viewmainheadid($curview) dodiffindex
4707 proc dohidelocalchanges {} {
4708 global nullid nullid2 lserial curview
4710 if {[commitinview $nullid $curview]} {
4711 removefakerow $nullid
4713 if {[commitinview $nullid2 $curview]} {
4714 removefakerow $nullid2
4716 incr lserial
4719 # spawn off a process to do git diff-index --cached HEAD
4720 proc dodiffindex {} {
4721 global lserial showlocalchanges vfilelimit curview
4722 global isworktree
4724 if {!$showlocalchanges || !$isworktree} return
4725 incr lserial
4726 set cmd "|git diff-index --cached HEAD"
4727 if {$vfilelimit($curview) ne {}} {
4728 set cmd [concat $cmd -- $vfilelimit($curview)]
4730 set fd [open $cmd r]
4731 fconfigure $fd -blocking 0
4732 set i [reg_instance $fd]
4733 filerun $fd [list readdiffindex $fd $lserial $i]
4736 proc readdiffindex {fd serial inst} {
4737 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4738 global vfilelimit
4740 set isdiff 1
4741 if {[gets $fd line] < 0} {
4742 if {![eof $fd]} {
4743 return 1
4745 set isdiff 0
4747 # we only need to see one line and we don't really care what it says...
4748 stop_instance $inst
4750 if {$serial != $lserial} {
4751 return 0
4754 # now see if there are any local changes not checked in to the index
4755 set cmd "|git diff-files"
4756 if {$vfilelimit($curview) ne {}} {
4757 set cmd [concat $cmd -- $vfilelimit($curview)]
4759 set fd [open $cmd r]
4760 fconfigure $fd -blocking 0
4761 set i [reg_instance $fd]
4762 filerun $fd [list readdifffiles $fd $serial $i]
4764 if {$isdiff && ![commitinview $nullid2 $curview]} {
4765 # add the line for the changes in the index to the graph
4766 set hl [mc "Local changes checked in to index but not committed"]
4767 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4768 set commitdata($nullid2) "\n $hl\n"
4769 if {[commitinview $nullid $curview]} {
4770 removefakerow $nullid
4772 insertfakerow $nullid2 $viewmainheadid($curview)
4773 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4774 if {[commitinview $nullid $curview]} {
4775 removefakerow $nullid
4777 removefakerow $nullid2
4779 return 0
4782 proc readdifffiles {fd serial inst} {
4783 global viewmainheadid nullid nullid2 curview
4784 global commitinfo commitdata lserial
4786 set isdiff 1
4787 if {[gets $fd line] < 0} {
4788 if {![eof $fd]} {
4789 return 1
4791 set isdiff 0
4793 # we only need to see one line and we don't really care what it says...
4794 stop_instance $inst
4796 if {$serial != $lserial} {
4797 return 0
4800 if {$isdiff && ![commitinview $nullid $curview]} {
4801 # add the line for the local diff to the graph
4802 set hl [mc "Local uncommitted changes, not checked in to index"]
4803 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4804 set commitdata($nullid) "\n $hl\n"
4805 if {[commitinview $nullid2 $curview]} {
4806 set p $nullid2
4807 } else {
4808 set p $viewmainheadid($curview)
4810 insertfakerow $nullid $p
4811 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4812 removefakerow $nullid
4814 return 0
4817 proc nextuse {id row} {
4818 global curview children
4820 if {[info exists children($curview,$id)]} {
4821 foreach kid $children($curview,$id) {
4822 if {![commitinview $kid $curview]} {
4823 return -1
4825 if {[rowofcommit $kid] > $row} {
4826 return [rowofcommit $kid]
4830 if {[commitinview $id $curview]} {
4831 return [rowofcommit $id]
4833 return -1
4836 proc prevuse {id row} {
4837 global curview children
4839 set ret -1
4840 if {[info exists children($curview,$id)]} {
4841 foreach kid $children($curview,$id) {
4842 if {![commitinview $kid $curview]} break
4843 if {[rowofcommit $kid] < $row} {
4844 set ret [rowofcommit $kid]
4848 return $ret
4851 proc make_idlist {row} {
4852 global displayorder parentlist uparrowlen downarrowlen mingaplen
4853 global commitidx curview children
4855 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4856 if {$r < 0} {
4857 set r 0
4859 set ra [expr {$row - $downarrowlen}]
4860 if {$ra < 0} {
4861 set ra 0
4863 set rb [expr {$row + $uparrowlen}]
4864 if {$rb > $commitidx($curview)} {
4865 set rb $commitidx($curview)
4867 make_disporder $r [expr {$rb + 1}]
4868 set ids {}
4869 for {} {$r < $ra} {incr r} {
4870 set nextid [lindex $displayorder [expr {$r + 1}]]
4871 foreach p [lindex $parentlist $r] {
4872 if {$p eq $nextid} continue
4873 set rn [nextuse $p $r]
4874 if {$rn >= $row &&
4875 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4876 lappend ids [list [ordertoken $p] $p]
4880 for {} {$r < $row} {incr r} {
4881 set nextid [lindex $displayorder [expr {$r + 1}]]
4882 foreach p [lindex $parentlist $r] {
4883 if {$p eq $nextid} continue
4884 set rn [nextuse $p $r]
4885 if {$rn < 0 || $rn >= $row} {
4886 lappend ids [list [ordertoken $p] $p]
4890 set id [lindex $displayorder $row]
4891 lappend ids [list [ordertoken $id] $id]
4892 while {$r < $rb} {
4893 foreach p [lindex $parentlist $r] {
4894 set firstkid [lindex $children($curview,$p) 0]
4895 if {[rowofcommit $firstkid] < $row} {
4896 lappend ids [list [ordertoken $p] $p]
4899 incr r
4900 set id [lindex $displayorder $r]
4901 if {$id ne {}} {
4902 set firstkid [lindex $children($curview,$id) 0]
4903 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4904 lappend ids [list [ordertoken $id] $id]
4908 set idlist {}
4909 foreach idx [lsort -unique $ids] {
4910 lappend idlist [lindex $idx 1]
4912 return $idlist
4915 proc rowsequal {a b} {
4916 while {[set i [lsearch -exact $a {}]] >= 0} {
4917 set a [lreplace $a $i $i]
4919 while {[set i [lsearch -exact $b {}]] >= 0} {
4920 set b [lreplace $b $i $i]
4922 return [expr {$a eq $b}]
4925 proc makeupline {id row rend col} {
4926 global rowidlist uparrowlen downarrowlen mingaplen
4928 for {set r $rend} {1} {set r $rstart} {
4929 set rstart [prevuse $id $r]
4930 if {$rstart < 0} return
4931 if {$rstart < $row} break
4933 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4934 set rstart [expr {$rend - $uparrowlen - 1}]
4936 for {set r $rstart} {[incr r] <= $row} {} {
4937 set idlist [lindex $rowidlist $r]
4938 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4939 set col [idcol $idlist $id $col]
4940 lset rowidlist $r [linsert $idlist $col $id]
4941 changedrow $r
4946 proc layoutrows {row endrow} {
4947 global rowidlist rowisopt rowfinal displayorder
4948 global uparrowlen downarrowlen maxwidth mingaplen
4949 global children parentlist
4950 global commitidx viewcomplete curview
4952 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4953 set idlist {}
4954 if {$row > 0} {
4955 set rm1 [expr {$row - 1}]
4956 foreach id [lindex $rowidlist $rm1] {
4957 if {$id ne {}} {
4958 lappend idlist $id
4961 set final [lindex $rowfinal $rm1]
4963 for {} {$row < $endrow} {incr row} {
4964 set rm1 [expr {$row - 1}]
4965 if {$rm1 < 0 || $idlist eq {}} {
4966 set idlist [make_idlist $row]
4967 set final 1
4968 } else {
4969 set id [lindex $displayorder $rm1]
4970 set col [lsearch -exact $idlist $id]
4971 set idlist [lreplace $idlist $col $col]
4972 foreach p [lindex $parentlist $rm1] {
4973 if {[lsearch -exact $idlist $p] < 0} {
4974 set col [idcol $idlist $p $col]
4975 set idlist [linsert $idlist $col $p]
4976 # if not the first child, we have to insert a line going up
4977 if {$id ne [lindex $children($curview,$p) 0]} {
4978 makeupline $p $rm1 $row $col
4982 set id [lindex $displayorder $row]
4983 if {$row > $downarrowlen} {
4984 set termrow [expr {$row - $downarrowlen - 1}]
4985 foreach p [lindex $parentlist $termrow] {
4986 set i [lsearch -exact $idlist $p]
4987 if {$i < 0} continue
4988 set nr [nextuse $p $termrow]
4989 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4990 set idlist [lreplace $idlist $i $i]
4994 set col [lsearch -exact $idlist $id]
4995 if {$col < 0} {
4996 set col [idcol $idlist $id]
4997 set idlist [linsert $idlist $col $id]
4998 if {$children($curview,$id) ne {}} {
4999 makeupline $id $rm1 $row $col
5002 set r [expr {$row + $uparrowlen - 1}]
5003 if {$r < $commitidx($curview)} {
5004 set x $col
5005 foreach p [lindex $parentlist $r] {
5006 if {[lsearch -exact $idlist $p] >= 0} continue
5007 set fk [lindex $children($curview,$p) 0]
5008 if {[rowofcommit $fk] < $row} {
5009 set x [idcol $idlist $p $x]
5010 set idlist [linsert $idlist $x $p]
5013 if {[incr r] < $commitidx($curview)} {
5014 set p [lindex $displayorder $r]
5015 if {[lsearch -exact $idlist $p] < 0} {
5016 set fk [lindex $children($curview,$p) 0]
5017 if {$fk ne {} && [rowofcommit $fk] < $row} {
5018 set x [idcol $idlist $p $x]
5019 set idlist [linsert $idlist $x $p]
5025 if {$final && !$viewcomplete($curview) &&
5026 $row + $uparrowlen + $mingaplen + $downarrowlen
5027 >= $commitidx($curview)} {
5028 set final 0
5030 set l [llength $rowidlist]
5031 if {$row == $l} {
5032 lappend rowidlist $idlist
5033 lappend rowisopt 0
5034 lappend rowfinal $final
5035 } elseif {$row < $l} {
5036 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5037 lset rowidlist $row $idlist
5038 changedrow $row
5040 lset rowfinal $row $final
5041 } else {
5042 set pad [ntimes [expr {$row - $l}] {}]
5043 set rowidlist [concat $rowidlist $pad]
5044 lappend rowidlist $idlist
5045 set rowfinal [concat $rowfinal $pad]
5046 lappend rowfinal $final
5047 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5050 return $row
5053 proc changedrow {row} {
5054 global displayorder iddrawn rowisopt need_redisplay
5056 set l [llength $rowisopt]
5057 if {$row < $l} {
5058 lset rowisopt $row 0
5059 if {$row + 1 < $l} {
5060 lset rowisopt [expr {$row + 1}] 0
5061 if {$row + 2 < $l} {
5062 lset rowisopt [expr {$row + 2}] 0
5066 set id [lindex $displayorder $row]
5067 if {[info exists iddrawn($id)]} {
5068 set need_redisplay 1
5072 proc insert_pad {row col npad} {
5073 global rowidlist
5075 set pad [ntimes $npad {}]
5076 set idlist [lindex $rowidlist $row]
5077 set bef [lrange $idlist 0 [expr {$col - 1}]]
5078 set aft [lrange $idlist $col end]
5079 set i [lsearch -exact $aft {}]
5080 if {$i > 0} {
5081 set aft [lreplace $aft $i $i]
5083 lset rowidlist $row [concat $bef $pad $aft]
5084 changedrow $row
5087 proc optimize_rows {row col endrow} {
5088 global rowidlist rowisopt displayorder curview children
5090 if {$row < 1} {
5091 set row 1
5093 for {} {$row < $endrow} {incr row; set col 0} {
5094 if {[lindex $rowisopt $row]} continue
5095 set haspad 0
5096 set y0 [expr {$row - 1}]
5097 set ym [expr {$row - 2}]
5098 set idlist [lindex $rowidlist $row]
5099 set previdlist [lindex $rowidlist $y0]
5100 if {$idlist eq {} || $previdlist eq {}} continue
5101 if {$ym >= 0} {
5102 set pprevidlist [lindex $rowidlist $ym]
5103 if {$pprevidlist eq {}} continue
5104 } else {
5105 set pprevidlist {}
5107 set x0 -1
5108 set xm -1
5109 for {} {$col < [llength $idlist]} {incr col} {
5110 set id [lindex $idlist $col]
5111 if {[lindex $previdlist $col] eq $id} continue
5112 if {$id eq {}} {
5113 set haspad 1
5114 continue
5116 set x0 [lsearch -exact $previdlist $id]
5117 if {$x0 < 0} continue
5118 set z [expr {$x0 - $col}]
5119 set isarrow 0
5120 set z0 {}
5121 if {$ym >= 0} {
5122 set xm [lsearch -exact $pprevidlist $id]
5123 if {$xm >= 0} {
5124 set z0 [expr {$xm - $x0}]
5127 if {$z0 eq {}} {
5128 # if row y0 is the first child of $id then it's not an arrow
5129 if {[lindex $children($curview,$id) 0] ne
5130 [lindex $displayorder $y0]} {
5131 set isarrow 1
5134 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5135 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5136 set isarrow 1
5138 # Looking at lines from this row to the previous row,
5139 # make them go straight up if they end in an arrow on
5140 # the previous row; otherwise make them go straight up
5141 # or at 45 degrees.
5142 if {$z < -1 || ($z < 0 && $isarrow)} {
5143 # Line currently goes left too much;
5144 # insert pads in the previous row, then optimize it
5145 set npad [expr {-1 - $z + $isarrow}]
5146 insert_pad $y0 $x0 $npad
5147 if {$y0 > 0} {
5148 optimize_rows $y0 $x0 $row
5150 set previdlist [lindex $rowidlist $y0]
5151 set x0 [lsearch -exact $previdlist $id]
5152 set z [expr {$x0 - $col}]
5153 if {$z0 ne {}} {
5154 set pprevidlist [lindex $rowidlist $ym]
5155 set xm [lsearch -exact $pprevidlist $id]
5156 set z0 [expr {$xm - $x0}]
5158 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5159 # Line currently goes right too much;
5160 # insert pads in this line
5161 set npad [expr {$z - 1 + $isarrow}]
5162 insert_pad $row $col $npad
5163 set idlist [lindex $rowidlist $row]
5164 incr col $npad
5165 set z [expr {$x0 - $col}]
5166 set haspad 1
5168 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5169 # this line links to its first child on row $row-2
5170 set id [lindex $displayorder $ym]
5171 set xc [lsearch -exact $pprevidlist $id]
5172 if {$xc >= 0} {
5173 set z0 [expr {$xc - $x0}]
5176 # avoid lines jigging left then immediately right
5177 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5178 insert_pad $y0 $x0 1
5179 incr x0
5180 optimize_rows $y0 $x0 $row
5181 set previdlist [lindex $rowidlist $y0]
5184 if {!$haspad} {
5185 # Find the first column that doesn't have a line going right
5186 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5187 set id [lindex $idlist $col]
5188 if {$id eq {}} break
5189 set x0 [lsearch -exact $previdlist $id]
5190 if {$x0 < 0} {
5191 # check if this is the link to the first child
5192 set kid [lindex $displayorder $y0]
5193 if {[lindex $children($curview,$id) 0] eq $kid} {
5194 # it is, work out offset to child
5195 set x0 [lsearch -exact $previdlist $kid]
5198 if {$x0 <= $col} break
5200 # Insert a pad at that column as long as it has a line and
5201 # isn't the last column
5202 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5203 set idlist [linsert $idlist $col {}]
5204 lset rowidlist $row $idlist
5205 changedrow $row
5211 proc xc {row col} {
5212 global canvx0 linespc
5213 return [expr {$canvx0 + $col * $linespc}]
5216 proc yc {row} {
5217 global canvy0 linespc
5218 return [expr {$canvy0 + $row * $linespc}]
5221 proc linewidth {id} {
5222 global thickerline lthickness
5224 set wid $lthickness
5225 if {[info exists thickerline] && $id eq $thickerline} {
5226 set wid [expr {2 * $lthickness}]
5228 return $wid
5231 proc rowranges {id} {
5232 global curview children uparrowlen downarrowlen
5233 global rowidlist
5235 set kids $children($curview,$id)
5236 if {$kids eq {}} {
5237 return {}
5239 set ret {}
5240 lappend kids $id
5241 foreach child $kids {
5242 if {![commitinview $child $curview]} break
5243 set row [rowofcommit $child]
5244 if {![info exists prev]} {
5245 lappend ret [expr {$row + 1}]
5246 } else {
5247 if {$row <= $prevrow} {
5248 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5250 # see if the line extends the whole way from prevrow to row
5251 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5252 [lsearch -exact [lindex $rowidlist \
5253 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5254 # it doesn't, see where it ends
5255 set r [expr {$prevrow + $downarrowlen}]
5256 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5257 while {[incr r -1] > $prevrow &&
5258 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5259 } else {
5260 while {[incr r] <= $row &&
5261 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5262 incr r -1
5264 lappend ret $r
5265 # see where it starts up again
5266 set r [expr {$row - $uparrowlen}]
5267 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5268 while {[incr r] < $row &&
5269 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5270 } else {
5271 while {[incr r -1] >= $prevrow &&
5272 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5273 incr r
5275 lappend ret $r
5278 if {$child eq $id} {
5279 lappend ret $row
5281 set prev $child
5282 set prevrow $row
5284 return $ret
5287 proc drawlineseg {id row endrow arrowlow} {
5288 global rowidlist displayorder iddrawn linesegs
5289 global canv colormap linespc curview maxlinelen parentlist
5291 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5292 set le [expr {$row + 1}]
5293 set arrowhigh 1
5294 while {1} {
5295 set c [lsearch -exact [lindex $rowidlist $le] $id]
5296 if {$c < 0} {
5297 incr le -1
5298 break
5300 lappend cols $c
5301 set x [lindex $displayorder $le]
5302 if {$x eq $id} {
5303 set arrowhigh 0
5304 break
5306 if {[info exists iddrawn($x)] || $le == $endrow} {
5307 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5308 if {$c >= 0} {
5309 lappend cols $c
5310 set arrowhigh 0
5312 break
5314 incr le
5316 if {$le <= $row} {
5317 return $row
5320 set lines {}
5321 set i 0
5322 set joinhigh 0
5323 if {[info exists linesegs($id)]} {
5324 set lines $linesegs($id)
5325 foreach li $lines {
5326 set r0 [lindex $li 0]
5327 if {$r0 > $row} {
5328 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5329 set joinhigh 1
5331 break
5333 incr i
5336 set joinlow 0
5337 if {$i > 0} {
5338 set li [lindex $lines [expr {$i-1}]]
5339 set r1 [lindex $li 1]
5340 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5341 set joinlow 1
5345 set x [lindex $cols [expr {$le - $row}]]
5346 set xp [lindex $cols [expr {$le - 1 - $row}]]
5347 set dir [expr {$xp - $x}]
5348 if {$joinhigh} {
5349 set ith [lindex $lines $i 2]
5350 set coords [$canv coords $ith]
5351 set ah [$canv itemcget $ith -arrow]
5352 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5353 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5354 if {$x2 ne {} && $x - $x2 == $dir} {
5355 set coords [lrange $coords 0 end-2]
5357 } else {
5358 set coords [list [xc $le $x] [yc $le]]
5360 if {$joinlow} {
5361 set itl [lindex $lines [expr {$i-1}] 2]
5362 set al [$canv itemcget $itl -arrow]
5363 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5364 } elseif {$arrowlow} {
5365 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5366 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5367 set arrowlow 0
5370 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5371 for {set y $le} {[incr y -1] > $row} {} {
5372 set x $xp
5373 set xp [lindex $cols [expr {$y - 1 - $row}]]
5374 set ndir [expr {$xp - $x}]
5375 if {$dir != $ndir || $xp < 0} {
5376 lappend coords [xc $y $x] [yc $y]
5378 set dir $ndir
5380 if {!$joinlow} {
5381 if {$xp < 0} {
5382 # join parent line to first child
5383 set ch [lindex $displayorder $row]
5384 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5385 if {$xc < 0} {
5386 puts "oops: drawlineseg: child $ch not on row $row"
5387 } elseif {$xc != $x} {
5388 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5389 set d [expr {int(0.5 * $linespc)}]
5390 set x1 [xc $row $x]
5391 if {$xc < $x} {
5392 set x2 [expr {$x1 - $d}]
5393 } else {
5394 set x2 [expr {$x1 + $d}]
5396 set y2 [yc $row]
5397 set y1 [expr {$y2 + $d}]
5398 lappend coords $x1 $y1 $x2 $y2
5399 } elseif {$xc < $x - 1} {
5400 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5401 } elseif {$xc > $x + 1} {
5402 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5404 set x $xc
5406 lappend coords [xc $row $x] [yc $row]
5407 } else {
5408 set xn [xc $row $xp]
5409 set yn [yc $row]
5410 lappend coords $xn $yn
5412 if {!$joinhigh} {
5413 assigncolor $id
5414 set t [$canv create line $coords -width [linewidth $id] \
5415 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5416 $canv lower $t
5417 bindline $t $id
5418 set lines [linsert $lines $i [list $row $le $t]]
5419 } else {
5420 $canv coords $ith $coords
5421 if {$arrow ne $ah} {
5422 $canv itemconf $ith -arrow $arrow
5424 lset lines $i 0 $row
5426 } else {
5427 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5428 set ndir [expr {$xo - $xp}]
5429 set clow [$canv coords $itl]
5430 if {$dir == $ndir} {
5431 set clow [lrange $clow 2 end]
5433 set coords [concat $coords $clow]
5434 if {!$joinhigh} {
5435 lset lines [expr {$i-1}] 1 $le
5436 } else {
5437 # coalesce two pieces
5438 $canv delete $ith
5439 set b [lindex $lines [expr {$i-1}] 0]
5440 set e [lindex $lines $i 1]
5441 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5443 $canv coords $itl $coords
5444 if {$arrow ne $al} {
5445 $canv itemconf $itl -arrow $arrow
5449 set linesegs($id) $lines
5450 return $le
5453 proc drawparentlinks {id row} {
5454 global rowidlist canv colormap curview parentlist
5455 global idpos linespc
5457 set rowids [lindex $rowidlist $row]
5458 set col [lsearch -exact $rowids $id]
5459 if {$col < 0} return
5460 set olds [lindex $parentlist $row]
5461 set row2 [expr {$row + 1}]
5462 set x [xc $row $col]
5463 set y [yc $row]
5464 set y2 [yc $row2]
5465 set d [expr {int(0.5 * $linespc)}]
5466 set ymid [expr {$y + $d}]
5467 set ids [lindex $rowidlist $row2]
5468 # rmx = right-most X coord used
5469 set rmx 0
5470 foreach p $olds {
5471 set i [lsearch -exact $ids $p]
5472 if {$i < 0} {
5473 puts "oops, parent $p of $id not in list"
5474 continue
5476 set x2 [xc $row2 $i]
5477 if {$x2 > $rmx} {
5478 set rmx $x2
5480 set j [lsearch -exact $rowids $p]
5481 if {$j < 0} {
5482 # drawlineseg will do this one for us
5483 continue
5485 assigncolor $p
5486 # should handle duplicated parents here...
5487 set coords [list $x $y]
5488 if {$i != $col} {
5489 # if attaching to a vertical segment, draw a smaller
5490 # slant for visual distinctness
5491 if {$i == $j} {
5492 if {$i < $col} {
5493 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5494 } else {
5495 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5497 } elseif {$i < $col && $i < $j} {
5498 # segment slants towards us already
5499 lappend coords [xc $row $j] $y
5500 } else {
5501 if {$i < $col - 1} {
5502 lappend coords [expr {$x2 + $linespc}] $y
5503 } elseif {$i > $col + 1} {
5504 lappend coords [expr {$x2 - $linespc}] $y
5506 lappend coords $x2 $y2
5508 } else {
5509 lappend coords $x2 $y2
5511 set t [$canv create line $coords -width [linewidth $p] \
5512 -fill $colormap($p) -tags lines.$p]
5513 $canv lower $t
5514 bindline $t $p
5516 if {$rmx > [lindex $idpos($id) 1]} {
5517 lset idpos($id) 1 $rmx
5518 redrawtags $id
5522 proc drawlines {id} {
5523 global canv
5525 $canv itemconf lines.$id -width [linewidth $id]
5528 proc drawcmittext {id row col} {
5529 global linespc canv canv2 canv3 fgcolor curview
5530 global cmitlisted commitinfo rowidlist parentlist
5531 global rowtextx idpos idtags idheads idotherrefs
5532 global linehtag linentag linedtag selectedline
5533 global canvxmax boldids boldnameids fgcolor
5534 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5536 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5537 set listed $cmitlisted($curview,$id)
5538 if {$id eq $nullid} {
5539 set ofill red
5540 } elseif {$id eq $nullid2} {
5541 set ofill green
5542 } elseif {$id eq $mainheadid} {
5543 set ofill yellow
5544 } else {
5545 set ofill [lindex $circlecolors $listed]
5547 set x [xc $row $col]
5548 set y [yc $row]
5549 set orad [expr {$linespc / 3}]
5550 if {$listed <= 2} {
5551 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5552 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5553 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5554 } elseif {$listed == 3} {
5555 # triangle pointing left for left-side commits
5556 set t [$canv create polygon \
5557 [expr {$x - $orad}] $y \
5558 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5559 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5560 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5561 } else {
5562 # triangle pointing right for right-side commits
5563 set t [$canv create polygon \
5564 [expr {$x + $orad - 1}] $y \
5565 [expr {$x - $orad}] [expr {$y - $orad}] \
5566 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5567 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5569 set circleitem($row) $t
5570 $canv raise $t
5571 $canv bind $t <1> {selcanvline {} %x %y}
5572 set rmx [llength [lindex $rowidlist $row]]
5573 set olds [lindex $parentlist $row]
5574 if {$olds ne {}} {
5575 set nextids [lindex $rowidlist [expr {$row + 1}]]
5576 foreach p $olds {
5577 set i [lsearch -exact $nextids $p]
5578 if {$i > $rmx} {
5579 set rmx $i
5583 set xt [xc $row $rmx]
5584 set rowtextx($row) $xt
5585 set idpos($id) [list $x $xt $y]
5586 if {[info exists idtags($id)] || [info exists idheads($id)]
5587 || [info exists idotherrefs($id)]} {
5588 set xt [drawtags $id $x $xt $y]
5590 set headline [lindex $commitinfo($id) 0]
5591 set name [lindex $commitinfo($id) 1]
5592 set date [lindex $commitinfo($id) 2]
5593 set date [formatdate $date]
5594 set font mainfont
5595 set nfont mainfont
5596 set isbold [ishighlighted $id]
5597 if {$isbold > 0} {
5598 lappend boldids $id
5599 set font mainfontbold
5600 if {$isbold > 1} {
5601 lappend boldnameids $id
5602 set nfont mainfontbold
5605 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5606 -text $headline -font $font -tags text]
5607 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5608 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5609 -text $name -font $nfont -tags text]
5610 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5611 -text $date -font mainfont -tags text]
5612 if {$selectedline == $row} {
5613 make_secsel $id
5615 set xr [expr {$xt + [font measure $font $headline]}]
5616 if {$xr > $canvxmax} {
5617 set canvxmax $xr
5618 setcanvscroll
5622 proc drawcmitrow {row} {
5623 global displayorder rowidlist nrows_drawn
5624 global iddrawn markingmatches
5625 global commitinfo numcommits
5626 global filehighlight fhighlights findpattern nhighlights
5627 global hlview vhighlights
5628 global highlight_related rhighlights
5630 if {$row >= $numcommits} return
5632 set id [lindex $displayorder $row]
5633 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5634 askvhighlight $row $id
5636 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5637 askfilehighlight $row $id
5639 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5640 askfindhighlight $row $id
5642 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5643 askrelhighlight $row $id
5645 if {![info exists iddrawn($id)]} {
5646 set col [lsearch -exact [lindex $rowidlist $row] $id]
5647 if {$col < 0} {
5648 puts "oops, row $row id $id not in list"
5649 return
5651 if {![info exists commitinfo($id)]} {
5652 getcommit $id
5654 assigncolor $id
5655 drawcmittext $id $row $col
5656 set iddrawn($id) 1
5657 incr nrows_drawn
5659 if {$markingmatches} {
5660 markrowmatches $row $id
5664 proc drawcommits {row {endrow {}}} {
5665 global numcommits iddrawn displayorder curview need_redisplay
5666 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5668 if {$row < 0} {
5669 set row 0
5671 if {$endrow eq {}} {
5672 set endrow $row
5674 if {$endrow >= $numcommits} {
5675 set endrow [expr {$numcommits - 1}]
5678 set rl1 [expr {$row - $downarrowlen - 3}]
5679 if {$rl1 < 0} {
5680 set rl1 0
5682 set ro1 [expr {$row - 3}]
5683 if {$ro1 < 0} {
5684 set ro1 0
5686 set r2 [expr {$endrow + $uparrowlen + 3}]
5687 if {$r2 > $numcommits} {
5688 set r2 $numcommits
5690 for {set r $rl1} {$r < $r2} {incr r} {
5691 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5692 if {$rl1 < $r} {
5693 layoutrows $rl1 $r
5695 set rl1 [expr {$r + 1}]
5698 if {$rl1 < $r} {
5699 layoutrows $rl1 $r
5701 optimize_rows $ro1 0 $r2
5702 if {$need_redisplay || $nrows_drawn > 2000} {
5703 clear_display
5704 drawvisible
5707 # make the lines join to already-drawn rows either side
5708 set r [expr {$row - 1}]
5709 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5710 set r $row
5712 set er [expr {$endrow + 1}]
5713 if {$er >= $numcommits ||
5714 ![info exists iddrawn([lindex $displayorder $er])]} {
5715 set er $endrow
5717 for {} {$r <= $er} {incr r} {
5718 set id [lindex $displayorder $r]
5719 set wasdrawn [info exists iddrawn($id)]
5720 drawcmitrow $r
5721 if {$r == $er} break
5722 set nextid [lindex $displayorder [expr {$r + 1}]]
5723 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5724 drawparentlinks $id $r
5726 set rowids [lindex $rowidlist $r]
5727 foreach lid $rowids {
5728 if {$lid eq {}} continue
5729 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5730 if {$lid eq $id} {
5731 # see if this is the first child of any of its parents
5732 foreach p [lindex $parentlist $r] {
5733 if {[lsearch -exact $rowids $p] < 0} {
5734 # make this line extend up to the child
5735 set lineend($p) [drawlineseg $p $r $er 0]
5738 } else {
5739 set lineend($lid) [drawlineseg $lid $r $er 1]
5745 proc undolayout {row} {
5746 global uparrowlen mingaplen downarrowlen
5747 global rowidlist rowisopt rowfinal need_redisplay
5749 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5750 if {$r < 0} {
5751 set r 0
5753 if {[llength $rowidlist] > $r} {
5754 incr r -1
5755 set rowidlist [lrange $rowidlist 0 $r]
5756 set rowfinal [lrange $rowfinal 0 $r]
5757 set rowisopt [lrange $rowisopt 0 $r]
5758 set need_redisplay 1
5759 run drawvisible
5763 proc drawvisible {} {
5764 global canv linespc curview vrowmod selectedline targetrow targetid
5765 global need_redisplay cscroll numcommits
5767 set fs [$canv yview]
5768 set ymax [lindex [$canv cget -scrollregion] 3]
5769 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5770 set f0 [lindex $fs 0]
5771 set f1 [lindex $fs 1]
5772 set y0 [expr {int($f0 * $ymax)}]
5773 set y1 [expr {int($f1 * $ymax)}]
5775 if {[info exists targetid]} {
5776 if {[commitinview $targetid $curview]} {
5777 set r [rowofcommit $targetid]
5778 if {$r != $targetrow} {
5779 # Fix up the scrollregion and change the scrolling position
5780 # now that our target row has moved.
5781 set diff [expr {($r - $targetrow) * $linespc}]
5782 set targetrow $r
5783 setcanvscroll
5784 set ymax [lindex [$canv cget -scrollregion] 3]
5785 incr y0 $diff
5786 incr y1 $diff
5787 set f0 [expr {$y0 / $ymax}]
5788 set f1 [expr {$y1 / $ymax}]
5789 allcanvs yview moveto $f0
5790 $cscroll set $f0 $f1
5791 set need_redisplay 1
5793 } else {
5794 unset targetid
5798 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5799 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5800 if {$endrow >= $vrowmod($curview)} {
5801 update_arcrows $curview
5803 if {$selectedline ne {} &&
5804 $row <= $selectedline && $selectedline <= $endrow} {
5805 set targetrow $selectedline
5806 } elseif {[info exists targetid]} {
5807 set targetrow [expr {int(($row + $endrow) / 2)}]
5809 if {[info exists targetrow]} {
5810 if {$targetrow >= $numcommits} {
5811 set targetrow [expr {$numcommits - 1}]
5813 set targetid [commitonrow $targetrow]
5815 drawcommits $row $endrow
5818 proc clear_display {} {
5819 global iddrawn linesegs need_redisplay nrows_drawn
5820 global vhighlights fhighlights nhighlights rhighlights
5821 global linehtag linentag linedtag boldids boldnameids
5823 allcanvs delete all
5824 catch {unset iddrawn}
5825 catch {unset linesegs}
5826 catch {unset linehtag}
5827 catch {unset linentag}
5828 catch {unset linedtag}
5829 set boldids {}
5830 set boldnameids {}
5831 catch {unset vhighlights}
5832 catch {unset fhighlights}
5833 catch {unset nhighlights}
5834 catch {unset rhighlights}
5835 set need_redisplay 0
5836 set nrows_drawn 0
5839 proc findcrossings {id} {
5840 global rowidlist parentlist numcommits displayorder
5842 set cross {}
5843 set ccross {}
5844 foreach {s e} [rowranges $id] {
5845 if {$e >= $numcommits} {
5846 set e [expr {$numcommits - 1}]
5848 if {$e <= $s} continue
5849 for {set row $e} {[incr row -1] >= $s} {} {
5850 set x [lsearch -exact [lindex $rowidlist $row] $id]
5851 if {$x < 0} break
5852 set olds [lindex $parentlist $row]
5853 set kid [lindex $displayorder $row]
5854 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5855 if {$kidx < 0} continue
5856 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5857 foreach p $olds {
5858 set px [lsearch -exact $nextrow $p]
5859 if {$px < 0} continue
5860 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5861 if {[lsearch -exact $ccross $p] >= 0} continue
5862 if {$x == $px + ($kidx < $px? -1: 1)} {
5863 lappend ccross $p
5864 } elseif {[lsearch -exact $cross $p] < 0} {
5865 lappend cross $p
5871 return [concat $ccross {{}} $cross]
5874 proc assigncolor {id} {
5875 global colormap colors nextcolor
5876 global parents children children curview
5878 if {[info exists colormap($id)]} return
5879 set ncolors [llength $colors]
5880 if {[info exists children($curview,$id)]} {
5881 set kids $children($curview,$id)
5882 } else {
5883 set kids {}
5885 if {[llength $kids] == 1} {
5886 set child [lindex $kids 0]
5887 if {[info exists colormap($child)]
5888 && [llength $parents($curview,$child)] == 1} {
5889 set colormap($id) $colormap($child)
5890 return
5893 set badcolors {}
5894 set origbad {}
5895 foreach x [findcrossings $id] {
5896 if {$x eq {}} {
5897 # delimiter between corner crossings and other crossings
5898 if {[llength $badcolors] >= $ncolors - 1} break
5899 set origbad $badcolors
5901 if {[info exists colormap($x)]
5902 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5903 lappend badcolors $colormap($x)
5906 if {[llength $badcolors] >= $ncolors} {
5907 set badcolors $origbad
5909 set origbad $badcolors
5910 if {[llength $badcolors] < $ncolors - 1} {
5911 foreach child $kids {
5912 if {[info exists colormap($child)]
5913 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5914 lappend badcolors $colormap($child)
5916 foreach p $parents($curview,$child) {
5917 if {[info exists colormap($p)]
5918 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5919 lappend badcolors $colormap($p)
5923 if {[llength $badcolors] >= $ncolors} {
5924 set badcolors $origbad
5927 for {set i 0} {$i <= $ncolors} {incr i} {
5928 set c [lindex $colors $nextcolor]
5929 if {[incr nextcolor] >= $ncolors} {
5930 set nextcolor 0
5932 if {[lsearch -exact $badcolors $c]} break
5934 set colormap($id) $c
5937 proc bindline {t id} {
5938 global canv
5940 $canv bind $t <Enter> "lineenter %x %y $id"
5941 $canv bind $t <Motion> "linemotion %x %y $id"
5942 $canv bind $t <Leave> "lineleave $id"
5943 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5946 proc drawtags {id x xt y1} {
5947 global idtags idheads idotherrefs mainhead
5948 global linespc lthickness
5949 global canv rowtextx curview fgcolor bgcolor ctxbut
5951 set marks {}
5952 set ntags 0
5953 set nheads 0
5954 if {[info exists idtags($id)]} {
5955 set marks $idtags($id)
5956 set ntags [llength $marks]
5958 if {[info exists idheads($id)]} {
5959 set marks [concat $marks $idheads($id)]
5960 set nheads [llength $idheads($id)]
5962 if {[info exists idotherrefs($id)]} {
5963 set marks [concat $marks $idotherrefs($id)]
5965 if {$marks eq {}} {
5966 return $xt
5969 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5970 set yt [expr {$y1 - 0.5 * $linespc}]
5971 set yb [expr {$yt + $linespc - 1}]
5972 set xvals {}
5973 set wvals {}
5974 set i -1
5975 foreach tag $marks {
5976 incr i
5977 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5978 set wid [font measure mainfontbold $tag]
5979 } else {
5980 set wid [font measure mainfont $tag]
5982 lappend xvals $xt
5983 lappend wvals $wid
5984 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5986 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5987 -width $lthickness -fill black -tags tag.$id]
5988 $canv lower $t
5989 foreach tag $marks x $xvals wid $wvals {
5990 set xl [expr {$x + $delta}]
5991 set xr [expr {$x + $delta + $wid + $lthickness}]
5992 set font mainfont
5993 if {[incr ntags -1] >= 0} {
5994 # draw a tag
5995 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5996 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5997 -width 1 -outline black -fill yellow -tags tag.$id]
5998 $canv bind $t <1> [list showtag $tag 1]
5999 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6000 } else {
6001 # draw a head or other ref
6002 if {[incr nheads -1] >= 0} {
6003 set col green
6004 if {$tag eq $mainhead} {
6005 set font mainfontbold
6007 } else {
6008 set col "#ddddff"
6010 set xl [expr {$xl - $delta/2}]
6011 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6012 -width 1 -outline black -fill $col -tags tag.$id
6013 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6014 set rwid [font measure mainfont $remoteprefix]
6015 set xi [expr {$x + 1}]
6016 set yti [expr {$yt + 1}]
6017 set xri [expr {$x + $rwid}]
6018 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6019 -width 0 -fill "#ffddaa" -tags tag.$id
6022 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6023 -font $font -tags [list tag.$id text]]
6024 if {$ntags >= 0} {
6025 $canv bind $t <1> [list showtag $tag 1]
6026 } elseif {$nheads >= 0} {
6027 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6030 return $xt
6033 proc xcoord {i level ln} {
6034 global canvx0 xspc1 xspc2
6036 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6037 if {$i > 0 && $i == $level} {
6038 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6039 } elseif {$i > $level} {
6040 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6042 return $x
6045 proc show_status {msg} {
6046 global canv fgcolor
6048 clear_display
6049 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6050 -tags text -fill $fgcolor
6053 # Don't change the text pane cursor if it is currently the hand cursor,
6054 # showing that we are over a sha1 ID link.
6055 proc settextcursor {c} {
6056 global ctext curtextcursor
6058 if {[$ctext cget -cursor] == $curtextcursor} {
6059 $ctext config -cursor $c
6061 set curtextcursor $c
6064 proc nowbusy {what {name {}}} {
6065 global isbusy busyname statusw
6067 if {[array names isbusy] eq {}} {
6068 . config -cursor watch
6069 settextcursor watch
6071 set isbusy($what) 1
6072 set busyname($what) $name
6073 if {$name ne {}} {
6074 $statusw conf -text $name
6078 proc notbusy {what} {
6079 global isbusy maincursor textcursor busyname statusw
6081 catch {
6082 unset isbusy($what)
6083 if {$busyname($what) ne {} &&
6084 [$statusw cget -text] eq $busyname($what)} {
6085 $statusw conf -text {}
6088 if {[array names isbusy] eq {}} {
6089 . config -cursor $maincursor
6090 settextcursor $textcursor
6094 proc findmatches {f} {
6095 global findtype findstring
6096 if {$findtype == [mc "Regexp"]} {
6097 set matches [regexp -indices -all -inline $findstring $f]
6098 } else {
6099 set fs $findstring
6100 if {$findtype == [mc "IgnCase"]} {
6101 set f [string tolower $f]
6102 set fs [string tolower $fs]
6104 set matches {}
6105 set i 0
6106 set l [string length $fs]
6107 while {[set j [string first $fs $f $i]] >= 0} {
6108 lappend matches [list $j [expr {$j+$l-1}]]
6109 set i [expr {$j + $l}]
6112 return $matches
6115 proc dofind {{dirn 1} {wrap 1}} {
6116 global findstring findstartline findcurline selectedline numcommits
6117 global gdttype filehighlight fh_serial find_dirn findallowwrap
6119 if {[info exists find_dirn]} {
6120 if {$find_dirn == $dirn} return
6121 stopfinding
6123 focus .
6124 if {$findstring eq {} || $numcommits == 0} return
6125 if {$selectedline eq {}} {
6126 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6127 } else {
6128 set findstartline $selectedline
6130 set findcurline $findstartline
6131 nowbusy finding [mc "Searching"]
6132 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6133 after cancel do_file_hl $fh_serial
6134 do_file_hl $fh_serial
6136 set find_dirn $dirn
6137 set findallowwrap $wrap
6138 run findmore
6141 proc stopfinding {} {
6142 global find_dirn findcurline fprogcoord
6144 if {[info exists find_dirn]} {
6145 unset find_dirn
6146 unset findcurline
6147 notbusy finding
6148 set fprogcoord 0
6149 adjustprogress
6151 stopblaming
6154 proc findmore {} {
6155 global commitdata commitinfo numcommits findpattern findloc
6156 global findstartline findcurline findallowwrap
6157 global find_dirn gdttype fhighlights fprogcoord
6158 global curview varcorder vrownum varccommits vrowmod
6160 if {![info exists find_dirn]} {
6161 return 0
6163 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6164 set l $findcurline
6165 set moretodo 0
6166 if {$find_dirn > 0} {
6167 incr l
6168 if {$l >= $numcommits} {
6169 set l 0
6171 if {$l <= $findstartline} {
6172 set lim [expr {$findstartline + 1}]
6173 } else {
6174 set lim $numcommits
6175 set moretodo $findallowwrap
6177 } else {
6178 if {$l == 0} {
6179 set l $numcommits
6181 incr l -1
6182 if {$l >= $findstartline} {
6183 set lim [expr {$findstartline - 1}]
6184 } else {
6185 set lim -1
6186 set moretodo $findallowwrap
6189 set n [expr {($lim - $l) * $find_dirn}]
6190 if {$n > 500} {
6191 set n 500
6192 set moretodo 1
6194 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6195 update_arcrows $curview
6197 set found 0
6198 set domore 1
6199 set ai [bsearch $vrownum($curview) $l]
6200 set a [lindex $varcorder($curview) $ai]
6201 set arow [lindex $vrownum($curview) $ai]
6202 set ids [lindex $varccommits($curview,$a)]
6203 set arowend [expr {$arow + [llength $ids]}]
6204 if {$gdttype eq [mc "containing:"]} {
6205 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6206 if {$l < $arow || $l >= $arowend} {
6207 incr ai $find_dirn
6208 set a [lindex $varcorder($curview) $ai]
6209 set arow [lindex $vrownum($curview) $ai]
6210 set ids [lindex $varccommits($curview,$a)]
6211 set arowend [expr {$arow + [llength $ids]}]
6213 set id [lindex $ids [expr {$l - $arow}]]
6214 # shouldn't happen unless git log doesn't give all the commits...
6215 if {![info exists commitdata($id)] ||
6216 ![doesmatch $commitdata($id)]} {
6217 continue
6219 if {![info exists commitinfo($id)]} {
6220 getcommit $id
6222 set info $commitinfo($id)
6223 foreach f $info ty $fldtypes {
6224 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6225 [doesmatch $f]} {
6226 set found 1
6227 break
6230 if {$found} break
6232 } else {
6233 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6234 if {$l < $arow || $l >= $arowend} {
6235 incr ai $find_dirn
6236 set a [lindex $varcorder($curview) $ai]
6237 set arow [lindex $vrownum($curview) $ai]
6238 set ids [lindex $varccommits($curview,$a)]
6239 set arowend [expr {$arow + [llength $ids]}]
6241 set id [lindex $ids [expr {$l - $arow}]]
6242 if {![info exists fhighlights($id)]} {
6243 # this sets fhighlights($id) to -1
6244 askfilehighlight $l $id
6246 if {$fhighlights($id) > 0} {
6247 set found $domore
6248 break
6250 if {$fhighlights($id) < 0} {
6251 if {$domore} {
6252 set domore 0
6253 set findcurline [expr {$l - $find_dirn}]
6258 if {$found || ($domore && !$moretodo)} {
6259 unset findcurline
6260 unset find_dirn
6261 notbusy finding
6262 set fprogcoord 0
6263 adjustprogress
6264 if {$found} {
6265 findselectline $l
6266 } else {
6267 bell
6269 return 0
6271 if {!$domore} {
6272 flushhighlights
6273 } else {
6274 set findcurline [expr {$l - $find_dirn}]
6276 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6277 if {$n < 0} {
6278 incr n $numcommits
6280 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6281 adjustprogress
6282 return $domore
6285 proc findselectline {l} {
6286 global findloc commentend ctext findcurline markingmatches gdttype
6288 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6289 set findcurline $l
6290 selectline $l 1
6291 if {$markingmatches &&
6292 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6293 # highlight the matches in the comments
6294 set f [$ctext get 1.0 $commentend]
6295 set matches [findmatches $f]
6296 foreach match $matches {
6297 set start [lindex $match 0]
6298 set end [expr {[lindex $match 1] + 1}]
6299 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6302 drawvisible
6305 # mark the bits of a headline or author that match a find string
6306 proc markmatches {canv l str tag matches font row} {
6307 global selectedline
6309 set bbox [$canv bbox $tag]
6310 set x0 [lindex $bbox 0]
6311 set y0 [lindex $bbox 1]
6312 set y1 [lindex $bbox 3]
6313 foreach match $matches {
6314 set start [lindex $match 0]
6315 set end [lindex $match 1]
6316 if {$start > $end} continue
6317 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6318 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6319 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6320 [expr {$x0+$xlen+2}] $y1 \
6321 -outline {} -tags [list match$l matches] -fill yellow]
6322 $canv lower $t
6323 if {$row == $selectedline} {
6324 $canv raise $t secsel
6329 proc unmarkmatches {} {
6330 global markingmatches
6332 allcanvs delete matches
6333 set markingmatches 0
6334 stopfinding
6337 proc selcanvline {w x y} {
6338 global canv canvy0 ctext linespc
6339 global rowtextx
6340 set ymax [lindex [$canv cget -scrollregion] 3]
6341 if {$ymax == {}} return
6342 set yfrac [lindex [$canv yview] 0]
6343 set y [expr {$y + $yfrac * $ymax}]
6344 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6345 if {$l < 0} {
6346 set l 0
6348 if {$w eq $canv} {
6349 set xmax [lindex [$canv cget -scrollregion] 2]
6350 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6351 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6353 unmarkmatches
6354 selectline $l 1
6357 proc commit_descriptor {p} {
6358 global commitinfo
6359 if {![info exists commitinfo($p)]} {
6360 getcommit $p
6362 set l "..."
6363 if {[llength $commitinfo($p)] > 1} {
6364 set l [lindex $commitinfo($p) 0]
6366 return "$p ($l)\n"
6369 # append some text to the ctext widget, and make any SHA1 ID
6370 # that we know about be a clickable link.
6371 proc appendwithlinks {text tags} {
6372 global ctext linknum curview
6374 set start [$ctext index "end - 1c"]
6375 $ctext insert end $text $tags
6376 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6377 foreach l $links {
6378 set s [lindex $l 0]
6379 set e [lindex $l 1]
6380 set linkid [string range $text $s $e]
6381 incr e
6382 $ctext tag delete link$linknum
6383 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6384 setlink $linkid link$linknum
6385 incr linknum
6389 proc setlink {id lk} {
6390 global curview ctext pendinglinks
6392 set known 0
6393 if {[string length $id] < 40} {
6394 set matches [longid $id]
6395 if {[llength $matches] > 0} {
6396 if {[llength $matches] > 1} return
6397 set known 1
6398 set id [lindex $matches 0]
6400 } else {
6401 set known [commitinview $id $curview]
6403 if {$known} {
6404 $ctext tag conf $lk -foreground blue -underline 1
6405 $ctext tag bind $lk <1> [list selbyid $id]
6406 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6407 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6408 } else {
6409 lappend pendinglinks($id) $lk
6410 interestedin $id {makelink %P}
6414 proc makelink {id} {
6415 global pendinglinks
6417 if {![info exists pendinglinks($id)]} return
6418 foreach lk $pendinglinks($id) {
6419 setlink $id $lk
6421 unset pendinglinks($id)
6424 proc linkcursor {w inc} {
6425 global linkentercount curtextcursor
6427 if {[incr linkentercount $inc] > 0} {
6428 $w configure -cursor hand2
6429 } else {
6430 $w configure -cursor $curtextcursor
6431 if {$linkentercount < 0} {
6432 set linkentercount 0
6437 proc viewnextline {dir} {
6438 global canv linespc
6440 $canv delete hover
6441 set ymax [lindex [$canv cget -scrollregion] 3]
6442 set wnow [$canv yview]
6443 set wtop [expr {[lindex $wnow 0] * $ymax}]
6444 set newtop [expr {$wtop + $dir * $linespc}]
6445 if {$newtop < 0} {
6446 set newtop 0
6447 } elseif {$newtop > $ymax} {
6448 set newtop $ymax
6450 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6453 # add a list of tag or branch names at position pos
6454 # returns the number of names inserted
6455 proc appendrefs {pos ids var} {
6456 global ctext linknum curview $var maxrefs
6458 if {[catch {$ctext index $pos}]} {
6459 return 0
6461 $ctext conf -state normal
6462 $ctext delete $pos "$pos lineend"
6463 set tags {}
6464 foreach id $ids {
6465 foreach tag [set $var\($id\)] {
6466 lappend tags [list $tag $id]
6469 if {[llength $tags] > $maxrefs} {
6470 $ctext insert $pos "many ([llength $tags])"
6471 } else {
6472 set tags [lsort -index 0 -decreasing $tags]
6473 set sep {}
6474 foreach ti $tags {
6475 set id [lindex $ti 1]
6476 set lk link$linknum
6477 incr linknum
6478 $ctext tag delete $lk
6479 $ctext insert $pos $sep
6480 $ctext insert $pos [lindex $ti 0] $lk
6481 setlink $id $lk
6482 set sep ", "
6485 $ctext conf -state disabled
6486 return [llength $tags]
6489 # called when we have finished computing the nearby tags
6490 proc dispneartags {delay} {
6491 global selectedline currentid showneartags tagphase
6493 if {$selectedline eq {} || !$showneartags} return
6494 after cancel dispnexttag
6495 if {$delay} {
6496 after 200 dispnexttag
6497 set tagphase -1
6498 } else {
6499 after idle dispnexttag
6500 set tagphase 0
6504 proc dispnexttag {} {
6505 global selectedline currentid showneartags tagphase ctext
6507 if {$selectedline eq {} || !$showneartags} return
6508 switch -- $tagphase {
6510 set dtags [desctags $currentid]
6511 if {$dtags ne {}} {
6512 appendrefs precedes $dtags idtags
6516 set atags [anctags $currentid]
6517 if {$atags ne {}} {
6518 appendrefs follows $atags idtags
6522 set dheads [descheads $currentid]
6523 if {$dheads ne {}} {
6524 if {[appendrefs branch $dheads idheads] > 1
6525 && [$ctext get "branch -3c"] eq "h"} {
6526 # turn "Branch" into "Branches"
6527 $ctext conf -state normal
6528 $ctext insert "branch -2c" "es"
6529 $ctext conf -state disabled
6534 if {[incr tagphase] <= 2} {
6535 after idle dispnexttag
6539 proc make_secsel {id} {
6540 global linehtag linentag linedtag canv canv2 canv3
6542 if {![info exists linehtag($id)]} return
6543 $canv delete secsel
6544 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6545 -tags secsel -fill [$canv cget -selectbackground]]
6546 $canv lower $t
6547 $canv2 delete secsel
6548 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6549 -tags secsel -fill [$canv2 cget -selectbackground]]
6550 $canv2 lower $t
6551 $canv3 delete secsel
6552 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6553 -tags secsel -fill [$canv3 cget -selectbackground]]
6554 $canv3 lower $t
6557 proc selectline {l isnew {desired_loc {}}} {
6558 global canv ctext commitinfo selectedline
6559 global canvy0 linespc parents children curview
6560 global currentid sha1entry
6561 global commentend idtags linknum
6562 global mergemax numcommits pending_select
6563 global cmitmode showneartags allcommits
6564 global targetrow targetid lastscrollrows
6565 global autoselect jump_to_here
6567 catch {unset pending_select}
6568 $canv delete hover
6569 normalline
6570 unsel_reflist
6571 stopfinding
6572 if {$l < 0 || $l >= $numcommits} return
6573 set id [commitonrow $l]
6574 set targetid $id
6575 set targetrow $l
6576 set selectedline $l
6577 set currentid $id
6578 if {$lastscrollrows < $numcommits} {
6579 setcanvscroll
6582 set y [expr {$canvy0 + $l * $linespc}]
6583 set ymax [lindex [$canv cget -scrollregion] 3]
6584 set ytop [expr {$y - $linespc - 1}]
6585 set ybot [expr {$y + $linespc + 1}]
6586 set wnow [$canv yview]
6587 set wtop [expr {[lindex $wnow 0] * $ymax}]
6588 set wbot [expr {[lindex $wnow 1] * $ymax}]
6589 set wh [expr {$wbot - $wtop}]
6590 set newtop $wtop
6591 if {$ytop < $wtop} {
6592 if {$ybot < $wtop} {
6593 set newtop [expr {$y - $wh / 2.0}]
6594 } else {
6595 set newtop $ytop
6596 if {$newtop > $wtop - $linespc} {
6597 set newtop [expr {$wtop - $linespc}]
6600 } elseif {$ybot > $wbot} {
6601 if {$ytop > $wbot} {
6602 set newtop [expr {$y - $wh / 2.0}]
6603 } else {
6604 set newtop [expr {$ybot - $wh}]
6605 if {$newtop < $wtop + $linespc} {
6606 set newtop [expr {$wtop + $linespc}]
6610 if {$newtop != $wtop} {
6611 if {$newtop < 0} {
6612 set newtop 0
6614 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6615 drawvisible
6618 make_secsel $id
6620 if {$isnew} {
6621 addtohistory [list selbyid $id]
6624 $sha1entry delete 0 end
6625 $sha1entry insert 0 $id
6626 if {$autoselect} {
6627 $sha1entry selection from 0
6628 $sha1entry selection to end
6630 rhighlight_sel $id
6632 $ctext conf -state normal
6633 clear_ctext
6634 set linknum 0
6635 if {![info exists commitinfo($id)]} {
6636 getcommit $id
6638 set info $commitinfo($id)
6639 set date [formatdate [lindex $info 2]]
6640 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6641 set date [formatdate [lindex $info 4]]
6642 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6643 if {[info exists idtags($id)]} {
6644 $ctext insert end [mc "Tags:"]
6645 foreach tag $idtags($id) {
6646 $ctext insert end " $tag"
6648 $ctext insert end "\n"
6651 set headers {}
6652 set olds $parents($curview,$id)
6653 if {[llength $olds] > 1} {
6654 set np 0
6655 foreach p $olds {
6656 if {$np >= $mergemax} {
6657 set tag mmax
6658 } else {
6659 set tag m$np
6661 $ctext insert end "[mc "Parent"]: " $tag
6662 appendwithlinks [commit_descriptor $p] {}
6663 incr np
6665 } else {
6666 foreach p $olds {
6667 append headers "[mc "Parent"]: [commit_descriptor $p]"
6671 foreach c $children($curview,$id) {
6672 append headers "[mc "Child"]: [commit_descriptor $c]"
6675 # make anything that looks like a SHA1 ID be a clickable link
6676 appendwithlinks $headers {}
6677 if {$showneartags} {
6678 if {![info exists allcommits]} {
6679 getallcommits
6681 $ctext insert end "[mc "Branch"]: "
6682 $ctext mark set branch "end -1c"
6683 $ctext mark gravity branch left
6684 $ctext insert end "\n[mc "Follows"]: "
6685 $ctext mark set follows "end -1c"
6686 $ctext mark gravity follows left
6687 $ctext insert end "\n[mc "Precedes"]: "
6688 $ctext mark set precedes "end -1c"
6689 $ctext mark gravity precedes left
6690 $ctext insert end "\n"
6691 dispneartags 1
6693 $ctext insert end "\n"
6694 set comment [lindex $info 5]
6695 if {[string first "\r" $comment] >= 0} {
6696 set comment [string map {"\r" "\n "} $comment]
6698 appendwithlinks $comment {comment}
6700 $ctext tag remove found 1.0 end
6701 $ctext conf -state disabled
6702 set commentend [$ctext index "end - 1c"]
6704 set jump_to_here $desired_loc
6705 init_flist [mc "Comments"]
6706 if {$cmitmode eq "tree"} {
6707 gettree $id
6708 } elseif {[llength $olds] <= 1} {
6709 startdiff $id
6710 } else {
6711 mergediff $id
6715 proc selfirstline {} {
6716 unmarkmatches
6717 selectline 0 1
6720 proc sellastline {} {
6721 global numcommits
6722 unmarkmatches
6723 set l [expr {$numcommits - 1}]
6724 selectline $l 1
6727 proc selnextline {dir} {
6728 global selectedline
6729 focus .
6730 if {$selectedline eq {}} return
6731 set l [expr {$selectedline + $dir}]
6732 unmarkmatches
6733 selectline $l 1
6736 proc selnextpage {dir} {
6737 global canv linespc selectedline numcommits
6739 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6740 if {$lpp < 1} {
6741 set lpp 1
6743 allcanvs yview scroll [expr {$dir * $lpp}] units
6744 drawvisible
6745 if {$selectedline eq {}} return
6746 set l [expr {$selectedline + $dir * $lpp}]
6747 if {$l < 0} {
6748 set l 0
6749 } elseif {$l >= $numcommits} {
6750 set l [expr $numcommits - 1]
6752 unmarkmatches
6753 selectline $l 1
6756 proc unselectline {} {
6757 global selectedline currentid
6759 set selectedline {}
6760 catch {unset currentid}
6761 allcanvs delete secsel
6762 rhighlight_none
6765 proc reselectline {} {
6766 global selectedline
6768 if {$selectedline ne {}} {
6769 selectline $selectedline 0
6773 proc addtohistory {cmd} {
6774 global history historyindex curview
6776 set elt [list $curview $cmd]
6777 if {$historyindex > 0
6778 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6779 return
6782 if {$historyindex < [llength $history]} {
6783 set history [lreplace $history $historyindex end $elt]
6784 } else {
6785 lappend history $elt
6787 incr historyindex
6788 if {$historyindex > 1} {
6789 .tf.bar.leftbut conf -state normal
6790 } else {
6791 .tf.bar.leftbut conf -state disabled
6793 .tf.bar.rightbut conf -state disabled
6796 proc godo {elt} {
6797 global curview
6799 set view [lindex $elt 0]
6800 set cmd [lindex $elt 1]
6801 if {$curview != $view} {
6802 showview $view
6804 eval $cmd
6807 proc goback {} {
6808 global history historyindex
6809 focus .
6811 if {$historyindex > 1} {
6812 incr historyindex -1
6813 godo [lindex $history [expr {$historyindex - 1}]]
6814 .tf.bar.rightbut conf -state normal
6816 if {$historyindex <= 1} {
6817 .tf.bar.leftbut conf -state disabled
6821 proc goforw {} {
6822 global history historyindex
6823 focus .
6825 if {$historyindex < [llength $history]} {
6826 set cmd [lindex $history $historyindex]
6827 incr historyindex
6828 godo $cmd
6829 .tf.bar.leftbut conf -state normal
6831 if {$historyindex >= [llength $history]} {
6832 .tf.bar.rightbut conf -state disabled
6836 proc gettree {id} {
6837 global treefilelist treeidlist diffids diffmergeid treepending
6838 global nullid nullid2
6840 set diffids $id
6841 catch {unset diffmergeid}
6842 if {![info exists treefilelist($id)]} {
6843 if {![info exists treepending]} {
6844 if {$id eq $nullid} {
6845 set cmd [list | git ls-files]
6846 } elseif {$id eq $nullid2} {
6847 set cmd [list | git ls-files --stage -t]
6848 } else {
6849 set cmd [list | git ls-tree -r $id]
6851 if {[catch {set gtf [open $cmd r]}]} {
6852 return
6854 set treepending $id
6855 set treefilelist($id) {}
6856 set treeidlist($id) {}
6857 fconfigure $gtf -blocking 0 -encoding binary
6858 filerun $gtf [list gettreeline $gtf $id]
6860 } else {
6861 setfilelist $id
6865 proc gettreeline {gtf id} {
6866 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6868 set nl 0
6869 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6870 if {$diffids eq $nullid} {
6871 set fname $line
6872 } else {
6873 set i [string first "\t" $line]
6874 if {$i < 0} continue
6875 set fname [string range $line [expr {$i+1}] end]
6876 set line [string range $line 0 [expr {$i-1}]]
6877 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6878 set sha1 [lindex $line 2]
6879 lappend treeidlist($id) $sha1
6881 if {[string index $fname 0] eq "\""} {
6882 set fname [lindex $fname 0]
6884 set fname [encoding convertfrom $fname]
6885 lappend treefilelist($id) $fname
6887 if {![eof $gtf]} {
6888 return [expr {$nl >= 1000? 2: 1}]
6890 close $gtf
6891 unset treepending
6892 if {$cmitmode ne "tree"} {
6893 if {![info exists diffmergeid]} {
6894 gettreediffs $diffids
6896 } elseif {$id ne $diffids} {
6897 gettree $diffids
6898 } else {
6899 setfilelist $id
6901 return 0
6904 proc showfile {f} {
6905 global treefilelist treeidlist diffids nullid nullid2
6906 global ctext_file_names ctext_file_lines
6907 global ctext commentend
6909 set i [lsearch -exact $treefilelist($diffids) $f]
6910 if {$i < 0} {
6911 puts "oops, $f not in list for id $diffids"
6912 return
6914 if {$diffids eq $nullid} {
6915 if {[catch {set bf [open $f r]} err]} {
6916 puts "oops, can't read $f: $err"
6917 return
6919 } else {
6920 set blob [lindex $treeidlist($diffids) $i]
6921 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6922 puts "oops, error reading blob $blob: $err"
6923 return
6926 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6927 filerun $bf [list getblobline $bf $diffids]
6928 $ctext config -state normal
6929 clear_ctext $commentend
6930 lappend ctext_file_names $f
6931 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6932 $ctext insert end "\n"
6933 $ctext insert end "$f\n" filesep
6934 $ctext config -state disabled
6935 $ctext yview $commentend
6936 settabs 0
6939 proc getblobline {bf id} {
6940 global diffids cmitmode ctext
6942 if {$id ne $diffids || $cmitmode ne "tree"} {
6943 catch {close $bf}
6944 return 0
6946 $ctext config -state normal
6947 set nl 0
6948 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6949 $ctext insert end "$line\n"
6951 if {[eof $bf]} {
6952 global jump_to_here ctext_file_names commentend
6954 # delete last newline
6955 $ctext delete "end - 2c" "end - 1c"
6956 close $bf
6957 if {$jump_to_here ne {} &&
6958 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6959 set lnum [expr {[lindex $jump_to_here 1] +
6960 [lindex [split $commentend .] 0]}]
6961 mark_ctext_line $lnum
6963 return 0
6965 $ctext config -state disabled
6966 return [expr {$nl >= 1000? 2: 1}]
6969 proc mark_ctext_line {lnum} {
6970 global ctext markbgcolor
6972 $ctext tag delete omark
6973 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6974 $ctext tag conf omark -background $markbgcolor
6975 $ctext see $lnum.0
6978 proc mergediff {id} {
6979 global diffmergeid
6980 global diffids treediffs
6981 global parents curview
6983 set diffmergeid $id
6984 set diffids $id
6985 set treediffs($id) {}
6986 set np [llength $parents($curview,$id)]
6987 settabs $np
6988 getblobdiffs $id
6991 proc startdiff {ids} {
6992 global treediffs diffids treepending diffmergeid nullid nullid2
6994 settabs 1
6995 set diffids $ids
6996 catch {unset diffmergeid}
6997 if {![info exists treediffs($ids)] ||
6998 [lsearch -exact $ids $nullid] >= 0 ||
6999 [lsearch -exact $ids $nullid2] >= 0} {
7000 if {![info exists treepending]} {
7001 gettreediffs $ids
7003 } else {
7004 addtocflist $ids
7008 proc path_filter {filter name} {
7009 foreach p $filter {
7010 set l [string length $p]
7011 if {[string index $p end] eq "/"} {
7012 if {[string compare -length $l $p $name] == 0} {
7013 return 1
7015 } else {
7016 if {[string compare -length $l $p $name] == 0 &&
7017 ([string length $name] == $l ||
7018 [string index $name $l] eq "/")} {
7019 return 1
7023 return 0
7026 proc addtocflist {ids} {
7027 global treediffs
7029 add_flist $treediffs($ids)
7030 getblobdiffs $ids
7033 proc diffcmd {ids flags} {
7034 global nullid nullid2
7036 set i [lsearch -exact $ids $nullid]
7037 set j [lsearch -exact $ids $nullid2]
7038 if {$i >= 0} {
7039 if {[llength $ids] > 1 && $j < 0} {
7040 # comparing working directory with some specific revision
7041 set cmd [concat | git diff-index $flags]
7042 if {$i == 0} {
7043 lappend cmd -R [lindex $ids 1]
7044 } else {
7045 lappend cmd [lindex $ids 0]
7047 } else {
7048 # comparing working directory with index
7049 set cmd [concat | git diff-files $flags]
7050 if {$j == 1} {
7051 lappend cmd -R
7054 } elseif {$j >= 0} {
7055 set cmd [concat | git diff-index --cached $flags]
7056 if {[llength $ids] > 1} {
7057 # comparing index with specific revision
7058 if {$i == 0} {
7059 lappend cmd -R [lindex $ids 1]
7060 } else {
7061 lappend cmd [lindex $ids 0]
7063 } else {
7064 # comparing index with HEAD
7065 lappend cmd HEAD
7067 } else {
7068 set cmd [concat | git diff-tree -r $flags $ids]
7070 return $cmd
7073 proc gettreediffs {ids} {
7074 global treediff treepending
7076 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7078 set treepending $ids
7079 set treediff {}
7080 fconfigure $gdtf -blocking 0 -encoding binary
7081 filerun $gdtf [list gettreediffline $gdtf $ids]
7084 proc gettreediffline {gdtf ids} {
7085 global treediff treediffs treepending diffids diffmergeid
7086 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7088 set nr 0
7089 set sublist {}
7090 set max 1000
7091 if {$perfile_attrs} {
7092 # cache_gitattr is slow, and even slower on win32 where we
7093 # have to invoke it for only about 30 paths at a time
7094 set max 500
7095 if {[tk windowingsystem] == "win32"} {
7096 set max 120
7099 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7100 set i [string first "\t" $line]
7101 if {$i >= 0} {
7102 set file [string range $line [expr {$i+1}] end]
7103 if {[string index $file 0] eq "\""} {
7104 set file [lindex $file 0]
7106 set file [encoding convertfrom $file]
7107 if {$file ne [lindex $treediff end]} {
7108 lappend treediff $file
7109 lappend sublist $file
7113 if {$perfile_attrs} {
7114 cache_gitattr encoding $sublist
7116 if {![eof $gdtf]} {
7117 return [expr {$nr >= $max? 2: 1}]
7119 close $gdtf
7120 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7121 set flist {}
7122 foreach f $treediff {
7123 if {[path_filter $vfilelimit($curview) $f]} {
7124 lappend flist $f
7127 set treediffs($ids) $flist
7128 } else {
7129 set treediffs($ids) $treediff
7131 unset treepending
7132 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7133 gettree $diffids
7134 } elseif {$ids != $diffids} {
7135 if {![info exists diffmergeid]} {
7136 gettreediffs $diffids
7138 } else {
7139 addtocflist $ids
7141 return 0
7144 # empty string or positive integer
7145 proc diffcontextvalidate {v} {
7146 return [regexp {^(|[1-9][0-9]*)$} $v]
7149 proc diffcontextchange {n1 n2 op} {
7150 global diffcontextstring diffcontext
7152 if {[string is integer -strict $diffcontextstring]} {
7153 if {$diffcontextstring > 0} {
7154 set diffcontext $diffcontextstring
7155 reselectline
7160 proc changeignorespace {} {
7161 reselectline
7164 proc getblobdiffs {ids} {
7165 global blobdifffd diffids env
7166 global diffinhdr treediffs
7167 global diffcontext
7168 global ignorespace
7169 global limitdiffs vfilelimit curview
7170 global diffencoding targetline diffnparents
7172 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7173 if {$ignorespace} {
7174 append cmd " -w"
7176 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7177 set cmd [concat $cmd -- $vfilelimit($curview)]
7179 if {[catch {set bdf [open $cmd r]} err]} {
7180 error_popup [mc "Error getting diffs: %s" $err]
7181 return
7183 set targetline {}
7184 set diffnparents 0
7185 set diffinhdr 0
7186 set diffencoding [get_path_encoding {}]
7187 fconfigure $bdf -blocking 0 -encoding binary
7188 set blobdifffd($ids) $bdf
7189 filerun $bdf [list getblobdiffline $bdf $diffids]
7192 proc setinlist {var i val} {
7193 global $var
7195 while {[llength [set $var]] < $i} {
7196 lappend $var {}
7198 if {[llength [set $var]] == $i} {
7199 lappend $var $val
7200 } else {
7201 lset $var $i $val
7205 proc makediffhdr {fname ids} {
7206 global ctext curdiffstart treediffs diffencoding
7207 global ctext_file_names jump_to_here targetline diffline
7209 set fname [encoding convertfrom $fname]
7210 set diffencoding [get_path_encoding $fname]
7211 set i [lsearch -exact $treediffs($ids) $fname]
7212 if {$i >= 0} {
7213 setinlist difffilestart $i $curdiffstart
7215 lset ctext_file_names end $fname
7216 set l [expr {(78 - [string length $fname]) / 2}]
7217 set pad [string range "----------------------------------------" 1 $l]
7218 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7219 set targetline {}
7220 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7221 set targetline [lindex $jump_to_here 1]
7223 set diffline 0
7226 proc getblobdiffline {bdf ids} {
7227 global diffids blobdifffd ctext curdiffstart
7228 global diffnexthead diffnextnote difffilestart
7229 global ctext_file_names ctext_file_lines
7230 global diffinhdr treediffs mergemax diffnparents
7231 global diffencoding jump_to_here targetline diffline
7233 set nr 0
7234 $ctext conf -state normal
7235 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7236 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7237 close $bdf
7238 return 0
7240 if {![string compare -length 5 "diff " $line]} {
7241 if {![regexp {^diff (--cc|--git) } $line m type]} {
7242 set line [encoding convertfrom $line]
7243 $ctext insert end "$line\n" hunksep
7244 continue
7246 # start of a new file
7247 set diffinhdr 1
7248 $ctext insert end "\n"
7249 set curdiffstart [$ctext index "end - 1c"]
7250 lappend ctext_file_names ""
7251 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7252 $ctext insert end "\n" filesep
7254 if {$type eq "--cc"} {
7255 # start of a new file in a merge diff
7256 set fname [string range $line 10 end]
7257 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7258 lappend treediffs($ids) $fname
7259 add_flist [list $fname]
7262 } else {
7263 set line [string range $line 11 end]
7264 # If the name hasn't changed the length will be odd,
7265 # the middle char will be a space, and the two bits either
7266 # side will be a/name and b/name, or "a/name" and "b/name".
7267 # If the name has changed we'll get "rename from" and
7268 # "rename to" or "copy from" and "copy to" lines following
7269 # this, and we'll use them to get the filenames.
7270 # This complexity is necessary because spaces in the
7271 # filename(s) don't get escaped.
7272 set l [string length $line]
7273 set i [expr {$l / 2}]
7274 if {!(($l & 1) && [string index $line $i] eq " " &&
7275 [string range $line 2 [expr {$i - 1}]] eq \
7276 [string range $line [expr {$i + 3}] end])} {
7277 continue
7279 # unescape if quoted and chop off the a/ from the front
7280 if {[string index $line 0] eq "\""} {
7281 set fname [string range [lindex $line 0] 2 end]
7282 } else {
7283 set fname [string range $line 2 [expr {$i - 1}]]
7286 makediffhdr $fname $ids
7288 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7289 set fname [encoding convertfrom [string range $line 16 end]]
7290 $ctext insert end "\n"
7291 set curdiffstart [$ctext index "end - 1c"]
7292 lappend ctext_file_names $fname
7293 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7294 $ctext insert end "$line\n" filesep
7295 set i [lsearch -exact $treediffs($ids) $fname]
7296 if {$i >= 0} {
7297 setinlist difffilestart $i $curdiffstart
7300 } elseif {![string compare -length 2 "@@" $line]} {
7301 regexp {^@@+} $line ats
7302 set line [encoding convertfrom $diffencoding $line]
7303 $ctext insert end "$line\n" hunksep
7304 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7305 set diffline $nl
7307 set diffnparents [expr {[string length $ats] - 1}]
7308 set diffinhdr 0
7310 } elseif {$diffinhdr} {
7311 if {![string compare -length 12 "rename from " $line]} {
7312 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7313 if {[string index $fname 0] eq "\""} {
7314 set fname [lindex $fname 0]
7316 set fname [encoding convertfrom $fname]
7317 set i [lsearch -exact $treediffs($ids) $fname]
7318 if {$i >= 0} {
7319 setinlist difffilestart $i $curdiffstart
7321 } elseif {![string compare -length 10 $line "rename to "] ||
7322 ![string compare -length 8 $line "copy to "]} {
7323 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7324 if {[string index $fname 0] eq "\""} {
7325 set fname [lindex $fname 0]
7327 makediffhdr $fname $ids
7328 } elseif {[string compare -length 3 $line "---"] == 0} {
7329 # do nothing
7330 continue
7331 } elseif {[string compare -length 3 $line "+++"] == 0} {
7332 set diffinhdr 0
7333 continue
7335 $ctext insert end "$line\n" filesep
7337 } else {
7338 set line [encoding convertfrom $diffencoding $line]
7339 # parse the prefix - one ' ', '-' or '+' for each parent
7340 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7341 set tag [expr {$diffnparents > 1? "m": "d"}]
7342 if {[string trim $prefix " -+"] eq {}} {
7343 # prefix only has " ", "-" and "+" in it: normal diff line
7344 set num [string first "-" $prefix]
7345 if {$num >= 0} {
7346 # removed line, first parent with line is $num
7347 if {$num >= $mergemax} {
7348 set num "max"
7350 $ctext insert end "$line\n" $tag$num
7351 } else {
7352 set tags {}
7353 if {[string first "+" $prefix] >= 0} {
7354 # added line
7355 lappend tags ${tag}result
7356 if {$diffnparents > 1} {
7357 set num [string first " " $prefix]
7358 if {$num >= 0} {
7359 if {$num >= $mergemax} {
7360 set num "max"
7362 lappend tags m$num
7366 if {$targetline ne {}} {
7367 if {$diffline == $targetline} {
7368 set seehere [$ctext index "end - 1 chars"]
7369 set targetline {}
7370 } else {
7371 incr diffline
7374 $ctext insert end "$line\n" $tags
7376 } else {
7377 # "\ No newline at end of file",
7378 # or something else we don't recognize
7379 $ctext insert end "$line\n" hunksep
7383 if {[info exists seehere]} {
7384 mark_ctext_line [lindex [split $seehere .] 0]
7386 $ctext conf -state disabled
7387 if {[eof $bdf]} {
7388 close $bdf
7389 return 0
7391 return [expr {$nr >= 1000? 2: 1}]
7394 proc changediffdisp {} {
7395 global ctext diffelide
7397 $ctext tag conf d0 -elide [lindex $diffelide 0]
7398 $ctext tag conf dresult -elide [lindex $diffelide 1]
7401 proc highlightfile {loc cline} {
7402 global ctext cflist cflist_top
7404 $ctext yview $loc
7405 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7406 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7407 $cflist see $cline.0
7408 set cflist_top $cline
7411 proc prevfile {} {
7412 global difffilestart ctext cmitmode
7414 if {$cmitmode eq "tree"} return
7415 set prev 0.0
7416 set prevline 1
7417 set here [$ctext index @0,0]
7418 foreach loc $difffilestart {
7419 if {[$ctext compare $loc >= $here]} {
7420 highlightfile $prev $prevline
7421 return
7423 set prev $loc
7424 incr prevline
7426 highlightfile $prev $prevline
7429 proc nextfile {} {
7430 global difffilestart ctext cmitmode
7432 if {$cmitmode eq "tree"} return
7433 set here [$ctext index @0,0]
7434 set line 1
7435 foreach loc $difffilestart {
7436 incr line
7437 if {[$ctext compare $loc > $here]} {
7438 highlightfile $loc $line
7439 return
7444 proc clear_ctext {{first 1.0}} {
7445 global ctext smarktop smarkbot
7446 global ctext_file_names ctext_file_lines
7447 global pendinglinks
7449 set l [lindex [split $first .] 0]
7450 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7451 set smarktop $l
7453 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7454 set smarkbot $l
7456 $ctext delete $first end
7457 if {$first eq "1.0"} {
7458 catch {unset pendinglinks}
7460 set ctext_file_names {}
7461 set ctext_file_lines {}
7464 proc settabs {{firstab {}}} {
7465 global firsttabstop tabstop ctext have_tk85
7467 if {$firstab ne {} && $have_tk85} {
7468 set firsttabstop $firstab
7470 set w [font measure textfont "0"]
7471 if {$firsttabstop != 0} {
7472 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7473 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7474 } elseif {$have_tk85 || $tabstop != 8} {
7475 $ctext conf -tabs [expr {$tabstop * $w}]
7476 } else {
7477 $ctext conf -tabs {}
7481 proc incrsearch {name ix op} {
7482 global ctext searchstring searchdirn
7484 $ctext tag remove found 1.0 end
7485 if {[catch {$ctext index anchor}]} {
7486 # no anchor set, use start of selection, or of visible area
7487 set sel [$ctext tag ranges sel]
7488 if {$sel ne {}} {
7489 $ctext mark set anchor [lindex $sel 0]
7490 } elseif {$searchdirn eq "-forwards"} {
7491 $ctext mark set anchor @0,0
7492 } else {
7493 $ctext mark set anchor @0,[winfo height $ctext]
7496 if {$searchstring ne {}} {
7497 set here [$ctext search $searchdirn -- $searchstring anchor]
7498 if {$here ne {}} {
7499 $ctext see $here
7501 searchmarkvisible 1
7505 proc dosearch {} {
7506 global sstring ctext searchstring searchdirn
7508 focus $sstring
7509 $sstring icursor end
7510 set searchdirn -forwards
7511 if {$searchstring ne {}} {
7512 set sel [$ctext tag ranges sel]
7513 if {$sel ne {}} {
7514 set start "[lindex $sel 0] + 1c"
7515 } elseif {[catch {set start [$ctext index anchor]}]} {
7516 set start "@0,0"
7518 set match [$ctext search -count mlen -- $searchstring $start]
7519 $ctext tag remove sel 1.0 end
7520 if {$match eq {}} {
7521 bell
7522 return
7524 $ctext see $match
7525 set mend "$match + $mlen c"
7526 $ctext tag add sel $match $mend
7527 $ctext mark unset anchor
7531 proc dosearchback {} {
7532 global sstring ctext searchstring searchdirn
7534 focus $sstring
7535 $sstring icursor end
7536 set searchdirn -backwards
7537 if {$searchstring ne {}} {
7538 set sel [$ctext tag ranges sel]
7539 if {$sel ne {}} {
7540 set start [lindex $sel 0]
7541 } elseif {[catch {set start [$ctext index anchor]}]} {
7542 set start @0,[winfo height $ctext]
7544 set match [$ctext search -backwards -count ml -- $searchstring $start]
7545 $ctext tag remove sel 1.0 end
7546 if {$match eq {}} {
7547 bell
7548 return
7550 $ctext see $match
7551 set mend "$match + $ml c"
7552 $ctext tag add sel $match $mend
7553 $ctext mark unset anchor
7557 proc searchmark {first last} {
7558 global ctext searchstring
7560 set mend $first.0
7561 while {1} {
7562 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7563 if {$match eq {}} break
7564 set mend "$match + $mlen c"
7565 $ctext tag add found $match $mend
7569 proc searchmarkvisible {doall} {
7570 global ctext smarktop smarkbot
7572 set topline [lindex [split [$ctext index @0,0] .] 0]
7573 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7574 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7575 # no overlap with previous
7576 searchmark $topline $botline
7577 set smarktop $topline
7578 set smarkbot $botline
7579 } else {
7580 if {$topline < $smarktop} {
7581 searchmark $topline [expr {$smarktop-1}]
7582 set smarktop $topline
7584 if {$botline > $smarkbot} {
7585 searchmark [expr {$smarkbot+1}] $botline
7586 set smarkbot $botline
7591 proc scrolltext {f0 f1} {
7592 global searchstring
7594 .bleft.bottom.sb set $f0 $f1
7595 if {$searchstring ne {}} {
7596 searchmarkvisible 0
7600 proc setcoords {} {
7601 global linespc charspc canvx0 canvy0
7602 global xspc1 xspc2 lthickness
7604 set linespc [font metrics mainfont -linespace]
7605 set charspc [font measure mainfont "m"]
7606 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7607 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7608 set lthickness [expr {int($linespc / 9) + 1}]
7609 set xspc1(0) $linespc
7610 set xspc2 $linespc
7613 proc redisplay {} {
7614 global canv
7615 global selectedline
7617 set ymax [lindex [$canv cget -scrollregion] 3]
7618 if {$ymax eq {} || $ymax == 0} return
7619 set span [$canv yview]
7620 clear_display
7621 setcanvscroll
7622 allcanvs yview moveto [lindex $span 0]
7623 drawvisible
7624 if {$selectedline ne {}} {
7625 selectline $selectedline 0
7626 allcanvs yview moveto [lindex $span 0]
7630 proc parsefont {f n} {
7631 global fontattr
7633 set fontattr($f,family) [lindex $n 0]
7634 set s [lindex $n 1]
7635 if {$s eq {} || $s == 0} {
7636 set s 10
7637 } elseif {$s < 0} {
7638 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7640 set fontattr($f,size) $s
7641 set fontattr($f,weight) normal
7642 set fontattr($f,slant) roman
7643 foreach style [lrange $n 2 end] {
7644 switch -- $style {
7645 "normal" -
7646 "bold" {set fontattr($f,weight) $style}
7647 "roman" -
7648 "italic" {set fontattr($f,slant) $style}
7653 proc fontflags {f {isbold 0}} {
7654 global fontattr
7656 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7657 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7658 -slant $fontattr($f,slant)]
7661 proc fontname {f} {
7662 global fontattr
7664 set n [list $fontattr($f,family) $fontattr($f,size)]
7665 if {$fontattr($f,weight) eq "bold"} {
7666 lappend n "bold"
7668 if {$fontattr($f,slant) eq "italic"} {
7669 lappend n "italic"
7671 return $n
7674 proc incrfont {inc} {
7675 global mainfont textfont ctext canv cflist showrefstop
7676 global stopped entries fontattr
7678 unmarkmatches
7679 set s $fontattr(mainfont,size)
7680 incr s $inc
7681 if {$s < 1} {
7682 set s 1
7684 set fontattr(mainfont,size) $s
7685 font config mainfont -size $s
7686 font config mainfontbold -size $s
7687 set mainfont [fontname mainfont]
7688 set s $fontattr(textfont,size)
7689 incr s $inc
7690 if {$s < 1} {
7691 set s 1
7693 set fontattr(textfont,size) $s
7694 font config textfont -size $s
7695 font config textfontbold -size $s
7696 set textfont [fontname textfont]
7697 setcoords
7698 settabs
7699 redisplay
7702 proc clearsha1 {} {
7703 global sha1entry sha1string
7704 if {[string length $sha1string] == 40} {
7705 $sha1entry delete 0 end
7709 proc sha1change {n1 n2 op} {
7710 global sha1string currentid sha1but
7711 if {$sha1string == {}
7712 || ([info exists currentid] && $sha1string == $currentid)} {
7713 set state disabled
7714 } else {
7715 set state normal
7717 if {[$sha1but cget -state] == $state} return
7718 if {$state == "normal"} {
7719 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7720 } else {
7721 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7725 proc gotocommit {} {
7726 global sha1string tagids headids curview varcid
7728 if {$sha1string == {}
7729 || ([info exists currentid] && $sha1string == $currentid)} return
7730 if {[info exists tagids($sha1string)]} {
7731 set id $tagids($sha1string)
7732 } elseif {[info exists headids($sha1string)]} {
7733 set id $headids($sha1string)
7734 } else {
7735 set id [string tolower $sha1string]
7736 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7737 set matches [longid $id]
7738 if {$matches ne {}} {
7739 if {[llength $matches] > 1} {
7740 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7741 return
7743 set id [lindex $matches 0]
7747 if {[commitinview $id $curview]} {
7748 selectline [rowofcommit $id] 1
7749 return
7751 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7752 set msg [mc "SHA1 id %s is not known" $sha1string]
7753 } else {
7754 set msg [mc "Tag/Head %s is not known" $sha1string]
7756 error_popup $msg
7759 proc lineenter {x y id} {
7760 global hoverx hovery hoverid hovertimer
7761 global commitinfo canv
7763 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7764 set hoverx $x
7765 set hovery $y
7766 set hoverid $id
7767 if {[info exists hovertimer]} {
7768 after cancel $hovertimer
7770 set hovertimer [after 500 linehover]
7771 $canv delete hover
7774 proc linemotion {x y id} {
7775 global hoverx hovery hoverid hovertimer
7777 if {[info exists hoverid] && $id == $hoverid} {
7778 set hoverx $x
7779 set hovery $y
7780 if {[info exists hovertimer]} {
7781 after cancel $hovertimer
7783 set hovertimer [after 500 linehover]
7787 proc lineleave {id} {
7788 global hoverid hovertimer canv
7790 if {[info exists hoverid] && $id == $hoverid} {
7791 $canv delete hover
7792 if {[info exists hovertimer]} {
7793 after cancel $hovertimer
7794 unset hovertimer
7796 unset hoverid
7800 proc linehover {} {
7801 global hoverx hovery hoverid hovertimer
7802 global canv linespc lthickness
7803 global commitinfo
7805 set text [lindex $commitinfo($hoverid) 0]
7806 set ymax [lindex [$canv cget -scrollregion] 3]
7807 if {$ymax == {}} return
7808 set yfrac [lindex [$canv yview] 0]
7809 set x [expr {$hoverx + 2 * $linespc}]
7810 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7811 set x0 [expr {$x - 2 * $lthickness}]
7812 set y0 [expr {$y - 2 * $lthickness}]
7813 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7814 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7815 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7816 -fill \#ffff80 -outline black -width 1 -tags hover]
7817 $canv raise $t
7818 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7819 -font mainfont]
7820 $canv raise $t
7823 proc clickisonarrow {id y} {
7824 global lthickness
7826 set ranges [rowranges $id]
7827 set thresh [expr {2 * $lthickness + 6}]
7828 set n [expr {[llength $ranges] - 1}]
7829 for {set i 1} {$i < $n} {incr i} {
7830 set row [lindex $ranges $i]
7831 if {abs([yc $row] - $y) < $thresh} {
7832 return $i
7835 return {}
7838 proc arrowjump {id n y} {
7839 global canv
7841 # 1 <-> 2, 3 <-> 4, etc...
7842 set n [expr {(($n - 1) ^ 1) + 1}]
7843 set row [lindex [rowranges $id] $n]
7844 set yt [yc $row]
7845 set ymax [lindex [$canv cget -scrollregion] 3]
7846 if {$ymax eq {} || $ymax <= 0} return
7847 set view [$canv yview]
7848 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7849 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7850 if {$yfrac < 0} {
7851 set yfrac 0
7853 allcanvs yview moveto $yfrac
7856 proc lineclick {x y id isnew} {
7857 global ctext commitinfo children canv thickerline curview
7859 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7860 unmarkmatches
7861 unselectline
7862 normalline
7863 $canv delete hover
7864 # draw this line thicker than normal
7865 set thickerline $id
7866 drawlines $id
7867 if {$isnew} {
7868 set ymax [lindex [$canv cget -scrollregion] 3]
7869 if {$ymax eq {}} return
7870 set yfrac [lindex [$canv yview] 0]
7871 set y [expr {$y + $yfrac * $ymax}]
7873 set dirn [clickisonarrow $id $y]
7874 if {$dirn ne {}} {
7875 arrowjump $id $dirn $y
7876 return
7879 if {$isnew} {
7880 addtohistory [list lineclick $x $y $id 0]
7882 # fill the details pane with info about this line
7883 $ctext conf -state normal
7884 clear_ctext
7885 settabs 0
7886 $ctext insert end "[mc "Parent"]:\t"
7887 $ctext insert end $id link0
7888 setlink $id link0
7889 set info $commitinfo($id)
7890 $ctext insert end "\n\t[lindex $info 0]\n"
7891 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7892 set date [formatdate [lindex $info 2]]
7893 $ctext insert end "\t[mc "Date"]:\t$date\n"
7894 set kids $children($curview,$id)
7895 if {$kids ne {}} {
7896 $ctext insert end "\n[mc "Children"]:"
7897 set i 0
7898 foreach child $kids {
7899 incr i
7900 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7901 set info $commitinfo($child)
7902 $ctext insert end "\n\t"
7903 $ctext insert end $child link$i
7904 setlink $child link$i
7905 $ctext insert end "\n\t[lindex $info 0]"
7906 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7907 set date [formatdate [lindex $info 2]]
7908 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7911 $ctext conf -state disabled
7912 init_flist {}
7915 proc normalline {} {
7916 global thickerline
7917 if {[info exists thickerline]} {
7918 set id $thickerline
7919 unset thickerline
7920 drawlines $id
7924 proc selbyid {id} {
7925 global curview
7926 if {[commitinview $id $curview]} {
7927 selectline [rowofcommit $id] 1
7931 proc mstime {} {
7932 global startmstime
7933 if {![info exists startmstime]} {
7934 set startmstime [clock clicks -milliseconds]
7936 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7939 proc rowmenu {x y id} {
7940 global rowctxmenu selectedline rowmenuid curview
7941 global nullid nullid2 fakerowmenu mainhead
7943 stopfinding
7944 set rowmenuid $id
7945 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7946 set state disabled
7947 } else {
7948 set state normal
7950 if {$id ne $nullid && $id ne $nullid2} {
7951 set menu $rowctxmenu
7952 if {$mainhead ne {}} {
7953 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7954 } else {
7955 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7957 } else {
7958 set menu $fakerowmenu
7960 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7961 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7962 $menu entryconfigure [mca "Make patch"] -state $state
7963 tk_popup $menu $x $y
7966 proc diffvssel {dirn} {
7967 global rowmenuid selectedline
7969 if {$selectedline eq {}} return
7970 if {$dirn} {
7971 set oldid [commitonrow $selectedline]
7972 set newid $rowmenuid
7973 } else {
7974 set oldid $rowmenuid
7975 set newid [commitonrow $selectedline]
7977 addtohistory [list doseldiff $oldid $newid]
7978 doseldiff $oldid $newid
7981 proc doseldiff {oldid newid} {
7982 global ctext
7983 global commitinfo
7985 $ctext conf -state normal
7986 clear_ctext
7987 init_flist [mc "Top"]
7988 $ctext insert end "[mc "From"] "
7989 $ctext insert end $oldid link0
7990 setlink $oldid link0
7991 $ctext insert end "\n "
7992 $ctext insert end [lindex $commitinfo($oldid) 0]
7993 $ctext insert end "\n\n[mc "To"] "
7994 $ctext insert end $newid link1
7995 setlink $newid link1
7996 $ctext insert end "\n "
7997 $ctext insert end [lindex $commitinfo($newid) 0]
7998 $ctext insert end "\n"
7999 $ctext conf -state disabled
8000 $ctext tag remove found 1.0 end
8001 startdiff [list $oldid $newid]
8004 proc mkpatch {} {
8005 global rowmenuid currentid commitinfo patchtop patchnum
8007 if {![info exists currentid]} return
8008 set oldid $currentid
8009 set oldhead [lindex $commitinfo($oldid) 0]
8010 set newid $rowmenuid
8011 set newhead [lindex $commitinfo($newid) 0]
8012 set top .patch
8013 set patchtop $top
8014 catch {destroy $top}
8015 toplevel $top
8016 make_transient $top .
8017 label $top.title -text [mc "Generate patch"]
8018 grid $top.title - -pady 10
8019 label $top.from -text [mc "From:"]
8020 entry $top.fromsha1 -width 40 -relief flat
8021 $top.fromsha1 insert 0 $oldid
8022 $top.fromsha1 conf -state readonly
8023 grid $top.from $top.fromsha1 -sticky w
8024 entry $top.fromhead -width 60 -relief flat
8025 $top.fromhead insert 0 $oldhead
8026 $top.fromhead conf -state readonly
8027 grid x $top.fromhead -sticky w
8028 label $top.to -text [mc "To:"]
8029 entry $top.tosha1 -width 40 -relief flat
8030 $top.tosha1 insert 0 $newid
8031 $top.tosha1 conf -state readonly
8032 grid $top.to $top.tosha1 -sticky w
8033 entry $top.tohead -width 60 -relief flat
8034 $top.tohead insert 0 $newhead
8035 $top.tohead conf -state readonly
8036 grid x $top.tohead -sticky w
8037 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8038 grid $top.rev x -pady 10
8039 label $top.flab -text [mc "Output file:"]
8040 entry $top.fname -width 60
8041 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8042 incr patchnum
8043 grid $top.flab $top.fname -sticky w
8044 frame $top.buts
8045 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8046 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8047 bind $top <Key-Return> mkpatchgo
8048 bind $top <Key-Escape> mkpatchcan
8049 grid $top.buts.gen $top.buts.can
8050 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8051 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8052 grid $top.buts - -pady 10 -sticky ew
8053 focus $top.fname
8056 proc mkpatchrev {} {
8057 global patchtop
8059 set oldid [$patchtop.fromsha1 get]
8060 set oldhead [$patchtop.fromhead get]
8061 set newid [$patchtop.tosha1 get]
8062 set newhead [$patchtop.tohead get]
8063 foreach e [list fromsha1 fromhead tosha1 tohead] \
8064 v [list $newid $newhead $oldid $oldhead] {
8065 $patchtop.$e conf -state normal
8066 $patchtop.$e delete 0 end
8067 $patchtop.$e insert 0 $v
8068 $patchtop.$e conf -state readonly
8072 proc mkpatchgo {} {
8073 global patchtop nullid nullid2
8075 set oldid [$patchtop.fromsha1 get]
8076 set newid [$patchtop.tosha1 get]
8077 set fname [$patchtop.fname get]
8078 set cmd [diffcmd [list $oldid $newid] -p]
8079 # trim off the initial "|"
8080 set cmd [lrange $cmd 1 end]
8081 lappend cmd >$fname &
8082 if {[catch {eval exec $cmd} err]} {
8083 error_popup "[mc "Error creating patch:"] $err" $patchtop
8085 catch {destroy $patchtop}
8086 unset patchtop
8089 proc mkpatchcan {} {
8090 global patchtop
8092 catch {destroy $patchtop}
8093 unset patchtop
8096 proc mktag {} {
8097 global rowmenuid mktagtop commitinfo
8099 set top .maketag
8100 set mktagtop $top
8101 catch {destroy $top}
8102 toplevel $top
8103 make_transient $top .
8104 label $top.title -text [mc "Create tag"]
8105 grid $top.title - -pady 10
8106 label $top.id -text [mc "ID:"]
8107 entry $top.sha1 -width 40 -relief flat
8108 $top.sha1 insert 0 $rowmenuid
8109 $top.sha1 conf -state readonly
8110 grid $top.id $top.sha1 -sticky w
8111 entry $top.head -width 60 -relief flat
8112 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8113 $top.head conf -state readonly
8114 grid x $top.head -sticky w
8115 label $top.tlab -text [mc "Tag name:"]
8116 entry $top.tag -width 60
8117 grid $top.tlab $top.tag -sticky w
8118 frame $top.buts
8119 button $top.buts.gen -text [mc "Create"] -command mktaggo
8120 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8121 bind $top <Key-Return> mktaggo
8122 bind $top <Key-Escape> mktagcan
8123 grid $top.buts.gen $top.buts.can
8124 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8125 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8126 grid $top.buts - -pady 10 -sticky ew
8127 focus $top.tag
8130 proc domktag {} {
8131 global mktagtop env tagids idtags
8133 set id [$mktagtop.sha1 get]
8134 set tag [$mktagtop.tag get]
8135 if {$tag == {}} {
8136 error_popup [mc "No tag name specified"] $mktagtop
8137 return 0
8139 if {[info exists tagids($tag)]} {
8140 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8141 return 0
8143 if {[catch {
8144 exec git tag $tag $id
8145 } err]} {
8146 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8147 return 0
8150 set tagids($tag) $id
8151 lappend idtags($id) $tag
8152 redrawtags $id
8153 addedtag $id
8154 dispneartags 0
8155 run refill_reflist
8156 return 1
8159 proc redrawtags {id} {
8160 global canv linehtag idpos currentid curview cmitlisted
8161 global canvxmax iddrawn circleitem mainheadid circlecolors
8163 if {![commitinview $id $curview]} return
8164 if {![info exists iddrawn($id)]} return
8165 set row [rowofcommit $id]
8166 if {$id eq $mainheadid} {
8167 set ofill yellow
8168 } else {
8169 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8171 $canv itemconf $circleitem($row) -fill $ofill
8172 $canv delete tag.$id
8173 set xt [eval drawtags $id $idpos($id)]
8174 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8175 set text [$canv itemcget $linehtag($id) -text]
8176 set font [$canv itemcget $linehtag($id) -font]
8177 set xr [expr {$xt + [font measure $font $text]}]
8178 if {$xr > $canvxmax} {
8179 set canvxmax $xr
8180 setcanvscroll
8182 if {[info exists currentid] && $currentid == $id} {
8183 make_secsel $id
8187 proc mktagcan {} {
8188 global mktagtop
8190 catch {destroy $mktagtop}
8191 unset mktagtop
8194 proc mktaggo {} {
8195 if {![domktag]} return
8196 mktagcan
8199 proc writecommit {} {
8200 global rowmenuid wrcomtop commitinfo wrcomcmd
8202 set top .writecommit
8203 set wrcomtop $top
8204 catch {destroy $top}
8205 toplevel $top
8206 make_transient $top .
8207 label $top.title -text [mc "Write commit to file"]
8208 grid $top.title - -pady 10
8209 label $top.id -text [mc "ID:"]
8210 entry $top.sha1 -width 40 -relief flat
8211 $top.sha1 insert 0 $rowmenuid
8212 $top.sha1 conf -state readonly
8213 grid $top.id $top.sha1 -sticky w
8214 entry $top.head -width 60 -relief flat
8215 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8216 $top.head conf -state readonly
8217 grid x $top.head -sticky w
8218 label $top.clab -text [mc "Command:"]
8219 entry $top.cmd -width 60 -textvariable wrcomcmd
8220 grid $top.clab $top.cmd -sticky w -pady 10
8221 label $top.flab -text [mc "Output file:"]
8222 entry $top.fname -width 60
8223 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8224 grid $top.flab $top.fname -sticky w
8225 frame $top.buts
8226 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8227 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8228 bind $top <Key-Return> wrcomgo
8229 bind $top <Key-Escape> wrcomcan
8230 grid $top.buts.gen $top.buts.can
8231 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8232 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8233 grid $top.buts - -pady 10 -sticky ew
8234 focus $top.fname
8237 proc wrcomgo {} {
8238 global wrcomtop
8240 set id [$wrcomtop.sha1 get]
8241 set cmd "echo $id | [$wrcomtop.cmd get]"
8242 set fname [$wrcomtop.fname get]
8243 if {[catch {exec sh -c $cmd >$fname &} err]} {
8244 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8246 catch {destroy $wrcomtop}
8247 unset wrcomtop
8250 proc wrcomcan {} {
8251 global wrcomtop
8253 catch {destroy $wrcomtop}
8254 unset wrcomtop
8257 proc mkbranch {} {
8258 global rowmenuid mkbrtop
8260 set top .makebranch
8261 catch {destroy $top}
8262 toplevel $top
8263 make_transient $top .
8264 label $top.title -text [mc "Create new branch"]
8265 grid $top.title - -pady 10
8266 label $top.id -text [mc "ID:"]
8267 entry $top.sha1 -width 40 -relief flat
8268 $top.sha1 insert 0 $rowmenuid
8269 $top.sha1 conf -state readonly
8270 grid $top.id $top.sha1 -sticky w
8271 label $top.nlab -text [mc "Name:"]
8272 entry $top.name -width 40
8273 grid $top.nlab $top.name -sticky w
8274 frame $top.buts
8275 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8276 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8277 bind $top <Key-Return> [list mkbrgo $top]
8278 bind $top <Key-Escape> "catch {destroy $top}"
8279 grid $top.buts.go $top.buts.can
8280 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8281 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8282 grid $top.buts - -pady 10 -sticky ew
8283 focus $top.name
8286 proc mkbrgo {top} {
8287 global headids idheads
8289 set name [$top.name get]
8290 set id [$top.sha1 get]
8291 set cmdargs {}
8292 set old_id {}
8293 if {$name eq {}} {
8294 error_popup [mc "Please specify a name for the new branch"] $top
8295 return
8297 if {[info exists headids($name)]} {
8298 if {![confirm_popup [mc \
8299 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8300 return
8302 set old_id $headids($name)
8303 lappend cmdargs -f
8305 catch {destroy $top}
8306 lappend cmdargs $name $id
8307 nowbusy newbranch
8308 update
8309 if {[catch {
8310 eval exec git branch $cmdargs
8311 } err]} {
8312 notbusy newbranch
8313 error_popup $err
8314 } else {
8315 notbusy newbranch
8316 if {$old_id ne {}} {
8317 movehead $id $name
8318 movedhead $id $name
8319 redrawtags $old_id
8320 redrawtags $id
8321 } else {
8322 set headids($name) $id
8323 lappend idheads($id) $name
8324 addedhead $id $name
8325 redrawtags $id
8327 dispneartags 0
8328 run refill_reflist
8332 proc exec_citool {tool_args {baseid {}}} {
8333 global commitinfo env
8335 set save_env [array get env GIT_AUTHOR_*]
8337 if {$baseid ne {}} {
8338 if {![info exists commitinfo($baseid)]} {
8339 getcommit $baseid
8341 set author [lindex $commitinfo($baseid) 1]
8342 set date [lindex $commitinfo($baseid) 2]
8343 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8344 $author author name email]
8345 && $date ne {}} {
8346 set env(GIT_AUTHOR_NAME) $name
8347 set env(GIT_AUTHOR_EMAIL) $email
8348 set env(GIT_AUTHOR_DATE) $date
8352 eval exec git citool $tool_args &
8354 array unset env GIT_AUTHOR_*
8355 array set env $save_env
8358 proc cherrypick {} {
8359 global rowmenuid curview
8360 global mainhead mainheadid
8362 set oldhead [exec git rev-parse HEAD]
8363 set dheads [descheads $rowmenuid]
8364 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8365 set ok [confirm_popup [mc "Commit %s is already\
8366 included in branch %s -- really re-apply it?" \
8367 [string range $rowmenuid 0 7] $mainhead]]
8368 if {!$ok} return
8370 nowbusy cherrypick [mc "Cherry-picking"]
8371 update
8372 # Unfortunately git-cherry-pick writes stuff to stderr even when
8373 # no error occurs, and exec takes that as an indication of error...
8374 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8375 notbusy cherrypick
8376 if {[regexp -line \
8377 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8378 $err msg fname]} {
8379 error_popup [mc "Cherry-pick failed because of local changes\
8380 to file '%s'.\nPlease commit, reset or stash\
8381 your changes and try again." $fname]
8382 } elseif {[regexp -line \
8383 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8384 $err]} {
8385 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8386 conflict.\nDo you wish to run git citool to\
8387 resolve it?"]]} {
8388 # Force citool to read MERGE_MSG
8389 file delete [file join [gitdir] "GITGUI_MSG"]
8390 exec_citool {} $rowmenuid
8392 } else {
8393 error_popup $err
8395 run updatecommits
8396 return
8398 set newhead [exec git rev-parse HEAD]
8399 if {$newhead eq $oldhead} {
8400 notbusy cherrypick
8401 error_popup [mc "No changes committed"]
8402 return
8404 addnewchild $newhead $oldhead
8405 if {[commitinview $oldhead $curview]} {
8406 # XXX this isn't right if we have a path limit...
8407 insertrow $newhead $oldhead $curview
8408 if {$mainhead ne {}} {
8409 movehead $newhead $mainhead
8410 movedhead $newhead $mainhead
8412 set mainheadid $newhead
8413 redrawtags $oldhead
8414 redrawtags $newhead
8415 selbyid $newhead
8417 notbusy cherrypick
8420 proc resethead {} {
8421 global mainhead rowmenuid confirm_ok resettype
8423 set confirm_ok 0
8424 set w ".confirmreset"
8425 toplevel $w
8426 make_transient $w .
8427 wm title $w [mc "Confirm reset"]
8428 message $w.m -text \
8429 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8430 -justify center -aspect 1000
8431 pack $w.m -side top -fill x -padx 20 -pady 20
8432 frame $w.f -relief sunken -border 2
8433 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8434 grid $w.f.rt -sticky w
8435 set resettype mixed
8436 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8437 -text [mc "Soft: Leave working tree and index untouched"]
8438 grid $w.f.soft -sticky w
8439 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8440 -text [mc "Mixed: Leave working tree untouched, reset index"]
8441 grid $w.f.mixed -sticky w
8442 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8443 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8444 grid $w.f.hard -sticky w
8445 pack $w.f -side top -fill x
8446 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8447 pack $w.ok -side left -fill x -padx 20 -pady 20
8448 button $w.cancel -text [mc Cancel] -command "destroy $w"
8449 bind $w <Key-Escape> [list destroy $w]
8450 pack $w.cancel -side right -fill x -padx 20 -pady 20
8451 bind $w <Visibility> "grab $w; focus $w"
8452 tkwait window $w
8453 if {!$confirm_ok} return
8454 if {[catch {set fd [open \
8455 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8456 error_popup $err
8457 } else {
8458 dohidelocalchanges
8459 filerun $fd [list readresetstat $fd]
8460 nowbusy reset [mc "Resetting"]
8461 selbyid $rowmenuid
8465 proc readresetstat {fd} {
8466 global mainhead mainheadid showlocalchanges rprogcoord
8468 if {[gets $fd line] >= 0} {
8469 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8470 set rprogcoord [expr {1.0 * $m / $n}]
8471 adjustprogress
8473 return 1
8475 set rprogcoord 0
8476 adjustprogress
8477 notbusy reset
8478 if {[catch {close $fd} err]} {
8479 error_popup $err
8481 set oldhead $mainheadid
8482 set newhead [exec git rev-parse HEAD]
8483 if {$newhead ne $oldhead} {
8484 movehead $newhead $mainhead
8485 movedhead $newhead $mainhead
8486 set mainheadid $newhead
8487 redrawtags $oldhead
8488 redrawtags $newhead
8490 if {$showlocalchanges} {
8491 doshowlocalchanges
8493 return 0
8496 # context menu for a head
8497 proc headmenu {x y id head} {
8498 global headmenuid headmenuhead headctxmenu mainhead
8500 stopfinding
8501 set headmenuid $id
8502 set headmenuhead $head
8503 set state normal
8504 if {$head eq $mainhead} {
8505 set state disabled
8507 $headctxmenu entryconfigure 0 -state $state
8508 $headctxmenu entryconfigure 1 -state $state
8509 tk_popup $headctxmenu $x $y
8512 proc cobranch {} {
8513 global headmenuid headmenuhead headids
8514 global showlocalchanges
8516 # check the tree is clean first??
8517 nowbusy checkout [mc "Checking out"]
8518 update
8519 dohidelocalchanges
8520 if {[catch {
8521 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8522 } err]} {
8523 notbusy checkout
8524 error_popup $err
8525 if {$showlocalchanges} {
8526 dodiffindex
8528 } else {
8529 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8533 proc readcheckoutstat {fd newhead newheadid} {
8534 global mainhead mainheadid headids showlocalchanges progresscoords
8535 global viewmainheadid curview
8537 if {[gets $fd line] >= 0} {
8538 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8539 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8540 adjustprogress
8542 return 1
8544 set progresscoords {0 0}
8545 adjustprogress
8546 notbusy checkout
8547 if {[catch {close $fd} err]} {
8548 error_popup $err
8550 set oldmainid $mainheadid
8551 set mainhead $newhead
8552 set mainheadid $newheadid
8553 set viewmainheadid($curview) $newheadid
8554 redrawtags $oldmainid
8555 redrawtags $newheadid
8556 selbyid $newheadid
8557 if {$showlocalchanges} {
8558 dodiffindex
8562 proc rmbranch {} {
8563 global headmenuid headmenuhead mainhead
8564 global idheads
8566 set head $headmenuhead
8567 set id $headmenuid
8568 # this check shouldn't be needed any more...
8569 if {$head eq $mainhead} {
8570 error_popup [mc "Cannot delete the currently checked-out branch"]
8571 return
8573 set dheads [descheads $id]
8574 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8575 # the stuff on this branch isn't on any other branch
8576 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8577 branch.\nReally delete branch %s?" $head $head]]} return
8579 nowbusy rmbranch
8580 update
8581 if {[catch {exec git branch -D $head} err]} {
8582 notbusy rmbranch
8583 error_popup $err
8584 return
8586 removehead $id $head
8587 removedhead $id $head
8588 redrawtags $id
8589 notbusy rmbranch
8590 dispneartags 0
8591 run refill_reflist
8594 # Display a list of tags and heads
8595 proc showrefs {} {
8596 global showrefstop bgcolor fgcolor selectbgcolor
8597 global bglist fglist reflistfilter reflist maincursor
8599 set top .showrefs
8600 set showrefstop $top
8601 if {[winfo exists $top]} {
8602 raise $top
8603 refill_reflist
8604 return
8606 toplevel $top
8607 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8608 make_transient $top .
8609 text $top.list -background $bgcolor -foreground $fgcolor \
8610 -selectbackground $selectbgcolor -font mainfont \
8611 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8612 -width 30 -height 20 -cursor $maincursor \
8613 -spacing1 1 -spacing3 1 -state disabled
8614 $top.list tag configure highlight -background $selectbgcolor
8615 lappend bglist $top.list
8616 lappend fglist $top.list
8617 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8618 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8619 grid $top.list $top.ysb -sticky nsew
8620 grid $top.xsb x -sticky ew
8621 frame $top.f
8622 label $top.f.l -text "[mc "Filter"]: "
8623 entry $top.f.e -width 20 -textvariable reflistfilter
8624 set reflistfilter "*"
8625 trace add variable reflistfilter write reflistfilter_change
8626 pack $top.f.e -side right -fill x -expand 1
8627 pack $top.f.l -side left
8628 grid $top.f - -sticky ew -pady 2
8629 button $top.close -command [list destroy $top] -text [mc "Close"]
8630 bind $top <Key-Escape> [list destroy $top]
8631 grid $top.close -
8632 grid columnconfigure $top 0 -weight 1
8633 grid rowconfigure $top 0 -weight 1
8634 bind $top.list <1> {break}
8635 bind $top.list <B1-Motion> {break}
8636 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8637 set reflist {}
8638 refill_reflist
8641 proc sel_reflist {w x y} {
8642 global showrefstop reflist headids tagids otherrefids
8644 if {![winfo exists $showrefstop]} return
8645 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8646 set ref [lindex $reflist [expr {$l-1}]]
8647 set n [lindex $ref 0]
8648 switch -- [lindex $ref 1] {
8649 "H" {selbyid $headids($n)}
8650 "T" {selbyid $tagids($n)}
8651 "o" {selbyid $otherrefids($n)}
8653 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8656 proc unsel_reflist {} {
8657 global showrefstop
8659 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8660 $showrefstop.list tag remove highlight 0.0 end
8663 proc reflistfilter_change {n1 n2 op} {
8664 global reflistfilter
8666 after cancel refill_reflist
8667 after 200 refill_reflist
8670 proc refill_reflist {} {
8671 global reflist reflistfilter showrefstop headids tagids otherrefids
8672 global curview
8674 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8675 set refs {}
8676 foreach n [array names headids] {
8677 if {[string match $reflistfilter $n]} {
8678 if {[commitinview $headids($n) $curview]} {
8679 lappend refs [list $n H]
8680 } else {
8681 interestedin $headids($n) {run refill_reflist}
8685 foreach n [array names tagids] {
8686 if {[string match $reflistfilter $n]} {
8687 if {[commitinview $tagids($n) $curview]} {
8688 lappend refs [list $n T]
8689 } else {
8690 interestedin $tagids($n) {run refill_reflist}
8694 foreach n [array names otherrefids] {
8695 if {[string match $reflistfilter $n]} {
8696 if {[commitinview $otherrefids($n) $curview]} {
8697 lappend refs [list $n o]
8698 } else {
8699 interestedin $otherrefids($n) {run refill_reflist}
8703 set refs [lsort -index 0 $refs]
8704 if {$refs eq $reflist} return
8706 # Update the contents of $showrefstop.list according to the
8707 # differences between $reflist (old) and $refs (new)
8708 $showrefstop.list conf -state normal
8709 $showrefstop.list insert end "\n"
8710 set i 0
8711 set j 0
8712 while {$i < [llength $reflist] || $j < [llength $refs]} {
8713 if {$i < [llength $reflist]} {
8714 if {$j < [llength $refs]} {
8715 set cmp [string compare [lindex $reflist $i 0] \
8716 [lindex $refs $j 0]]
8717 if {$cmp == 0} {
8718 set cmp [string compare [lindex $reflist $i 1] \
8719 [lindex $refs $j 1]]
8721 } else {
8722 set cmp -1
8724 } else {
8725 set cmp 1
8727 switch -- $cmp {
8728 -1 {
8729 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8730 incr i
8733 incr i
8734 incr j
8737 set l [expr {$j + 1}]
8738 $showrefstop.list image create $l.0 -align baseline \
8739 -image reficon-[lindex $refs $j 1] -padx 2
8740 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8741 incr j
8745 set reflist $refs
8746 # delete last newline
8747 $showrefstop.list delete end-2c end-1c
8748 $showrefstop.list conf -state disabled
8751 # Stuff for finding nearby tags
8752 proc getallcommits {} {
8753 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8754 global idheads idtags idotherrefs allparents tagobjid
8756 if {![info exists allcommits]} {
8757 set nextarc 0
8758 set allcommits 0
8759 set seeds {}
8760 set allcwait 0
8761 set cachedarcs 0
8762 set allccache [file join [gitdir] "gitk.cache"]
8763 if {![catch {
8764 set f [open $allccache r]
8765 set allcwait 1
8766 getcache $f
8767 }]} return
8770 if {$allcwait} {
8771 return
8773 set cmd [list | git rev-list --parents]
8774 set allcupdate [expr {$seeds ne {}}]
8775 if {!$allcupdate} {
8776 set ids "--all"
8777 } else {
8778 set refs [concat [array names idheads] [array names idtags] \
8779 [array names idotherrefs]]
8780 set ids {}
8781 set tagobjs {}
8782 foreach name [array names tagobjid] {
8783 lappend tagobjs $tagobjid($name)
8785 foreach id [lsort -unique $refs] {
8786 if {![info exists allparents($id)] &&
8787 [lsearch -exact $tagobjs $id] < 0} {
8788 lappend ids $id
8791 if {$ids ne {}} {
8792 foreach id $seeds {
8793 lappend ids "^$id"
8797 if {$ids ne {}} {
8798 set fd [open [concat $cmd $ids] r]
8799 fconfigure $fd -blocking 0
8800 incr allcommits
8801 nowbusy allcommits
8802 filerun $fd [list getallclines $fd]
8803 } else {
8804 dispneartags 0
8808 # Since most commits have 1 parent and 1 child, we group strings of
8809 # such commits into "arcs" joining branch/merge points (BMPs), which
8810 # are commits that either don't have 1 parent or don't have 1 child.
8812 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8813 # arcout(id) - outgoing arcs for BMP
8814 # arcids(a) - list of IDs on arc including end but not start
8815 # arcstart(a) - BMP ID at start of arc
8816 # arcend(a) - BMP ID at end of arc
8817 # growing(a) - arc a is still growing
8818 # arctags(a) - IDs out of arcids (excluding end) that have tags
8819 # archeads(a) - IDs out of arcids (excluding end) that have heads
8820 # The start of an arc is at the descendent end, so "incoming" means
8821 # coming from descendents, and "outgoing" means going towards ancestors.
8823 proc getallclines {fd} {
8824 global allparents allchildren idtags idheads nextarc
8825 global arcnos arcids arctags arcout arcend arcstart archeads growing
8826 global seeds allcommits cachedarcs allcupdate
8828 set nid 0
8829 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8830 set id [lindex $line 0]
8831 if {[info exists allparents($id)]} {
8832 # seen it already
8833 continue
8835 set cachedarcs 0
8836 set olds [lrange $line 1 end]
8837 set allparents($id) $olds
8838 if {![info exists allchildren($id)]} {
8839 set allchildren($id) {}
8840 set arcnos($id) {}
8841 lappend seeds $id
8842 } else {
8843 set a $arcnos($id)
8844 if {[llength $olds] == 1 && [llength $a] == 1} {
8845 lappend arcids($a) $id
8846 if {[info exists idtags($id)]} {
8847 lappend arctags($a) $id
8849 if {[info exists idheads($id)]} {
8850 lappend archeads($a) $id
8852 if {[info exists allparents($olds)]} {
8853 # seen parent already
8854 if {![info exists arcout($olds)]} {
8855 splitarc $olds
8857 lappend arcids($a) $olds
8858 set arcend($a) $olds
8859 unset growing($a)
8861 lappend allchildren($olds) $id
8862 lappend arcnos($olds) $a
8863 continue
8866 foreach a $arcnos($id) {
8867 lappend arcids($a) $id
8868 set arcend($a) $id
8869 unset growing($a)
8872 set ao {}
8873 foreach p $olds {
8874 lappend allchildren($p) $id
8875 set a [incr nextarc]
8876 set arcstart($a) $id
8877 set archeads($a) {}
8878 set arctags($a) {}
8879 set archeads($a) {}
8880 set arcids($a) {}
8881 lappend ao $a
8882 set growing($a) 1
8883 if {[info exists allparents($p)]} {
8884 # seen it already, may need to make a new branch
8885 if {![info exists arcout($p)]} {
8886 splitarc $p
8888 lappend arcids($a) $p
8889 set arcend($a) $p
8890 unset growing($a)
8892 lappend arcnos($p) $a
8894 set arcout($id) $ao
8896 if {$nid > 0} {
8897 global cached_dheads cached_dtags cached_atags
8898 catch {unset cached_dheads}
8899 catch {unset cached_dtags}
8900 catch {unset cached_atags}
8902 if {![eof $fd]} {
8903 return [expr {$nid >= 1000? 2: 1}]
8905 set cacheok 1
8906 if {[catch {
8907 fconfigure $fd -blocking 1
8908 close $fd
8909 } err]} {
8910 # got an error reading the list of commits
8911 # if we were updating, try rereading the whole thing again
8912 if {$allcupdate} {
8913 incr allcommits -1
8914 dropcache $err
8915 return
8917 error_popup "[mc "Error reading commit topology information;\
8918 branch and preceding/following tag information\
8919 will be incomplete."]\n($err)"
8920 set cacheok 0
8922 if {[incr allcommits -1] == 0} {
8923 notbusy allcommits
8924 if {$cacheok} {
8925 run savecache
8928 dispneartags 0
8929 return 0
8932 proc recalcarc {a} {
8933 global arctags archeads arcids idtags idheads
8935 set at {}
8936 set ah {}
8937 foreach id [lrange $arcids($a) 0 end-1] {
8938 if {[info exists idtags($id)]} {
8939 lappend at $id
8941 if {[info exists idheads($id)]} {
8942 lappend ah $id
8945 set arctags($a) $at
8946 set archeads($a) $ah
8949 proc splitarc {p} {
8950 global arcnos arcids nextarc arctags archeads idtags idheads
8951 global arcstart arcend arcout allparents growing
8953 set a $arcnos($p)
8954 if {[llength $a] != 1} {
8955 puts "oops splitarc called but [llength $a] arcs already"
8956 return
8958 set a [lindex $a 0]
8959 set i [lsearch -exact $arcids($a) $p]
8960 if {$i < 0} {
8961 puts "oops splitarc $p not in arc $a"
8962 return
8964 set na [incr nextarc]
8965 if {[info exists arcend($a)]} {
8966 set arcend($na) $arcend($a)
8967 } else {
8968 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8969 set j [lsearch -exact $arcnos($l) $a]
8970 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8972 set tail [lrange $arcids($a) [expr {$i+1}] end]
8973 set arcids($a) [lrange $arcids($a) 0 $i]
8974 set arcend($a) $p
8975 set arcstart($na) $p
8976 set arcout($p) $na
8977 set arcids($na) $tail
8978 if {[info exists growing($a)]} {
8979 set growing($na) 1
8980 unset growing($a)
8983 foreach id $tail {
8984 if {[llength $arcnos($id)] == 1} {
8985 set arcnos($id) $na
8986 } else {
8987 set j [lsearch -exact $arcnos($id) $a]
8988 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8992 # reconstruct tags and heads lists
8993 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8994 recalcarc $a
8995 recalcarc $na
8996 } else {
8997 set arctags($na) {}
8998 set archeads($na) {}
9002 # Update things for a new commit added that is a child of one
9003 # existing commit. Used when cherry-picking.
9004 proc addnewchild {id p} {
9005 global allparents allchildren idtags nextarc
9006 global arcnos arcids arctags arcout arcend arcstart archeads growing
9007 global seeds allcommits
9009 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9010 set allparents($id) [list $p]
9011 set allchildren($id) {}
9012 set arcnos($id) {}
9013 lappend seeds $id
9014 lappend allchildren($p) $id
9015 set a [incr nextarc]
9016 set arcstart($a) $id
9017 set archeads($a) {}
9018 set arctags($a) {}
9019 set arcids($a) [list $p]
9020 set arcend($a) $p
9021 if {![info exists arcout($p)]} {
9022 splitarc $p
9024 lappend arcnos($p) $a
9025 set arcout($id) [list $a]
9028 # This implements a cache for the topology information.
9029 # The cache saves, for each arc, the start and end of the arc,
9030 # the ids on the arc, and the outgoing arcs from the end.
9031 proc readcache {f} {
9032 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9033 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9034 global allcwait
9036 set a $nextarc
9037 set lim $cachedarcs
9038 if {$lim - $a > 500} {
9039 set lim [expr {$a + 500}]
9041 if {[catch {
9042 if {$a == $lim} {
9043 # finish reading the cache and setting up arctags, etc.
9044 set line [gets $f]
9045 if {$line ne "1"} {error "bad final version"}
9046 close $f
9047 foreach id [array names idtags] {
9048 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9049 [llength $allparents($id)] == 1} {
9050 set a [lindex $arcnos($id) 0]
9051 if {$arctags($a) eq {}} {
9052 recalcarc $a
9056 foreach id [array names idheads] {
9057 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9058 [llength $allparents($id)] == 1} {
9059 set a [lindex $arcnos($id) 0]
9060 if {$archeads($a) eq {}} {
9061 recalcarc $a
9065 foreach id [lsort -unique $possible_seeds] {
9066 if {$arcnos($id) eq {}} {
9067 lappend seeds $id
9070 set allcwait 0
9071 } else {
9072 while {[incr a] <= $lim} {
9073 set line [gets $f]
9074 if {[llength $line] != 3} {error "bad line"}
9075 set s [lindex $line 0]
9076 set arcstart($a) $s
9077 lappend arcout($s) $a
9078 if {![info exists arcnos($s)]} {
9079 lappend possible_seeds $s
9080 set arcnos($s) {}
9082 set e [lindex $line 1]
9083 if {$e eq {}} {
9084 set growing($a) 1
9085 } else {
9086 set arcend($a) $e
9087 if {![info exists arcout($e)]} {
9088 set arcout($e) {}
9091 set arcids($a) [lindex $line 2]
9092 foreach id $arcids($a) {
9093 lappend allparents($s) $id
9094 set s $id
9095 lappend arcnos($id) $a
9097 if {![info exists allparents($s)]} {
9098 set allparents($s) {}
9100 set arctags($a) {}
9101 set archeads($a) {}
9103 set nextarc [expr {$a - 1}]
9105 } err]} {
9106 dropcache $err
9107 return 0
9109 if {!$allcwait} {
9110 getallcommits
9112 return $allcwait
9115 proc getcache {f} {
9116 global nextarc cachedarcs possible_seeds
9118 if {[catch {
9119 set line [gets $f]
9120 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9121 # make sure it's an integer
9122 set cachedarcs [expr {int([lindex $line 1])}]
9123 if {$cachedarcs < 0} {error "bad number of arcs"}
9124 set nextarc 0
9125 set possible_seeds {}
9126 run readcache $f
9127 } err]} {
9128 dropcache $err
9130 return 0
9133 proc dropcache {err} {
9134 global allcwait nextarc cachedarcs seeds
9136 #puts "dropping cache ($err)"
9137 foreach v {arcnos arcout arcids arcstart arcend growing \
9138 arctags archeads allparents allchildren} {
9139 global $v
9140 catch {unset $v}
9142 set allcwait 0
9143 set nextarc 0
9144 set cachedarcs 0
9145 set seeds {}
9146 getallcommits
9149 proc writecache {f} {
9150 global cachearc cachedarcs allccache
9151 global arcstart arcend arcnos arcids arcout
9153 set a $cachearc
9154 set lim $cachedarcs
9155 if {$lim - $a > 1000} {
9156 set lim [expr {$a + 1000}]
9158 if {[catch {
9159 while {[incr a] <= $lim} {
9160 if {[info exists arcend($a)]} {
9161 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9162 } else {
9163 puts $f [list $arcstart($a) {} $arcids($a)]
9166 } err]} {
9167 catch {close $f}
9168 catch {file delete $allccache}
9169 #puts "writing cache failed ($err)"
9170 return 0
9172 set cachearc [expr {$a - 1}]
9173 if {$a > $cachedarcs} {
9174 puts $f "1"
9175 close $f
9176 return 0
9178 return 1
9181 proc savecache {} {
9182 global nextarc cachedarcs cachearc allccache
9184 if {$nextarc == $cachedarcs} return
9185 set cachearc 0
9186 set cachedarcs $nextarc
9187 catch {
9188 set f [open $allccache w]
9189 puts $f [list 1 $cachedarcs]
9190 run writecache $f
9194 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9195 # or 0 if neither is true.
9196 proc anc_or_desc {a b} {
9197 global arcout arcstart arcend arcnos cached_isanc
9199 if {$arcnos($a) eq $arcnos($b)} {
9200 # Both are on the same arc(s); either both are the same BMP,
9201 # or if one is not a BMP, the other is also not a BMP or is
9202 # the BMP at end of the arc (and it only has 1 incoming arc).
9203 # Or both can be BMPs with no incoming arcs.
9204 if {$a eq $b || $arcnos($a) eq {}} {
9205 return 0
9207 # assert {[llength $arcnos($a)] == 1}
9208 set arc [lindex $arcnos($a) 0]
9209 set i [lsearch -exact $arcids($arc) $a]
9210 set j [lsearch -exact $arcids($arc) $b]
9211 if {$i < 0 || $i > $j} {
9212 return 1
9213 } else {
9214 return -1
9218 if {![info exists arcout($a)]} {
9219 set arc [lindex $arcnos($a) 0]
9220 if {[info exists arcend($arc)]} {
9221 set aend $arcend($arc)
9222 } else {
9223 set aend {}
9225 set a $arcstart($arc)
9226 } else {
9227 set aend $a
9229 if {![info exists arcout($b)]} {
9230 set arc [lindex $arcnos($b) 0]
9231 if {[info exists arcend($arc)]} {
9232 set bend $arcend($arc)
9233 } else {
9234 set bend {}
9236 set b $arcstart($arc)
9237 } else {
9238 set bend $b
9240 if {$a eq $bend} {
9241 return 1
9243 if {$b eq $aend} {
9244 return -1
9246 if {[info exists cached_isanc($a,$bend)]} {
9247 if {$cached_isanc($a,$bend)} {
9248 return 1
9251 if {[info exists cached_isanc($b,$aend)]} {
9252 if {$cached_isanc($b,$aend)} {
9253 return -1
9255 if {[info exists cached_isanc($a,$bend)]} {
9256 return 0
9260 set todo [list $a $b]
9261 set anc($a) a
9262 set anc($b) b
9263 for {set i 0} {$i < [llength $todo]} {incr i} {
9264 set x [lindex $todo $i]
9265 if {$anc($x) eq {}} {
9266 continue
9268 foreach arc $arcnos($x) {
9269 set xd $arcstart($arc)
9270 if {$xd eq $bend} {
9271 set cached_isanc($a,$bend) 1
9272 set cached_isanc($b,$aend) 0
9273 return 1
9274 } elseif {$xd eq $aend} {
9275 set cached_isanc($b,$aend) 1
9276 set cached_isanc($a,$bend) 0
9277 return -1
9279 if {![info exists anc($xd)]} {
9280 set anc($xd) $anc($x)
9281 lappend todo $xd
9282 } elseif {$anc($xd) ne $anc($x)} {
9283 set anc($xd) {}
9287 set cached_isanc($a,$bend) 0
9288 set cached_isanc($b,$aend) 0
9289 return 0
9292 # This identifies whether $desc has an ancestor that is
9293 # a growing tip of the graph and which is not an ancestor of $anc
9294 # and returns 0 if so and 1 if not.
9295 # If we subsequently discover a tag on such a growing tip, and that
9296 # turns out to be a descendent of $anc (which it could, since we
9297 # don't necessarily see children before parents), then $desc
9298 # isn't a good choice to display as a descendent tag of
9299 # $anc (since it is the descendent of another tag which is
9300 # a descendent of $anc). Similarly, $anc isn't a good choice to
9301 # display as a ancestor tag of $desc.
9303 proc is_certain {desc anc} {
9304 global arcnos arcout arcstart arcend growing problems
9306 set certain {}
9307 if {[llength $arcnos($anc)] == 1} {
9308 # tags on the same arc are certain
9309 if {$arcnos($desc) eq $arcnos($anc)} {
9310 return 1
9312 if {![info exists arcout($anc)]} {
9313 # if $anc is partway along an arc, use the start of the arc instead
9314 set a [lindex $arcnos($anc) 0]
9315 set anc $arcstart($a)
9318 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9319 set x $desc
9320 } else {
9321 set a [lindex $arcnos($desc) 0]
9322 set x $arcend($a)
9324 if {$x == $anc} {
9325 return 1
9327 set anclist [list $x]
9328 set dl($x) 1
9329 set nnh 1
9330 set ngrowanc 0
9331 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9332 set x [lindex $anclist $i]
9333 if {$dl($x)} {
9334 incr nnh -1
9336 set done($x) 1
9337 foreach a $arcout($x) {
9338 if {[info exists growing($a)]} {
9339 if {![info exists growanc($x)] && $dl($x)} {
9340 set growanc($x) 1
9341 incr ngrowanc
9343 } else {
9344 set y $arcend($a)
9345 if {[info exists dl($y)]} {
9346 if {$dl($y)} {
9347 if {!$dl($x)} {
9348 set dl($y) 0
9349 if {![info exists done($y)]} {
9350 incr nnh -1
9352 if {[info exists growanc($x)]} {
9353 incr ngrowanc -1
9355 set xl [list $y]
9356 for {set k 0} {$k < [llength $xl]} {incr k} {
9357 set z [lindex $xl $k]
9358 foreach c $arcout($z) {
9359 if {[info exists arcend($c)]} {
9360 set v $arcend($c)
9361 if {[info exists dl($v)] && $dl($v)} {
9362 set dl($v) 0
9363 if {![info exists done($v)]} {
9364 incr nnh -1
9366 if {[info exists growanc($v)]} {
9367 incr ngrowanc -1
9369 lappend xl $v
9376 } elseif {$y eq $anc || !$dl($x)} {
9377 set dl($y) 0
9378 lappend anclist $y
9379 } else {
9380 set dl($y) 1
9381 lappend anclist $y
9382 incr nnh
9387 foreach x [array names growanc] {
9388 if {$dl($x)} {
9389 return 0
9391 return 0
9393 return 1
9396 proc validate_arctags {a} {
9397 global arctags idtags
9399 set i -1
9400 set na $arctags($a)
9401 foreach id $arctags($a) {
9402 incr i
9403 if {![info exists idtags($id)]} {
9404 set na [lreplace $na $i $i]
9405 incr i -1
9408 set arctags($a) $na
9411 proc validate_archeads {a} {
9412 global archeads idheads
9414 set i -1
9415 set na $archeads($a)
9416 foreach id $archeads($a) {
9417 incr i
9418 if {![info exists idheads($id)]} {
9419 set na [lreplace $na $i $i]
9420 incr i -1
9423 set archeads($a) $na
9426 # Return the list of IDs that have tags that are descendents of id,
9427 # ignoring IDs that are descendents of IDs already reported.
9428 proc desctags {id} {
9429 global arcnos arcstart arcids arctags idtags allparents
9430 global growing cached_dtags
9432 if {![info exists allparents($id)]} {
9433 return {}
9435 set t1 [clock clicks -milliseconds]
9436 set argid $id
9437 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9438 # part-way along an arc; check that arc first
9439 set a [lindex $arcnos($id) 0]
9440 if {$arctags($a) ne {}} {
9441 validate_arctags $a
9442 set i [lsearch -exact $arcids($a) $id]
9443 set tid {}
9444 foreach t $arctags($a) {
9445 set j [lsearch -exact $arcids($a) $t]
9446 if {$j >= $i} break
9447 set tid $t
9449 if {$tid ne {}} {
9450 return $tid
9453 set id $arcstart($a)
9454 if {[info exists idtags($id)]} {
9455 return $id
9458 if {[info exists cached_dtags($id)]} {
9459 return $cached_dtags($id)
9462 set origid $id
9463 set todo [list $id]
9464 set queued($id) 1
9465 set nc 1
9466 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9467 set id [lindex $todo $i]
9468 set done($id) 1
9469 set ta [info exists hastaggedancestor($id)]
9470 if {!$ta} {
9471 incr nc -1
9473 # ignore tags on starting node
9474 if {!$ta && $i > 0} {
9475 if {[info exists idtags($id)]} {
9476 set tagloc($id) $id
9477 set ta 1
9478 } elseif {[info exists cached_dtags($id)]} {
9479 set tagloc($id) $cached_dtags($id)
9480 set ta 1
9483 foreach a $arcnos($id) {
9484 set d $arcstart($a)
9485 if {!$ta && $arctags($a) ne {}} {
9486 validate_arctags $a
9487 if {$arctags($a) ne {}} {
9488 lappend tagloc($id) [lindex $arctags($a) end]
9491 if {$ta || $arctags($a) ne {}} {
9492 set tomark [list $d]
9493 for {set j 0} {$j < [llength $tomark]} {incr j} {
9494 set dd [lindex $tomark $j]
9495 if {![info exists hastaggedancestor($dd)]} {
9496 if {[info exists done($dd)]} {
9497 foreach b $arcnos($dd) {
9498 lappend tomark $arcstart($b)
9500 if {[info exists tagloc($dd)]} {
9501 unset tagloc($dd)
9503 } elseif {[info exists queued($dd)]} {
9504 incr nc -1
9506 set hastaggedancestor($dd) 1
9510 if {![info exists queued($d)]} {
9511 lappend todo $d
9512 set queued($d) 1
9513 if {![info exists hastaggedancestor($d)]} {
9514 incr nc
9519 set tags {}
9520 foreach id [array names tagloc] {
9521 if {![info exists hastaggedancestor($id)]} {
9522 foreach t $tagloc($id) {
9523 if {[lsearch -exact $tags $t] < 0} {
9524 lappend tags $t
9529 set t2 [clock clicks -milliseconds]
9530 set loopix $i
9532 # remove tags that are descendents of other tags
9533 for {set i 0} {$i < [llength $tags]} {incr i} {
9534 set a [lindex $tags $i]
9535 for {set j 0} {$j < $i} {incr j} {
9536 set b [lindex $tags $j]
9537 set r [anc_or_desc $a $b]
9538 if {$r == 1} {
9539 set tags [lreplace $tags $j $j]
9540 incr j -1
9541 incr i -1
9542 } elseif {$r == -1} {
9543 set tags [lreplace $tags $i $i]
9544 incr i -1
9545 break
9550 if {[array names growing] ne {}} {
9551 # graph isn't finished, need to check if any tag could get
9552 # eclipsed by another tag coming later. Simply ignore any
9553 # tags that could later get eclipsed.
9554 set ctags {}
9555 foreach t $tags {
9556 if {[is_certain $t $origid]} {
9557 lappend ctags $t
9560 if {$tags eq $ctags} {
9561 set cached_dtags($origid) $tags
9562 } else {
9563 set tags $ctags
9565 } else {
9566 set cached_dtags($origid) $tags
9568 set t3 [clock clicks -milliseconds]
9569 if {0 && $t3 - $t1 >= 100} {
9570 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9571 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9573 return $tags
9576 proc anctags {id} {
9577 global arcnos arcids arcout arcend arctags idtags allparents
9578 global growing cached_atags
9580 if {![info exists allparents($id)]} {
9581 return {}
9583 set t1 [clock clicks -milliseconds]
9584 set argid $id
9585 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9586 # part-way along an arc; check that arc first
9587 set a [lindex $arcnos($id) 0]
9588 if {$arctags($a) ne {}} {
9589 validate_arctags $a
9590 set i [lsearch -exact $arcids($a) $id]
9591 foreach t $arctags($a) {
9592 set j [lsearch -exact $arcids($a) $t]
9593 if {$j > $i} {
9594 return $t
9598 if {![info exists arcend($a)]} {
9599 return {}
9601 set id $arcend($a)
9602 if {[info exists idtags($id)]} {
9603 return $id
9606 if {[info exists cached_atags($id)]} {
9607 return $cached_atags($id)
9610 set origid $id
9611 set todo [list $id]
9612 set queued($id) 1
9613 set taglist {}
9614 set nc 1
9615 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9616 set id [lindex $todo $i]
9617 set done($id) 1
9618 set td [info exists hastaggeddescendent($id)]
9619 if {!$td} {
9620 incr nc -1
9622 # ignore tags on starting node
9623 if {!$td && $i > 0} {
9624 if {[info exists idtags($id)]} {
9625 set tagloc($id) $id
9626 set td 1
9627 } elseif {[info exists cached_atags($id)]} {
9628 set tagloc($id) $cached_atags($id)
9629 set td 1
9632 foreach a $arcout($id) {
9633 if {!$td && $arctags($a) ne {}} {
9634 validate_arctags $a
9635 if {$arctags($a) ne {}} {
9636 lappend tagloc($id) [lindex $arctags($a) 0]
9639 if {![info exists arcend($a)]} continue
9640 set d $arcend($a)
9641 if {$td || $arctags($a) ne {}} {
9642 set tomark [list $d]
9643 for {set j 0} {$j < [llength $tomark]} {incr j} {
9644 set dd [lindex $tomark $j]
9645 if {![info exists hastaggeddescendent($dd)]} {
9646 if {[info exists done($dd)]} {
9647 foreach b $arcout($dd) {
9648 if {[info exists arcend($b)]} {
9649 lappend tomark $arcend($b)
9652 if {[info exists tagloc($dd)]} {
9653 unset tagloc($dd)
9655 } elseif {[info exists queued($dd)]} {
9656 incr nc -1
9658 set hastaggeddescendent($dd) 1
9662 if {![info exists queued($d)]} {
9663 lappend todo $d
9664 set queued($d) 1
9665 if {![info exists hastaggeddescendent($d)]} {
9666 incr nc
9671 set t2 [clock clicks -milliseconds]
9672 set loopix $i
9673 set tags {}
9674 foreach id [array names tagloc] {
9675 if {![info exists hastaggeddescendent($id)]} {
9676 foreach t $tagloc($id) {
9677 if {[lsearch -exact $tags $t] < 0} {
9678 lappend tags $t
9684 # remove tags that are ancestors of other tags
9685 for {set i 0} {$i < [llength $tags]} {incr i} {
9686 set a [lindex $tags $i]
9687 for {set j 0} {$j < $i} {incr j} {
9688 set b [lindex $tags $j]
9689 set r [anc_or_desc $a $b]
9690 if {$r == -1} {
9691 set tags [lreplace $tags $j $j]
9692 incr j -1
9693 incr i -1
9694 } elseif {$r == 1} {
9695 set tags [lreplace $tags $i $i]
9696 incr i -1
9697 break
9702 if {[array names growing] ne {}} {
9703 # graph isn't finished, need to check if any tag could get
9704 # eclipsed by another tag coming later. Simply ignore any
9705 # tags that could later get eclipsed.
9706 set ctags {}
9707 foreach t $tags {
9708 if {[is_certain $origid $t]} {
9709 lappend ctags $t
9712 if {$tags eq $ctags} {
9713 set cached_atags($origid) $tags
9714 } else {
9715 set tags $ctags
9717 } else {
9718 set cached_atags($origid) $tags
9720 set t3 [clock clicks -milliseconds]
9721 if {0 && $t3 - $t1 >= 100} {
9722 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9723 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9725 return $tags
9728 # Return the list of IDs that have heads that are descendents of id,
9729 # including id itself if it has a head.
9730 proc descheads {id} {
9731 global arcnos arcstart arcids archeads idheads cached_dheads
9732 global allparents
9734 if {![info exists allparents($id)]} {
9735 return {}
9737 set aret {}
9738 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9739 # part-way along an arc; check it first
9740 set a [lindex $arcnos($id) 0]
9741 if {$archeads($a) ne {}} {
9742 validate_archeads $a
9743 set i [lsearch -exact $arcids($a) $id]
9744 foreach t $archeads($a) {
9745 set j [lsearch -exact $arcids($a) $t]
9746 if {$j > $i} break
9747 lappend aret $t
9750 set id $arcstart($a)
9752 set origid $id
9753 set todo [list $id]
9754 set seen($id) 1
9755 set ret {}
9756 for {set i 0} {$i < [llength $todo]} {incr i} {
9757 set id [lindex $todo $i]
9758 if {[info exists cached_dheads($id)]} {
9759 set ret [concat $ret $cached_dheads($id)]
9760 } else {
9761 if {[info exists idheads($id)]} {
9762 lappend ret $id
9764 foreach a $arcnos($id) {
9765 if {$archeads($a) ne {}} {
9766 validate_archeads $a
9767 if {$archeads($a) ne {}} {
9768 set ret [concat $ret $archeads($a)]
9771 set d $arcstart($a)
9772 if {![info exists seen($d)]} {
9773 lappend todo $d
9774 set seen($d) 1
9779 set ret [lsort -unique $ret]
9780 set cached_dheads($origid) $ret
9781 return [concat $ret $aret]
9784 proc addedtag {id} {
9785 global arcnos arcout cached_dtags cached_atags
9787 if {![info exists arcnos($id)]} return
9788 if {![info exists arcout($id)]} {
9789 recalcarc [lindex $arcnos($id) 0]
9791 catch {unset cached_dtags}
9792 catch {unset cached_atags}
9795 proc addedhead {hid head} {
9796 global arcnos arcout cached_dheads
9798 if {![info exists arcnos($hid)]} return
9799 if {![info exists arcout($hid)]} {
9800 recalcarc [lindex $arcnos($hid) 0]
9802 catch {unset cached_dheads}
9805 proc removedhead {hid head} {
9806 global cached_dheads
9808 catch {unset cached_dheads}
9811 proc movedhead {hid head} {
9812 global arcnos arcout cached_dheads
9814 if {![info exists arcnos($hid)]} return
9815 if {![info exists arcout($hid)]} {
9816 recalcarc [lindex $arcnos($hid) 0]
9818 catch {unset cached_dheads}
9821 proc changedrefs {} {
9822 global cached_dheads cached_dtags cached_atags
9823 global arctags archeads arcnos arcout idheads idtags
9825 foreach id [concat [array names idheads] [array names idtags]] {
9826 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9827 set a [lindex $arcnos($id) 0]
9828 if {![info exists donearc($a)]} {
9829 recalcarc $a
9830 set donearc($a) 1
9834 catch {unset cached_dtags}
9835 catch {unset cached_atags}
9836 catch {unset cached_dheads}
9839 proc rereadrefs {} {
9840 global idtags idheads idotherrefs mainheadid
9842 set refids [concat [array names idtags] \
9843 [array names idheads] [array names idotherrefs]]
9844 foreach id $refids {
9845 if {![info exists ref($id)]} {
9846 set ref($id) [listrefs $id]
9849 set oldmainhead $mainheadid
9850 readrefs
9851 changedrefs
9852 set refids [lsort -unique [concat $refids [array names idtags] \
9853 [array names idheads] [array names idotherrefs]]]
9854 foreach id $refids {
9855 set v [listrefs $id]
9856 if {![info exists ref($id)] || $ref($id) != $v} {
9857 redrawtags $id
9860 if {$oldmainhead ne $mainheadid} {
9861 redrawtags $oldmainhead
9862 redrawtags $mainheadid
9864 run refill_reflist
9867 proc listrefs {id} {
9868 global idtags idheads idotherrefs
9870 set x {}
9871 if {[info exists idtags($id)]} {
9872 set x $idtags($id)
9874 set y {}
9875 if {[info exists idheads($id)]} {
9876 set y $idheads($id)
9878 set z {}
9879 if {[info exists idotherrefs($id)]} {
9880 set z $idotherrefs($id)
9882 return [list $x $y $z]
9885 proc showtag {tag isnew} {
9886 global ctext tagcontents tagids linknum tagobjid
9888 if {$isnew} {
9889 addtohistory [list showtag $tag 0]
9891 $ctext conf -state normal
9892 clear_ctext
9893 settabs 0
9894 set linknum 0
9895 if {![info exists tagcontents($tag)]} {
9896 catch {
9897 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9900 if {[info exists tagcontents($tag)]} {
9901 set text $tagcontents($tag)
9902 } else {
9903 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9905 appendwithlinks $text {}
9906 $ctext conf -state disabled
9907 init_flist {}
9910 proc doquit {} {
9911 global stopped
9912 global gitktmpdir
9914 set stopped 100
9915 savestuff .
9916 destroy .
9918 if {[info exists gitktmpdir]} {
9919 catch {file delete -force $gitktmpdir}
9923 proc mkfontdisp {font top which} {
9924 global fontattr fontpref $font
9926 set fontpref($font) [set $font]
9927 button $top.${font}but -text $which -font optionfont \
9928 -command [list choosefont $font $which]
9929 label $top.$font -relief flat -font $font \
9930 -text $fontattr($font,family) -justify left
9931 grid x $top.${font}but $top.$font -sticky w
9934 proc choosefont {font which} {
9935 global fontparam fontlist fonttop fontattr
9936 global prefstop
9938 set fontparam(which) $which
9939 set fontparam(font) $font
9940 set fontparam(family) [font actual $font -family]
9941 set fontparam(size) $fontattr($font,size)
9942 set fontparam(weight) $fontattr($font,weight)
9943 set fontparam(slant) $fontattr($font,slant)
9944 set top .gitkfont
9945 set fonttop $top
9946 if {![winfo exists $top]} {
9947 font create sample
9948 eval font config sample [font actual $font]
9949 toplevel $top
9950 make_transient $top $prefstop
9951 wm title $top [mc "Gitk font chooser"]
9952 label $top.l -textvariable fontparam(which)
9953 pack $top.l -side top
9954 set fontlist [lsort [font families]]
9955 frame $top.f
9956 listbox $top.f.fam -listvariable fontlist \
9957 -yscrollcommand [list $top.f.sb set]
9958 bind $top.f.fam <<ListboxSelect>> selfontfam
9959 scrollbar $top.f.sb -command [list $top.f.fam yview]
9960 pack $top.f.sb -side right -fill y
9961 pack $top.f.fam -side left -fill both -expand 1
9962 pack $top.f -side top -fill both -expand 1
9963 frame $top.g
9964 spinbox $top.g.size -from 4 -to 40 -width 4 \
9965 -textvariable fontparam(size) \
9966 -validatecommand {string is integer -strict %s}
9967 checkbutton $top.g.bold -padx 5 \
9968 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9969 -variable fontparam(weight) -onvalue bold -offvalue normal
9970 checkbutton $top.g.ital -padx 5 \
9971 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9972 -variable fontparam(slant) -onvalue italic -offvalue roman
9973 pack $top.g.size $top.g.bold $top.g.ital -side left
9974 pack $top.g -side top
9975 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9976 -background white
9977 $top.c create text 100 25 -anchor center -text $which -font sample \
9978 -fill black -tags text
9979 bind $top.c <Configure> [list centertext $top.c]
9980 pack $top.c -side top -fill x
9981 frame $top.buts
9982 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9983 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9984 bind $top <Key-Return> fontok
9985 bind $top <Key-Escape> fontcan
9986 grid $top.buts.ok $top.buts.can
9987 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9988 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9989 pack $top.buts -side bottom -fill x
9990 trace add variable fontparam write chg_fontparam
9991 } else {
9992 raise $top
9993 $top.c itemconf text -text $which
9995 set i [lsearch -exact $fontlist $fontparam(family)]
9996 if {$i >= 0} {
9997 $top.f.fam selection set $i
9998 $top.f.fam see $i
10002 proc centertext {w} {
10003 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10006 proc fontok {} {
10007 global fontparam fontpref prefstop
10009 set f $fontparam(font)
10010 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10011 if {$fontparam(weight) eq "bold"} {
10012 lappend fontpref($f) "bold"
10014 if {$fontparam(slant) eq "italic"} {
10015 lappend fontpref($f) "italic"
10017 set w $prefstop.$f
10018 $w conf -text $fontparam(family) -font $fontpref($f)
10020 fontcan
10023 proc fontcan {} {
10024 global fonttop fontparam
10026 if {[info exists fonttop]} {
10027 catch {destroy $fonttop}
10028 catch {font delete sample}
10029 unset fonttop
10030 unset fontparam
10034 proc selfontfam {} {
10035 global fonttop fontparam
10037 set i [$fonttop.f.fam curselection]
10038 if {$i ne {}} {
10039 set fontparam(family) [$fonttop.f.fam get $i]
10043 proc chg_fontparam {v sub op} {
10044 global fontparam
10046 font config sample -$sub $fontparam($sub)
10049 proc doprefs {} {
10050 global maxwidth maxgraphpct
10051 global oldprefs prefstop showneartags showlocalchanges
10052 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10053 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10055 set top .gitkprefs
10056 set prefstop $top
10057 if {[winfo exists $top]} {
10058 raise $top
10059 return
10061 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10062 limitdiffs tabstop perfile_attrs} {
10063 set oldprefs($v) [set $v]
10065 toplevel $top
10066 wm title $top [mc "Gitk preferences"]
10067 make_transient $top .
10068 label $top.ldisp -text [mc "Commit list display options"]
10069 grid $top.ldisp - -sticky w -pady 10
10070 label $top.spacer -text " "
10071 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10072 -font optionfont
10073 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10074 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10075 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10076 -font optionfont
10077 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10078 grid x $top.maxpctl $top.maxpct -sticky w
10079 frame $top.showlocal
10080 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
10081 checkbutton $top.showlocal.b -variable showlocalchanges
10082 pack $top.showlocal.b $top.showlocal.l -side left
10083 grid x $top.showlocal -sticky w
10084 frame $top.autoselect
10085 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
10086 checkbutton $top.autoselect.b -variable autoselect
10087 pack $top.autoselect.b $top.autoselect.l -side left
10088 grid x $top.autoselect -sticky w
10090 label $top.ddisp -text [mc "Diff display options"]
10091 grid $top.ddisp - -sticky w -pady 10
10092 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10093 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10094 grid x $top.tabstopl $top.tabstop -sticky w
10095 frame $top.ntag
10096 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
10097 checkbutton $top.ntag.b -variable showneartags
10098 pack $top.ntag.b $top.ntag.l -side left
10099 grid x $top.ntag -sticky w
10100 frame $top.ldiff
10101 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
10102 checkbutton $top.ldiff.b -variable limitdiffs
10103 pack $top.ldiff.b $top.ldiff.l -side left
10104 grid x $top.ldiff -sticky w
10105 frame $top.lattr
10106 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
10107 checkbutton $top.lattr.b -variable perfile_attrs
10108 pack $top.lattr.b $top.lattr.l -side left
10109 grid x $top.lattr -sticky w
10111 entry $top.extdifft -textvariable extdifftool
10112 frame $top.extdifff
10113 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10114 -padx 10
10115 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10116 -command choose_extdiff
10117 pack $top.extdifff.l $top.extdifff.b -side left
10118 grid x $top.extdifff $top.extdifft -sticky w
10120 label $top.cdisp -text [mc "Colors: press to choose"]
10121 grid $top.cdisp - -sticky w -pady 10
10122 label $top.bg -padx 40 -relief sunk -background $bgcolor
10123 button $top.bgbut -text [mc "Background"] -font optionfont \
10124 -command [list choosecolor bgcolor {} $top.bg background setbg]
10125 grid x $top.bgbut $top.bg -sticky w
10126 label $top.fg -padx 40 -relief sunk -background $fgcolor
10127 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10128 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10129 grid x $top.fgbut $top.fg -sticky w
10130 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10131 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10132 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10133 [list $ctext tag conf d0 -foreground]]
10134 grid x $top.diffoldbut $top.diffold -sticky w
10135 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10136 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10137 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10138 [list $ctext tag conf dresult -foreground]]
10139 grid x $top.diffnewbut $top.diffnew -sticky w
10140 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10141 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10142 -command [list choosecolor diffcolors 2 $top.hunksep \
10143 "diff hunk header" \
10144 [list $ctext tag conf hunksep -foreground]]
10145 grid x $top.hunksepbut $top.hunksep -sticky w
10146 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10147 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10148 -command [list choosecolor markbgcolor {} $top.markbgsep \
10149 [mc "marked line background"] \
10150 [list $ctext tag conf omark -background]]
10151 grid x $top.markbgbut $top.markbgsep -sticky w
10152 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10153 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10154 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10155 grid x $top.selbgbut $top.selbgsep -sticky w
10157 label $top.cfont -text [mc "Fonts: press to choose"]
10158 grid $top.cfont - -sticky w -pady 10
10159 mkfontdisp mainfont $top [mc "Main font"]
10160 mkfontdisp textfont $top [mc "Diff display font"]
10161 mkfontdisp uifont $top [mc "User interface font"]
10163 frame $top.buts
10164 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10165 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10166 bind $top <Key-Return> prefsok
10167 bind $top <Key-Escape> prefscan
10168 grid $top.buts.ok $top.buts.can
10169 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10170 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10171 grid $top.buts - - -pady 10 -sticky ew
10172 bind $top <Visibility> "focus $top.buts.ok"
10175 proc choose_extdiff {} {
10176 global extdifftool
10178 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10179 if {$prog ne {}} {
10180 set extdifftool $prog
10184 proc choosecolor {v vi w x cmd} {
10185 global $v
10187 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10188 -title [mc "Gitk: choose color for %s" $x]]
10189 if {$c eq {}} return
10190 $w conf -background $c
10191 lset $v $vi $c
10192 eval $cmd $c
10195 proc setselbg {c} {
10196 global bglist cflist
10197 foreach w $bglist {
10198 $w configure -selectbackground $c
10200 $cflist tag configure highlight \
10201 -background [$cflist cget -selectbackground]
10202 allcanvs itemconf secsel -fill $c
10205 proc setbg {c} {
10206 global bglist
10208 foreach w $bglist {
10209 $w conf -background $c
10213 proc setfg {c} {
10214 global fglist canv
10216 foreach w $fglist {
10217 $w conf -foreground $c
10219 allcanvs itemconf text -fill $c
10220 $canv itemconf circle -outline $c
10223 proc prefscan {} {
10224 global oldprefs prefstop
10226 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10227 limitdiffs tabstop perfile_attrs} {
10228 global $v
10229 set $v $oldprefs($v)
10231 catch {destroy $prefstop}
10232 unset prefstop
10233 fontcan
10236 proc prefsok {} {
10237 global maxwidth maxgraphpct
10238 global oldprefs prefstop showneartags showlocalchanges
10239 global fontpref mainfont textfont uifont
10240 global limitdiffs treediffs perfile_attrs
10242 catch {destroy $prefstop}
10243 unset prefstop
10244 fontcan
10245 set fontchanged 0
10246 if {$mainfont ne $fontpref(mainfont)} {
10247 set mainfont $fontpref(mainfont)
10248 parsefont mainfont $mainfont
10249 eval font configure mainfont [fontflags mainfont]
10250 eval font configure mainfontbold [fontflags mainfont 1]
10251 setcoords
10252 set fontchanged 1
10254 if {$textfont ne $fontpref(textfont)} {
10255 set textfont $fontpref(textfont)
10256 parsefont textfont $textfont
10257 eval font configure textfont [fontflags textfont]
10258 eval font configure textfontbold [fontflags textfont 1]
10260 if {$uifont ne $fontpref(uifont)} {
10261 set uifont $fontpref(uifont)
10262 parsefont uifont $uifont
10263 eval font configure uifont [fontflags uifont]
10265 settabs
10266 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10267 if {$showlocalchanges} {
10268 doshowlocalchanges
10269 } else {
10270 dohidelocalchanges
10273 if {$limitdiffs != $oldprefs(limitdiffs) ||
10274 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10275 # treediffs elements are limited by path;
10276 # won't have encodings cached if perfile_attrs was just turned on
10277 catch {unset treediffs}
10279 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10280 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10281 redisplay
10282 } elseif {$showneartags != $oldprefs(showneartags) ||
10283 $limitdiffs != $oldprefs(limitdiffs)} {
10284 reselectline
10288 proc formatdate {d} {
10289 global datetimeformat
10290 if {$d ne {}} {
10291 set d [clock format $d -format $datetimeformat]
10293 return $d
10296 # This list of encoding names and aliases is distilled from
10297 # http://www.iana.org/assignments/character-sets.
10298 # Not all of them are supported by Tcl.
10299 set encoding_aliases {
10300 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10301 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10302 { ISO-10646-UTF-1 csISO10646UTF1 }
10303 { ISO_646.basic:1983 ref csISO646basic1983 }
10304 { INVARIANT csINVARIANT }
10305 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10306 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10307 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10308 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10309 { NATS-DANO iso-ir-9-1 csNATSDANO }
10310 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10311 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10312 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10313 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10314 { ISO-2022-KR csISO2022KR }
10315 { EUC-KR csEUCKR }
10316 { ISO-2022-JP csISO2022JP }
10317 { ISO-2022-JP-2 csISO2022JP2 }
10318 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10319 csISO13JISC6220jp }
10320 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10321 { IT iso-ir-15 ISO646-IT csISO15Italian }
10322 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10323 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10324 { greek7-old iso-ir-18 csISO18Greek7Old }
10325 { latin-greek iso-ir-19 csISO19LatinGreek }
10326 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10327 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10328 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10329 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10330 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10331 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10332 { INIS iso-ir-49 csISO49INIS }
10333 { INIS-8 iso-ir-50 csISO50INIS8 }
10334 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10335 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10336 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10337 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10338 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10339 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10340 csISO60Norwegian1 }
10341 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10342 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10343 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10344 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10345 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10346 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10347 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10348 { greek7 iso-ir-88 csISO88Greek7 }
10349 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10350 { iso-ir-90 csISO90 }
10351 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10352 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10353 csISO92JISC62991984b }
10354 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10355 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10356 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10357 csISO95JIS62291984handadd }
10358 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10359 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10360 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10361 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10362 CP819 csISOLatin1 }
10363 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10364 { T.61-7bit iso-ir-102 csISO102T617bit }
10365 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10366 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10367 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10368 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10369 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10370 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10371 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10372 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10373 arabic csISOLatinArabic }
10374 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10375 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10376 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10377 greek greek8 csISOLatinGreek }
10378 { T.101-G2 iso-ir-128 csISO128T101G2 }
10379 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10380 csISOLatinHebrew }
10381 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10382 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10383 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10384 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10385 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10386 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10387 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10388 csISOLatinCyrillic }
10389 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10390 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10391 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10392 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10393 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10394 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10395 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10396 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10397 { ISO_10367-box iso-ir-155 csISO10367Box }
10398 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10399 { latin-lap lap iso-ir-158 csISO158Lap }
10400 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10401 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10402 { us-dk csUSDK }
10403 { dk-us csDKUS }
10404 { JIS_X0201 X0201 csHalfWidthKatakana }
10405 { KSC5636 ISO646-KR csKSC5636 }
10406 { ISO-10646-UCS-2 csUnicode }
10407 { ISO-10646-UCS-4 csUCS4 }
10408 { DEC-MCS dec csDECMCS }
10409 { hp-roman8 roman8 r8 csHPRoman8 }
10410 { macintosh mac csMacintosh }
10411 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10412 csIBM037 }
10413 { IBM038 EBCDIC-INT cp038 csIBM038 }
10414 { IBM273 CP273 csIBM273 }
10415 { IBM274 EBCDIC-BE CP274 csIBM274 }
10416 { IBM275 EBCDIC-BR cp275 csIBM275 }
10417 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10418 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10419 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10420 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10421 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10422 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10423 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10424 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10425 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10426 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10427 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10428 { IBM437 cp437 437 csPC8CodePage437 }
10429 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10430 { IBM775 cp775 csPC775Baltic }
10431 { IBM850 cp850 850 csPC850Multilingual }
10432 { IBM851 cp851 851 csIBM851 }
10433 { IBM852 cp852 852 csPCp852 }
10434 { IBM855 cp855 855 csIBM855 }
10435 { IBM857 cp857 857 csIBM857 }
10436 { IBM860 cp860 860 csIBM860 }
10437 { IBM861 cp861 861 cp-is csIBM861 }
10438 { IBM862 cp862 862 csPC862LatinHebrew }
10439 { IBM863 cp863 863 csIBM863 }
10440 { IBM864 cp864 csIBM864 }
10441 { IBM865 cp865 865 csIBM865 }
10442 { IBM866 cp866 866 csIBM866 }
10443 { IBM868 CP868 cp-ar csIBM868 }
10444 { IBM869 cp869 869 cp-gr csIBM869 }
10445 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10446 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10447 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10448 { IBM891 cp891 csIBM891 }
10449 { IBM903 cp903 csIBM903 }
10450 { IBM904 cp904 904 csIBBM904 }
10451 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10452 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10453 { IBM1026 CP1026 csIBM1026 }
10454 { EBCDIC-AT-DE csIBMEBCDICATDE }
10455 { EBCDIC-AT-DE-A csEBCDICATDEA }
10456 { EBCDIC-CA-FR csEBCDICCAFR }
10457 { EBCDIC-DK-NO csEBCDICDKNO }
10458 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10459 { EBCDIC-FI-SE csEBCDICFISE }
10460 { EBCDIC-FI-SE-A csEBCDICFISEA }
10461 { EBCDIC-FR csEBCDICFR }
10462 { EBCDIC-IT csEBCDICIT }
10463 { EBCDIC-PT csEBCDICPT }
10464 { EBCDIC-ES csEBCDICES }
10465 { EBCDIC-ES-A csEBCDICESA }
10466 { EBCDIC-ES-S csEBCDICESS }
10467 { EBCDIC-UK csEBCDICUK }
10468 { EBCDIC-US csEBCDICUS }
10469 { UNKNOWN-8BIT csUnknown8BiT }
10470 { MNEMONIC csMnemonic }
10471 { MNEM csMnem }
10472 { VISCII csVISCII }
10473 { VIQR csVIQR }
10474 { KOI8-R csKOI8R }
10475 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10476 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10477 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10478 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10479 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10480 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10481 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10482 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10483 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10484 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10485 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10486 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10487 { IBM1047 IBM-1047 }
10488 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10489 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10490 { UNICODE-1-1 csUnicode11 }
10491 { CESU-8 csCESU-8 }
10492 { BOCU-1 csBOCU-1 }
10493 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10494 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10495 l8 }
10496 { ISO-8859-15 ISO_8859-15 Latin-9 }
10497 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10498 { GBK CP936 MS936 windows-936 }
10499 { JIS_Encoding csJISEncoding }
10500 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10501 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10502 EUC-JP }
10503 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10504 { ISO-10646-UCS-Basic csUnicodeASCII }
10505 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10506 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10507 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10508 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10509 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10510 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10511 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10512 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10513 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10514 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10515 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10516 { Ventura-US csVenturaUS }
10517 { Ventura-International csVenturaInternational }
10518 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10519 { PC8-Turkish csPC8Turkish }
10520 { IBM-Symbols csIBMSymbols }
10521 { IBM-Thai csIBMThai }
10522 { HP-Legal csHPLegal }
10523 { HP-Pi-font csHPPiFont }
10524 { HP-Math8 csHPMath8 }
10525 { Adobe-Symbol-Encoding csHPPSMath }
10526 { HP-DeskTop csHPDesktop }
10527 { Ventura-Math csVenturaMath }
10528 { Microsoft-Publishing csMicrosoftPublishing }
10529 { Windows-31J csWindows31J }
10530 { GB2312 csGB2312 }
10531 { Big5 csBig5 }
10534 proc tcl_encoding {enc} {
10535 global encoding_aliases tcl_encoding_cache
10536 if {[info exists tcl_encoding_cache($enc)]} {
10537 return $tcl_encoding_cache($enc)
10539 set names [encoding names]
10540 set lcnames [string tolower $names]
10541 set enc [string tolower $enc]
10542 set i [lsearch -exact $lcnames $enc]
10543 if {$i < 0} {
10544 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10545 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10546 set i [lsearch -exact $lcnames $encx]
10549 if {$i < 0} {
10550 foreach l $encoding_aliases {
10551 set ll [string tolower $l]
10552 if {[lsearch -exact $ll $enc] < 0} continue
10553 # look through the aliases for one that tcl knows about
10554 foreach e $ll {
10555 set i [lsearch -exact $lcnames $e]
10556 if {$i < 0} {
10557 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10558 set i [lsearch -exact $lcnames $ex]
10561 if {$i >= 0} break
10563 break
10566 set tclenc {}
10567 if {$i >= 0} {
10568 set tclenc [lindex $names $i]
10570 set tcl_encoding_cache($enc) $tclenc
10571 return $tclenc
10574 proc gitattr {path attr default} {
10575 global path_attr_cache
10576 if {[info exists path_attr_cache($attr,$path)]} {
10577 set r $path_attr_cache($attr,$path)
10578 } else {
10579 set r "unspecified"
10580 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10581 regexp "(.*): encoding: (.*)" $line m f r
10583 set path_attr_cache($attr,$path) $r
10585 if {$r eq "unspecified"} {
10586 return $default
10588 return $r
10591 proc cache_gitattr {attr pathlist} {
10592 global path_attr_cache
10593 set newlist {}
10594 foreach path $pathlist {
10595 if {![info exists path_attr_cache($attr,$path)]} {
10596 lappend newlist $path
10599 set lim 1000
10600 if {[tk windowingsystem] == "win32"} {
10601 # windows has a 32k limit on the arguments to a command...
10602 set lim 30
10604 while {$newlist ne {}} {
10605 set head [lrange $newlist 0 [expr {$lim - 1}]]
10606 set newlist [lrange $newlist $lim end]
10607 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10608 foreach row [split $rlist "\n"] {
10609 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10610 if {[string index $path 0] eq "\""} {
10611 set path [encoding convertfrom [lindex $path 0]]
10613 set path_attr_cache($attr,$path) $value
10620 proc get_path_encoding {path} {
10621 global gui_encoding perfile_attrs
10622 set tcl_enc $gui_encoding
10623 if {$path ne {} && $perfile_attrs} {
10624 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10625 if {$enc2 ne {}} {
10626 set tcl_enc $enc2
10629 return $tcl_enc
10632 # First check that Tcl/Tk is recent enough
10633 if {[catch {package require Tk 8.4} err]} {
10634 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10635 Gitk requires at least Tcl/Tk 8.4."]
10636 exit 1
10639 # defaults...
10640 set wrcomcmd "git diff-tree --stdin -p --pretty"
10642 set gitencoding {}
10643 catch {
10644 set gitencoding [exec git config --get i18n.commitencoding]
10646 catch {
10647 set gitencoding [exec git config --get i18n.logoutputencoding]
10649 if {$gitencoding == ""} {
10650 set gitencoding "utf-8"
10652 set tclencoding [tcl_encoding $gitencoding]
10653 if {$tclencoding == {}} {
10654 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10657 set gui_encoding [encoding system]
10658 catch {
10659 set enc [exec git config --get gui.encoding]
10660 if {$enc ne {}} {
10661 set tclenc [tcl_encoding $enc]
10662 if {$tclenc ne {}} {
10663 set gui_encoding $tclenc
10664 } else {
10665 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10670 set mainfont {Helvetica 9}
10671 set textfont {Courier 9}
10672 set uifont {Helvetica 9 bold}
10673 set tabstop 8
10674 set findmergefiles 0
10675 set maxgraphpct 50
10676 set maxwidth 16
10677 set revlistorder 0
10678 set fastdate 0
10679 set uparrowlen 5
10680 set downarrowlen 5
10681 set mingaplen 100
10682 set cmitmode "patch"
10683 set wrapcomment "none"
10684 set showneartags 1
10685 set maxrefs 20
10686 set maxlinelen 200
10687 set showlocalchanges 1
10688 set limitdiffs 1
10689 set datetimeformat "%Y-%m-%d %H:%M:%S"
10690 set autoselect 1
10691 set perfile_attrs 0
10693 set extdifftool "meld"
10695 set colors {green red blue magenta darkgrey brown orange}
10696 set bgcolor white
10697 set fgcolor black
10698 set diffcolors {red "#00a000" blue}
10699 set diffcontext 3
10700 set ignorespace 0
10701 set selectbgcolor gray85
10702 set markbgcolor "#e0e0ff"
10704 set circlecolors {white blue gray blue blue}
10706 # button for popping up context menus
10707 if {[tk windowingsystem] eq "aqua"} {
10708 set ctxbut <Button-2>
10709 } else {
10710 set ctxbut <Button-3>
10713 ## For msgcat loading, first locate the installation location.
10714 if { [info exists ::env(GITK_MSGSDIR)] } {
10715 ## Msgsdir was manually set in the environment.
10716 set gitk_msgsdir $::env(GITK_MSGSDIR)
10717 } else {
10718 ## Let's guess the prefix from argv0.
10719 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10720 set gitk_libdir [file join $gitk_prefix share gitk lib]
10721 set gitk_msgsdir [file join $gitk_libdir msgs]
10722 unset gitk_prefix
10725 ## Internationalization (i18n) through msgcat and gettext. See
10726 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10727 package require msgcat
10728 namespace import ::msgcat::mc
10729 ## And eventually load the actual message catalog
10730 ::msgcat::mcload $gitk_msgsdir
10732 catch {source ~/.gitk}
10734 font create optionfont -family sans-serif -size -12
10736 parsefont mainfont $mainfont
10737 eval font create mainfont [fontflags mainfont]
10738 eval font create mainfontbold [fontflags mainfont 1]
10740 parsefont textfont $textfont
10741 eval font create textfont [fontflags textfont]
10742 eval font create textfontbold [fontflags textfont 1]
10744 parsefont uifont $uifont
10745 eval font create uifont [fontflags uifont]
10747 setoptions
10749 # check that we can find a .git directory somewhere...
10750 if {[catch {set gitdir [gitdir]}]} {
10751 show_error {} . [mc "Cannot find a git repository here."]
10752 exit 1
10754 if {![file isdirectory $gitdir]} {
10755 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10756 exit 1
10759 set selecthead {}
10760 set selectheadid {}
10762 set revtreeargs {}
10763 set cmdline_files {}
10764 set i 0
10765 set revtreeargscmd {}
10766 foreach arg $argv {
10767 switch -glob -- $arg {
10768 "" { }
10769 "--" {
10770 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10771 break
10773 "--select-commit=*" {
10774 set selecthead [string range $arg 16 end]
10776 "--argscmd=*" {
10777 set revtreeargscmd [string range $arg 10 end]
10779 default {
10780 lappend revtreeargs $arg
10783 incr i
10786 if {$selecthead eq "HEAD"} {
10787 set selecthead {}
10790 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10791 # no -- on command line, but some arguments (other than --argscmd)
10792 if {[catch {
10793 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10794 set cmdline_files [split $f "\n"]
10795 set n [llength $cmdline_files]
10796 set revtreeargs [lrange $revtreeargs 0 end-$n]
10797 # Unfortunately git rev-parse doesn't produce an error when
10798 # something is both a revision and a filename. To be consistent
10799 # with git log and git rev-list, check revtreeargs for filenames.
10800 foreach arg $revtreeargs {
10801 if {[file exists $arg]} {
10802 show_error {} . [mc "Ambiguous argument '%s': both revision\
10803 and filename" $arg]
10804 exit 1
10807 } err]} {
10808 # unfortunately we get both stdout and stderr in $err,
10809 # so look for "fatal:".
10810 set i [string first "fatal:" $err]
10811 if {$i > 0} {
10812 set err [string range $err [expr {$i + 6}] end]
10814 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10815 exit 1
10819 set nullid "0000000000000000000000000000000000000000"
10820 set nullid2 "0000000000000000000000000000000000000001"
10821 set nullfile "/dev/null"
10823 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10825 set runq {}
10826 set history {}
10827 set historyindex 0
10828 set fh_serial 0
10829 set nhl_names {}
10830 set highlight_paths {}
10831 set findpattern {}
10832 set searchdirn -forwards
10833 set boldids {}
10834 set boldnameids {}
10835 set diffelide {0 0}
10836 set markingmatches 0
10837 set linkentercount 0
10838 set need_redisplay 0
10839 set nrows_drawn 0
10840 set firsttabstop 0
10842 set nextviewnum 1
10843 set curview 0
10844 set selectedview 0
10845 set selectedhlview [mc "None"]
10846 set highlight_related [mc "None"]
10847 set highlight_files {}
10848 set viewfiles(0) {}
10849 set viewperm(0) 0
10850 set viewargs(0) {}
10851 set viewargscmd(0) {}
10853 set selectedline {}
10854 set numcommits 0
10855 set loginstance 0
10856 set cmdlineok 0
10857 set stopped 0
10858 set stuffsaved 0
10859 set patchnum 0
10860 set lserial 0
10861 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10862 setcoords
10863 makewindow
10864 # wait for the window to become visible
10865 tkwait visibility .
10866 wm title . "[file tail $argv0]: [file tail [pwd]]"
10867 readrefs
10869 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10870 # create a view for the files/dirs specified on the command line
10871 set curview 1
10872 set selectedview 1
10873 set nextviewnum 2
10874 set viewname(1) [mc "Command line"]
10875 set viewfiles(1) $cmdline_files
10876 set viewargs(1) $revtreeargs
10877 set viewargscmd(1) $revtreeargscmd
10878 set viewperm(1) 0
10879 set vdatemode(1) 0
10880 addviewmenu 1
10881 .bar.view entryconf [mca "Edit view..."] -state normal
10882 .bar.view entryconf [mca "Delete view"] -state normal
10885 if {[info exists permviews]} {
10886 foreach v $permviews {
10887 set n $nextviewnum
10888 incr nextviewnum
10889 set viewname($n) [lindex $v 0]
10890 set viewfiles($n) [lindex $v 1]
10891 set viewargs($n) [lindex $v 2]
10892 set viewargscmd($n) [lindex $v 3]
10893 set viewperm($n) 1
10894 addviewmenu $n
10897 getcommits {}