Merge branch 'maint'
[git/git-svn.git] / gitk-git / gitk
blob8c08310e6dea4aa904b47cd335686deedb6fd5ed
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 "--simplify-by-decoration" {
192 # These mean that we get a subset of the commits
193 set filtered 1
194 lappend glflags $arg
196 "-n" {
197 # This appears to be the only one that has a value as a
198 # separate word following it
199 set filtered 1
200 set nextisval 1
201 lappend glflags $arg
203 "--not" - "--all" {
204 lappend revargs $arg
206 "--merge" {
207 set vmergeonly($n) 1
208 # git rev-parse doesn't understand --merge
209 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
211 "-*" {
212 # Other flag arguments including -<n>
213 if {[string is digit -strict [string range $arg 1 end]]} {
214 set filtered 1
215 } else {
216 # a flag argument that we don't recognize;
217 # that means we can't optimize
218 set allknown 0
220 lappend glflags $arg
222 default {
223 # Non-flag arguments specify commits or ranges of commits
224 if {[string match "*...*" $arg]} {
225 lappend revargs --gitk-symmetric-diff-marker
227 lappend revargs $arg
231 set vdflags($n) $diffargs
232 set vflags($n) $glflags
233 set vrevs($n) $revargs
234 set vfiltered($n) $filtered
235 set vorigargs($n) $origargs
236 return $allknown
239 proc parseviewrevs {view revs} {
240 global vposids vnegids
242 if {$revs eq {}} {
243 set revs HEAD
245 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
246 # we get stdout followed by stderr in $err
247 # for an unknown rev, git rev-parse echoes it and then errors out
248 set errlines [split $err "\n"]
249 set badrev {}
250 for {set l 0} {$l < [llength $errlines]} {incr l} {
251 set line [lindex $errlines $l]
252 if {!([string length $line] == 40 && [string is xdigit $line])} {
253 if {[string match "fatal:*" $line]} {
254 if {[string match "fatal: ambiguous argument*" $line]
255 && $badrev ne {}} {
256 if {[llength $badrev] == 1} {
257 set err "unknown revision $badrev"
258 } else {
259 set err "unknown revisions: [join $badrev ", "]"
261 } else {
262 set err [join [lrange $errlines $l end] "\n"]
264 break
266 lappend badrev $line
269 error_popup "[mc "Error parsing revisions:"] $err"
270 return {}
272 set ret {}
273 set pos {}
274 set neg {}
275 set sdm 0
276 foreach id [split $ids "\n"] {
277 if {$id eq "--gitk-symmetric-diff-marker"} {
278 set sdm 4
279 } elseif {[string match "^*" $id]} {
280 if {$sdm != 1} {
281 lappend ret $id
282 if {$sdm == 3} {
283 set sdm 0
286 lappend neg [string range $id 1 end]
287 } else {
288 if {$sdm != 2} {
289 lappend ret $id
290 } else {
291 lset ret end $id...[lindex $ret end]
293 lappend pos $id
295 incr sdm -1
297 set vposids($view) $pos
298 set vnegids($view) $neg
299 return $ret
302 # Start off a git log process and arrange to read its output
303 proc start_rev_list {view} {
304 global startmsecs commitidx viewcomplete curview
305 global tclencoding
306 global viewargs viewargscmd viewfiles vfilelimit
307 global showlocalchanges
308 global viewactive viewinstances vmergeonly
309 global mainheadid viewmainheadid viewmainheadid_orig
310 global vcanopt vflags vrevs vorigargs
312 set startmsecs [clock clicks -milliseconds]
313 set commitidx($view) 0
314 # these are set this way for the error exits
315 set viewcomplete($view) 1
316 set viewactive($view) 0
317 varcinit $view
319 set args $viewargs($view)
320 if {$viewargscmd($view) ne {}} {
321 if {[catch {
322 set str [exec sh -c $viewargscmd($view)]
323 } err]} {
324 error_popup "[mc "Error executing --argscmd command:"] $err"
325 return 0
327 set args [concat $args [split $str "\n"]]
329 set vcanopt($view) [parseviewargs $view $args]
331 set files $viewfiles($view)
332 if {$vmergeonly($view)} {
333 set files [unmerged_files $files]
334 if {$files eq {}} {
335 global nr_unmerged
336 if {$nr_unmerged == 0} {
337 error_popup [mc "No files selected: --merge specified but\
338 no files are unmerged."]
339 } else {
340 error_popup [mc "No files selected: --merge specified but\
341 no unmerged files are within file limit."]
343 return 0
346 set vfilelimit($view) $files
348 if {$vcanopt($view)} {
349 set revs [parseviewrevs $view $vrevs($view)]
350 if {$revs eq {}} {
351 return 0
353 set args [concat $vflags($view) $revs]
354 } else {
355 set args $vorigargs($view)
358 if {[catch {
359 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
360 --boundary $args "--" $files] r]
361 } err]} {
362 error_popup "[mc "Error executing git log:"] $err"
363 return 0
365 set i [reg_instance $fd]
366 set viewinstances($view) [list $i]
367 set viewmainheadid($view) $mainheadid
368 set viewmainheadid_orig($view) $mainheadid
369 if {$files ne {} && $mainheadid ne {}} {
370 get_viewmainhead $view
372 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
373 interestedin $viewmainheadid($view) dodiffindex
375 fconfigure $fd -blocking 0 -translation lf -eofchar {}
376 if {$tclencoding != {}} {
377 fconfigure $fd -encoding $tclencoding
379 filerun $fd [list getcommitlines $fd $i $view 0]
380 nowbusy $view [mc "Reading"]
381 set viewcomplete($view) 0
382 set viewactive($view) 1
383 return 1
386 proc stop_instance {inst} {
387 global commfd leftover
389 set fd $commfd($inst)
390 catch {
391 set pid [pid $fd]
393 if {$::tcl_platform(platform) eq {windows}} {
394 exec kill -f $pid
395 } else {
396 exec kill $pid
399 catch {close $fd}
400 nukefile $fd
401 unset commfd($inst)
402 unset leftover($inst)
405 proc stop_backends {} {
406 global commfd
408 foreach inst [array names commfd] {
409 stop_instance $inst
413 proc stop_rev_list {view} {
414 global viewinstances
416 foreach inst $viewinstances($view) {
417 stop_instance $inst
419 set viewinstances($view) {}
422 proc reset_pending_select {selid} {
423 global pending_select mainheadid selectheadid
425 if {$selid ne {}} {
426 set pending_select $selid
427 } elseif {$selectheadid ne {}} {
428 set pending_select $selectheadid
429 } else {
430 set pending_select $mainheadid
434 proc getcommits {selid} {
435 global canv curview need_redisplay viewactive
437 initlayout
438 if {[start_rev_list $curview]} {
439 reset_pending_select $selid
440 show_status [mc "Reading commits..."]
441 set need_redisplay 1
442 } else {
443 show_status [mc "No commits selected"]
447 proc updatecommits {} {
448 global curview vcanopt vorigargs vfilelimit viewinstances
449 global viewactive viewcomplete tclencoding
450 global startmsecs showneartags showlocalchanges
451 global mainheadid viewmainheadid viewmainheadid_orig pending_select
452 global isworktree
453 global varcid vposids vnegids vflags vrevs
455 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
456 rereadrefs
457 set view $curview
458 if {$mainheadid ne $viewmainheadid_orig($view)} {
459 if {$showlocalchanges} {
460 dohidelocalchanges
462 set viewmainheadid($view) $mainheadid
463 set viewmainheadid_orig($view) $mainheadid
464 if {$vfilelimit($view) ne {}} {
465 get_viewmainhead $view
468 if {$showlocalchanges} {
469 doshowlocalchanges
471 if {$vcanopt($view)} {
472 set oldpos $vposids($view)
473 set oldneg $vnegids($view)
474 set revs [parseviewrevs $view $vrevs($view)]
475 if {$revs eq {}} {
476 return
478 # note: getting the delta when negative refs change is hard,
479 # and could require multiple git log invocations, so in that
480 # case we ask git log for all the commits (not just the delta)
481 if {$oldneg eq $vnegids($view)} {
482 set newrevs {}
483 set npos 0
484 # take out positive refs that we asked for before or
485 # that we have already seen
486 foreach rev $revs {
487 if {[string length $rev] == 40} {
488 if {[lsearch -exact $oldpos $rev] < 0
489 && ![info exists varcid($view,$rev)]} {
490 lappend newrevs $rev
491 incr npos
493 } else {
494 lappend $newrevs $rev
497 if {$npos == 0} return
498 set revs $newrevs
499 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
501 set args [concat $vflags($view) $revs --not $oldpos]
502 } else {
503 set args $vorigargs($view)
505 if {[catch {
506 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
507 --boundary $args "--" $vfilelimit($view)] r]
508 } err]} {
509 error_popup "[mc "Error executing git log:"] $err"
510 return
512 if {$viewactive($view) == 0} {
513 set startmsecs [clock clicks -milliseconds]
515 set i [reg_instance $fd]
516 lappend viewinstances($view) $i
517 fconfigure $fd -blocking 0 -translation lf -eofchar {}
518 if {$tclencoding != {}} {
519 fconfigure $fd -encoding $tclencoding
521 filerun $fd [list getcommitlines $fd $i $view 1]
522 incr viewactive($view)
523 set viewcomplete($view) 0
524 reset_pending_select {}
525 nowbusy $view [mc "Reading"]
526 if {$showneartags} {
527 getallcommits
531 proc reloadcommits {} {
532 global curview viewcomplete selectedline currentid thickerline
533 global showneartags treediffs commitinterest cached_commitrow
534 global targetid
536 set selid {}
537 if {$selectedline ne {}} {
538 set selid $currentid
541 if {!$viewcomplete($curview)} {
542 stop_rev_list $curview
544 resetvarcs $curview
545 set selectedline {}
546 catch {unset currentid}
547 catch {unset thickerline}
548 catch {unset treediffs}
549 readrefs
550 changedrefs
551 if {$showneartags} {
552 getallcommits
554 clear_display
555 catch {unset commitinterest}
556 catch {unset cached_commitrow}
557 catch {unset targetid}
558 setcanvscroll
559 getcommits $selid
560 return 0
563 # This makes a string representation of a positive integer which
564 # sorts as a string in numerical order
565 proc strrep {n} {
566 if {$n < 16} {
567 return [format "%x" $n]
568 } elseif {$n < 256} {
569 return [format "x%.2x" $n]
570 } elseif {$n < 65536} {
571 return [format "y%.4x" $n]
573 return [format "z%.8x" $n]
576 # Procedures used in reordering commits from git log (without
577 # --topo-order) into the order for display.
579 proc varcinit {view} {
580 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
581 global vtokmod varcmod vrowmod varcix vlastins
583 set varcstart($view) {{}}
584 set vupptr($view) {0}
585 set vdownptr($view) {0}
586 set vleftptr($view) {0}
587 set vbackptr($view) {0}
588 set varctok($view) {{}}
589 set varcrow($view) {{}}
590 set vtokmod($view) {}
591 set varcmod($view) 0
592 set vrowmod($view) 0
593 set varcix($view) {{}}
594 set vlastins($view) {0}
597 proc resetvarcs {view} {
598 global varcid varccommits parents children vseedcount ordertok
600 foreach vid [array names varcid $view,*] {
601 unset varcid($vid)
602 unset children($vid)
603 unset parents($vid)
605 # some commits might have children but haven't been seen yet
606 foreach vid [array names children $view,*] {
607 unset children($vid)
609 foreach va [array names varccommits $view,*] {
610 unset varccommits($va)
612 foreach vd [array names vseedcount $view,*] {
613 unset vseedcount($vd)
615 catch {unset ordertok}
618 # returns a list of the commits with no children
619 proc seeds {v} {
620 global vdownptr vleftptr varcstart
622 set ret {}
623 set a [lindex $vdownptr($v) 0]
624 while {$a != 0} {
625 lappend ret [lindex $varcstart($v) $a]
626 set a [lindex $vleftptr($v) $a]
628 return $ret
631 proc newvarc {view id} {
632 global varcid varctok parents children vdatemode
633 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
634 global commitdata commitinfo vseedcount varccommits vlastins
636 set a [llength $varctok($view)]
637 set vid $view,$id
638 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
639 if {![info exists commitinfo($id)]} {
640 parsecommit $id $commitdata($id) 1
642 set cdate [lindex $commitinfo($id) 4]
643 if {![string is integer -strict $cdate]} {
644 set cdate 0
646 if {![info exists vseedcount($view,$cdate)]} {
647 set vseedcount($view,$cdate) -1
649 set c [incr vseedcount($view,$cdate)]
650 set cdate [expr {$cdate ^ 0xffffffff}]
651 set tok "s[strrep $cdate][strrep $c]"
652 } else {
653 set tok {}
655 set ka 0
656 if {[llength $children($vid)] > 0} {
657 set kid [lindex $children($vid) end]
658 set k $varcid($view,$kid)
659 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
660 set ki $kid
661 set ka $k
662 set tok [lindex $varctok($view) $k]
665 if {$ka != 0} {
666 set i [lsearch -exact $parents($view,$ki) $id]
667 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
668 append tok [strrep $j]
670 set c [lindex $vlastins($view) $ka]
671 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
672 set c $ka
673 set b [lindex $vdownptr($view) $ka]
674 } else {
675 set b [lindex $vleftptr($view) $c]
677 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
678 set c $b
679 set b [lindex $vleftptr($view) $c]
681 if {$c == $ka} {
682 lset vdownptr($view) $ka $a
683 lappend vbackptr($view) 0
684 } else {
685 lset vleftptr($view) $c $a
686 lappend vbackptr($view) $c
688 lset vlastins($view) $ka $a
689 lappend vupptr($view) $ka
690 lappend vleftptr($view) $b
691 if {$b != 0} {
692 lset vbackptr($view) $b $a
694 lappend varctok($view) $tok
695 lappend varcstart($view) $id
696 lappend vdownptr($view) 0
697 lappend varcrow($view) {}
698 lappend varcix($view) {}
699 set varccommits($view,$a) {}
700 lappend vlastins($view) 0
701 return $a
704 proc splitvarc {p v} {
705 global varcid varcstart varccommits varctok vtokmod
706 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
708 set oa $varcid($v,$p)
709 set otok [lindex $varctok($v) $oa]
710 set ac $varccommits($v,$oa)
711 set i [lsearch -exact $varccommits($v,$oa) $p]
712 if {$i <= 0} return
713 set na [llength $varctok($v)]
714 # "%" sorts before "0"...
715 set tok "$otok%[strrep $i]"
716 lappend varctok($v) $tok
717 lappend varcrow($v) {}
718 lappend varcix($v) {}
719 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
720 set varccommits($v,$na) [lrange $ac $i end]
721 lappend varcstart($v) $p
722 foreach id $varccommits($v,$na) {
723 set varcid($v,$id) $na
725 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
726 lappend vlastins($v) [lindex $vlastins($v) $oa]
727 lset vdownptr($v) $oa $na
728 lset vlastins($v) $oa 0
729 lappend vupptr($v) $oa
730 lappend vleftptr($v) 0
731 lappend vbackptr($v) 0
732 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
733 lset vupptr($v) $b $na
735 if {[string compare $otok $vtokmod($v)] <= 0} {
736 modify_arc $v $oa
740 proc renumbervarc {a v} {
741 global parents children varctok varcstart varccommits
742 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
744 set t1 [clock clicks -milliseconds]
745 set todo {}
746 set isrelated($a) 1
747 set kidchanged($a) 1
748 set ntot 0
749 while {$a != 0} {
750 if {[info exists isrelated($a)]} {
751 lappend todo $a
752 set id [lindex $varccommits($v,$a) end]
753 foreach p $parents($v,$id) {
754 if {[info exists varcid($v,$p)]} {
755 set isrelated($varcid($v,$p)) 1
759 incr ntot
760 set b [lindex $vdownptr($v) $a]
761 if {$b == 0} {
762 while {$a != 0} {
763 set b [lindex $vleftptr($v) $a]
764 if {$b != 0} break
765 set a [lindex $vupptr($v) $a]
768 set a $b
770 foreach a $todo {
771 if {![info exists kidchanged($a)]} continue
772 set id [lindex $varcstart($v) $a]
773 if {[llength $children($v,$id)] > 1} {
774 set children($v,$id) [lsort -command [list vtokcmp $v] \
775 $children($v,$id)]
777 set oldtok [lindex $varctok($v) $a]
778 if {!$vdatemode($v)} {
779 set tok {}
780 } else {
781 set tok $oldtok
783 set ka 0
784 set kid [last_real_child $v,$id]
785 if {$kid ne {}} {
786 set k $varcid($v,$kid)
787 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
788 set ki $kid
789 set ka $k
790 set tok [lindex $varctok($v) $k]
793 if {$ka != 0} {
794 set i [lsearch -exact $parents($v,$ki) $id]
795 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
796 append tok [strrep $j]
798 if {$tok eq $oldtok} {
799 continue
801 set id [lindex $varccommits($v,$a) end]
802 foreach p $parents($v,$id) {
803 if {[info exists varcid($v,$p)]} {
804 set kidchanged($varcid($v,$p)) 1
805 } else {
806 set sortkids($p) 1
809 lset varctok($v) $a $tok
810 set b [lindex $vupptr($v) $a]
811 if {$b != $ka} {
812 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
813 modify_arc $v $ka
815 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
816 modify_arc $v $b
818 set c [lindex $vbackptr($v) $a]
819 set d [lindex $vleftptr($v) $a]
820 if {$c == 0} {
821 lset vdownptr($v) $b $d
822 } else {
823 lset vleftptr($v) $c $d
825 if {$d != 0} {
826 lset vbackptr($v) $d $c
828 if {[lindex $vlastins($v) $b] == $a} {
829 lset vlastins($v) $b $c
831 lset vupptr($v) $a $ka
832 set c [lindex $vlastins($v) $ka]
833 if {$c == 0 || \
834 [string compare $tok [lindex $varctok($v) $c]] < 0} {
835 set c $ka
836 set b [lindex $vdownptr($v) $ka]
837 } else {
838 set b [lindex $vleftptr($v) $c]
840 while {$b != 0 && \
841 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
842 set c $b
843 set b [lindex $vleftptr($v) $c]
845 if {$c == $ka} {
846 lset vdownptr($v) $ka $a
847 lset vbackptr($v) $a 0
848 } else {
849 lset vleftptr($v) $c $a
850 lset vbackptr($v) $a $c
852 lset vleftptr($v) $a $b
853 if {$b != 0} {
854 lset vbackptr($v) $b $a
856 lset vlastins($v) $ka $a
859 foreach id [array names sortkids] {
860 if {[llength $children($v,$id)] > 1} {
861 set children($v,$id) [lsort -command [list vtokcmp $v] \
862 $children($v,$id)]
865 set t2 [clock clicks -milliseconds]
866 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
869 # Fix up the graph after we have found out that in view $v,
870 # $p (a commit that we have already seen) is actually the parent
871 # of the last commit in arc $a.
872 proc fix_reversal {p a v} {
873 global varcid varcstart varctok vupptr
875 set pa $varcid($v,$p)
876 if {$p ne [lindex $varcstart($v) $pa]} {
877 splitvarc $p $v
878 set pa $varcid($v,$p)
880 # seeds always need to be renumbered
881 if {[lindex $vupptr($v) $pa] == 0 ||
882 [string compare [lindex $varctok($v) $a] \
883 [lindex $varctok($v) $pa]] > 0} {
884 renumbervarc $pa $v
888 proc insertrow {id p v} {
889 global cmitlisted children parents varcid varctok vtokmod
890 global varccommits ordertok commitidx numcommits curview
891 global targetid targetrow
893 readcommit $id
894 set vid $v,$id
895 set cmitlisted($vid) 1
896 set children($vid) {}
897 set parents($vid) [list $p]
898 set a [newvarc $v $id]
899 set varcid($vid) $a
900 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
901 modify_arc $v $a
903 lappend varccommits($v,$a) $id
904 set vp $v,$p
905 if {[llength [lappend children($vp) $id]] > 1} {
906 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
907 catch {unset ordertok}
909 fix_reversal $p $a $v
910 incr commitidx($v)
911 if {$v == $curview} {
912 set numcommits $commitidx($v)
913 setcanvscroll
914 if {[info exists targetid]} {
915 if {![comes_before $targetid $p]} {
916 incr targetrow
922 proc insertfakerow {id p} {
923 global varcid varccommits parents children cmitlisted
924 global commitidx varctok vtokmod targetid targetrow curview numcommits
926 set v $curview
927 set a $varcid($v,$p)
928 set i [lsearch -exact $varccommits($v,$a) $p]
929 if {$i < 0} {
930 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
931 return
933 set children($v,$id) {}
934 set parents($v,$id) [list $p]
935 set varcid($v,$id) $a
936 lappend children($v,$p) $id
937 set cmitlisted($v,$id) 1
938 set numcommits [incr commitidx($v)]
939 # note we deliberately don't update varcstart($v) even if $i == 0
940 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
941 modify_arc $v $a $i
942 if {[info exists targetid]} {
943 if {![comes_before $targetid $p]} {
944 incr targetrow
947 setcanvscroll
948 drawvisible
951 proc removefakerow {id} {
952 global varcid varccommits parents children commitidx
953 global varctok vtokmod cmitlisted currentid selectedline
954 global targetid curview numcommits
956 set v $curview
957 if {[llength $parents($v,$id)] != 1} {
958 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
959 return
961 set p [lindex $parents($v,$id) 0]
962 set a $varcid($v,$id)
963 set i [lsearch -exact $varccommits($v,$a) $id]
964 if {$i < 0} {
965 puts "oops: removefakerow can't find [shortids $id] on arc $a"
966 return
968 unset varcid($v,$id)
969 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
970 unset parents($v,$id)
971 unset children($v,$id)
972 unset cmitlisted($v,$id)
973 set numcommits [incr commitidx($v) -1]
974 set j [lsearch -exact $children($v,$p) $id]
975 if {$j >= 0} {
976 set children($v,$p) [lreplace $children($v,$p) $j $j]
978 modify_arc $v $a $i
979 if {[info exist currentid] && $id eq $currentid} {
980 unset currentid
981 set selectedline {}
983 if {[info exists targetid] && $targetid eq $id} {
984 set targetid $p
986 setcanvscroll
987 drawvisible
990 proc first_real_child {vp} {
991 global children nullid nullid2
993 foreach id $children($vp) {
994 if {$id ne $nullid && $id ne $nullid2} {
995 return $id
998 return {}
1001 proc last_real_child {vp} {
1002 global children nullid nullid2
1004 set kids $children($vp)
1005 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1006 set id [lindex $kids $i]
1007 if {$id ne $nullid && $id ne $nullid2} {
1008 return $id
1011 return {}
1014 proc vtokcmp {v a b} {
1015 global varctok varcid
1017 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1018 [lindex $varctok($v) $varcid($v,$b)]]
1021 # This assumes that if lim is not given, the caller has checked that
1022 # arc a's token is less than $vtokmod($v)
1023 proc modify_arc {v a {lim {}}} {
1024 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1026 if {$lim ne {}} {
1027 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1028 if {$c > 0} return
1029 if {$c == 0} {
1030 set r [lindex $varcrow($v) $a]
1031 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1034 set vtokmod($v) [lindex $varctok($v) $a]
1035 set varcmod($v) $a
1036 if {$v == $curview} {
1037 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1038 set a [lindex $vupptr($v) $a]
1039 set lim {}
1041 set r 0
1042 if {$a != 0} {
1043 if {$lim eq {}} {
1044 set lim [llength $varccommits($v,$a)]
1046 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1048 set vrowmod($v) $r
1049 undolayout $r
1053 proc update_arcrows {v} {
1054 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1055 global varcid vrownum varcorder varcix varccommits
1056 global vupptr vdownptr vleftptr varctok
1057 global displayorder parentlist curview cached_commitrow
1059 if {$vrowmod($v) == $commitidx($v)} return
1060 if {$v == $curview} {
1061 if {[llength $displayorder] > $vrowmod($v)} {
1062 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1063 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1065 catch {unset cached_commitrow}
1067 set narctot [expr {[llength $varctok($v)] - 1}]
1068 set a $varcmod($v)
1069 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1070 # go up the tree until we find something that has a row number,
1071 # or we get to a seed
1072 set a [lindex $vupptr($v) $a]
1074 if {$a == 0} {
1075 set a [lindex $vdownptr($v) 0]
1076 if {$a == 0} return
1077 set vrownum($v) {0}
1078 set varcorder($v) [list $a]
1079 lset varcix($v) $a 0
1080 lset varcrow($v) $a 0
1081 set arcn 0
1082 set row 0
1083 } else {
1084 set arcn [lindex $varcix($v) $a]
1085 if {[llength $vrownum($v)] > $arcn + 1} {
1086 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1087 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1089 set row [lindex $varcrow($v) $a]
1091 while {1} {
1092 set p $a
1093 incr row [llength $varccommits($v,$a)]
1094 # go down if possible
1095 set b [lindex $vdownptr($v) $a]
1096 if {$b == 0} {
1097 # if not, go left, or go up until we can go left
1098 while {$a != 0} {
1099 set b [lindex $vleftptr($v) $a]
1100 if {$b != 0} break
1101 set a [lindex $vupptr($v) $a]
1103 if {$a == 0} break
1105 set a $b
1106 incr arcn
1107 lappend vrownum($v) $row
1108 lappend varcorder($v) $a
1109 lset varcix($v) $a $arcn
1110 lset varcrow($v) $a $row
1112 set vtokmod($v) [lindex $varctok($v) $p]
1113 set varcmod($v) $p
1114 set vrowmod($v) $row
1115 if {[info exists currentid]} {
1116 set selectedline [rowofcommit $currentid]
1120 # Test whether view $v contains commit $id
1121 proc commitinview {id v} {
1122 global varcid
1124 return [info exists varcid($v,$id)]
1127 # Return the row number for commit $id in the current view
1128 proc rowofcommit {id} {
1129 global varcid varccommits varcrow curview cached_commitrow
1130 global varctok vtokmod
1132 set v $curview
1133 if {![info exists varcid($v,$id)]} {
1134 puts "oops rowofcommit no arc for [shortids $id]"
1135 return {}
1137 set a $varcid($v,$id)
1138 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1139 update_arcrows $v
1141 if {[info exists cached_commitrow($id)]} {
1142 return $cached_commitrow($id)
1144 set i [lsearch -exact $varccommits($v,$a) $id]
1145 if {$i < 0} {
1146 puts "oops didn't find commit [shortids $id] in arc $a"
1147 return {}
1149 incr i [lindex $varcrow($v) $a]
1150 set cached_commitrow($id) $i
1151 return $i
1154 # Returns 1 if a is on an earlier row than b, otherwise 0
1155 proc comes_before {a b} {
1156 global varcid varctok curview
1158 set v $curview
1159 if {$a eq $b || ![info exists varcid($v,$a)] || \
1160 ![info exists varcid($v,$b)]} {
1161 return 0
1163 if {$varcid($v,$a) != $varcid($v,$b)} {
1164 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1165 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1167 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1170 proc bsearch {l elt} {
1171 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1172 return 0
1174 set lo 0
1175 set hi [llength $l]
1176 while {$hi - $lo > 1} {
1177 set mid [expr {int(($lo + $hi) / 2)}]
1178 set t [lindex $l $mid]
1179 if {$elt < $t} {
1180 set hi $mid
1181 } elseif {$elt > $t} {
1182 set lo $mid
1183 } else {
1184 return $mid
1187 return $lo
1190 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1191 proc make_disporder {start end} {
1192 global vrownum curview commitidx displayorder parentlist
1193 global varccommits varcorder parents vrowmod varcrow
1194 global d_valid_start d_valid_end
1196 if {$end > $vrowmod($curview)} {
1197 update_arcrows $curview
1199 set ai [bsearch $vrownum($curview) $start]
1200 set start [lindex $vrownum($curview) $ai]
1201 set narc [llength $vrownum($curview)]
1202 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1203 set a [lindex $varcorder($curview) $ai]
1204 set l [llength $displayorder]
1205 set al [llength $varccommits($curview,$a)]
1206 if {$l < $r + $al} {
1207 if {$l < $r} {
1208 set pad [ntimes [expr {$r - $l}] {}]
1209 set displayorder [concat $displayorder $pad]
1210 set parentlist [concat $parentlist $pad]
1211 } elseif {$l > $r} {
1212 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1213 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1215 foreach id $varccommits($curview,$a) {
1216 lappend displayorder $id
1217 lappend parentlist $parents($curview,$id)
1219 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1220 set i $r
1221 foreach id $varccommits($curview,$a) {
1222 lset displayorder $i $id
1223 lset parentlist $i $parents($curview,$id)
1224 incr i
1227 incr r $al
1231 proc commitonrow {row} {
1232 global displayorder
1234 set id [lindex $displayorder $row]
1235 if {$id eq {}} {
1236 make_disporder $row [expr {$row + 1}]
1237 set id [lindex $displayorder $row]
1239 return $id
1242 proc closevarcs {v} {
1243 global varctok varccommits varcid parents children
1244 global cmitlisted commitidx vtokmod
1246 set missing_parents 0
1247 set scripts {}
1248 set narcs [llength $varctok($v)]
1249 for {set a 1} {$a < $narcs} {incr a} {
1250 set id [lindex $varccommits($v,$a) end]
1251 foreach p $parents($v,$id) {
1252 if {[info exists varcid($v,$p)]} continue
1253 # add p as a new commit
1254 incr missing_parents
1255 set cmitlisted($v,$p) 0
1256 set parents($v,$p) {}
1257 if {[llength $children($v,$p)] == 1 &&
1258 [llength $parents($v,$id)] == 1} {
1259 set b $a
1260 } else {
1261 set b [newvarc $v $p]
1263 set varcid($v,$p) $b
1264 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1265 modify_arc $v $b
1267 lappend varccommits($v,$b) $p
1268 incr commitidx($v)
1269 set scripts [check_interest $p $scripts]
1272 if {$missing_parents > 0} {
1273 foreach s $scripts {
1274 eval $s
1279 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1280 # Assumes we already have an arc for $rwid.
1281 proc rewrite_commit {v id rwid} {
1282 global children parents varcid varctok vtokmod varccommits
1284 foreach ch $children($v,$id) {
1285 # make $rwid be $ch's parent in place of $id
1286 set i [lsearch -exact $parents($v,$ch) $id]
1287 if {$i < 0} {
1288 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1290 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1291 # add $ch to $rwid's children and sort the list if necessary
1292 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1293 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1294 $children($v,$rwid)]
1296 # fix the graph after joining $id to $rwid
1297 set a $varcid($v,$ch)
1298 fix_reversal $rwid $a $v
1299 # parentlist is wrong for the last element of arc $a
1300 # even if displayorder is right, hence the 3rd arg here
1301 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1305 # Mechanism for registering a command to be executed when we come
1306 # across a particular commit. To handle the case when only the
1307 # prefix of the commit is known, the commitinterest array is now
1308 # indexed by the first 4 characters of the ID. Each element is a
1309 # list of id, cmd pairs.
1310 proc interestedin {id cmd} {
1311 global commitinterest
1313 lappend commitinterest([string range $id 0 3]) $id $cmd
1316 proc check_interest {id scripts} {
1317 global commitinterest
1319 set prefix [string range $id 0 3]
1320 if {[info exists commitinterest($prefix)]} {
1321 set newlist {}
1322 foreach {i script} $commitinterest($prefix) {
1323 if {[string match "$i*" $id]} {
1324 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1325 } else {
1326 lappend newlist $i $script
1329 if {$newlist ne {}} {
1330 set commitinterest($prefix) $newlist
1331 } else {
1332 unset commitinterest($prefix)
1335 return $scripts
1338 proc getcommitlines {fd inst view updating} {
1339 global cmitlisted leftover
1340 global commitidx commitdata vdatemode
1341 global parents children curview hlview
1342 global idpending ordertok
1343 global varccommits varcid varctok vtokmod vfilelimit
1345 set stuff [read $fd 500000]
1346 # git log doesn't terminate the last commit with a null...
1347 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1348 set stuff "\0"
1350 if {$stuff == {}} {
1351 if {![eof $fd]} {
1352 return 1
1354 global commfd viewcomplete viewactive viewname
1355 global viewinstances
1356 unset commfd($inst)
1357 set i [lsearch -exact $viewinstances($view) $inst]
1358 if {$i >= 0} {
1359 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1361 # set it blocking so we wait for the process to terminate
1362 fconfigure $fd -blocking 1
1363 if {[catch {close $fd} err]} {
1364 set fv {}
1365 if {$view != $curview} {
1366 set fv " for the \"$viewname($view)\" view"
1368 if {[string range $err 0 4] == "usage"} {
1369 set err "Gitk: error reading commits$fv:\
1370 bad arguments to git log."
1371 if {$viewname($view) eq "Command line"} {
1372 append err \
1373 " (Note: arguments to gitk are passed to git log\
1374 to allow selection of commits to be displayed.)"
1376 } else {
1377 set err "Error reading commits$fv: $err"
1379 error_popup $err
1381 if {[incr viewactive($view) -1] <= 0} {
1382 set viewcomplete($view) 1
1383 # Check if we have seen any ids listed as parents that haven't
1384 # appeared in the list
1385 closevarcs $view
1386 notbusy $view
1388 if {$view == $curview} {
1389 run chewcommits
1391 return 0
1393 set start 0
1394 set gotsome 0
1395 set scripts {}
1396 while 1 {
1397 set i [string first "\0" $stuff $start]
1398 if {$i < 0} {
1399 append leftover($inst) [string range $stuff $start end]
1400 break
1402 if {$start == 0} {
1403 set cmit $leftover($inst)
1404 append cmit [string range $stuff 0 [expr {$i - 1}]]
1405 set leftover($inst) {}
1406 } else {
1407 set cmit [string range $stuff $start [expr {$i - 1}]]
1409 set start [expr {$i + 1}]
1410 set j [string first "\n" $cmit]
1411 set ok 0
1412 set listed 1
1413 if {$j >= 0 && [string match "commit *" $cmit]} {
1414 set ids [string range $cmit 7 [expr {$j - 1}]]
1415 if {[string match {[-^<>]*} $ids]} {
1416 switch -- [string index $ids 0] {
1417 "-" {set listed 0}
1418 "^" {set listed 2}
1419 "<" {set listed 3}
1420 ">" {set listed 4}
1422 set ids [string range $ids 1 end]
1424 set ok 1
1425 foreach id $ids {
1426 if {[string length $id] != 40} {
1427 set ok 0
1428 break
1432 if {!$ok} {
1433 set shortcmit $cmit
1434 if {[string length $shortcmit] > 80} {
1435 set shortcmit "[string range $shortcmit 0 80]..."
1437 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1438 exit 1
1440 set id [lindex $ids 0]
1441 set vid $view,$id
1443 if {!$listed && $updating && ![info exists varcid($vid)] &&
1444 $vfilelimit($view) ne {}} {
1445 # git log doesn't rewrite parents for unlisted commits
1446 # when doing path limiting, so work around that here
1447 # by working out the rewritten parent with git rev-list
1448 # and if we already know about it, using the rewritten
1449 # parent as a substitute parent for $id's children.
1450 if {![catch {
1451 set rwid [exec git rev-list --first-parent --max-count=1 \
1452 $id -- $vfilelimit($view)]
1453 }]} {
1454 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1455 # use $rwid in place of $id
1456 rewrite_commit $view $id $rwid
1457 continue
1462 set a 0
1463 if {[info exists varcid($vid)]} {
1464 if {$cmitlisted($vid) || !$listed} continue
1465 set a $varcid($vid)
1467 if {$listed} {
1468 set olds [lrange $ids 1 end]
1469 } else {
1470 set olds {}
1472 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1473 set cmitlisted($vid) $listed
1474 set parents($vid) $olds
1475 if {![info exists children($vid)]} {
1476 set children($vid) {}
1477 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1478 set k [lindex $children($vid) 0]
1479 if {[llength $parents($view,$k)] == 1 &&
1480 (!$vdatemode($view) ||
1481 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1482 set a $varcid($view,$k)
1485 if {$a == 0} {
1486 # new arc
1487 set a [newvarc $view $id]
1489 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1490 modify_arc $view $a
1492 if {![info exists varcid($vid)]} {
1493 set varcid($vid) $a
1494 lappend varccommits($view,$a) $id
1495 incr commitidx($view)
1498 set i 0
1499 foreach p $olds {
1500 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1501 set vp $view,$p
1502 if {[llength [lappend children($vp) $id]] > 1 &&
1503 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1504 set children($vp) [lsort -command [list vtokcmp $view] \
1505 $children($vp)]
1506 catch {unset ordertok}
1508 if {[info exists varcid($view,$p)]} {
1509 fix_reversal $p $a $view
1512 incr i
1515 set scripts [check_interest $id $scripts]
1516 set gotsome 1
1518 if {$gotsome} {
1519 global numcommits hlview
1521 if {$view == $curview} {
1522 set numcommits $commitidx($view)
1523 run chewcommits
1525 if {[info exists hlview] && $view == $hlview} {
1526 # we never actually get here...
1527 run vhighlightmore
1529 foreach s $scripts {
1530 eval $s
1533 return 2
1536 proc chewcommits {} {
1537 global curview hlview viewcomplete
1538 global pending_select
1540 layoutmore
1541 if {$viewcomplete($curview)} {
1542 global commitidx varctok
1543 global numcommits startmsecs
1545 if {[info exists pending_select]} {
1546 update
1547 reset_pending_select {}
1549 if {[commitinview $pending_select $curview]} {
1550 selectline [rowofcommit $pending_select] 1
1551 } else {
1552 set row [first_real_row]
1553 selectline $row 1
1556 if {$commitidx($curview) > 0} {
1557 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1558 #puts "overall $ms ms for $numcommits commits"
1559 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1560 } else {
1561 show_status [mc "No commits selected"]
1563 notbusy layout
1565 return 0
1568 proc do_readcommit {id} {
1569 global tclencoding
1571 # Invoke git-log to handle automatic encoding conversion
1572 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1573 # Read the results using i18n.logoutputencoding
1574 fconfigure $fd -translation lf -eofchar {}
1575 if {$tclencoding != {}} {
1576 fconfigure $fd -encoding $tclencoding
1578 set contents [read $fd]
1579 close $fd
1580 # Remove the heading line
1581 regsub {^commit [0-9a-f]+\n} $contents {} contents
1583 return $contents
1586 proc readcommit {id} {
1587 if {[catch {set contents [do_readcommit $id]}]} return
1588 parsecommit $id $contents 1
1591 proc parsecommit {id contents listed} {
1592 global commitinfo cdate
1594 set inhdr 1
1595 set comment {}
1596 set headline {}
1597 set auname {}
1598 set audate {}
1599 set comname {}
1600 set comdate {}
1601 set hdrend [string first "\n\n" $contents]
1602 if {$hdrend < 0} {
1603 # should never happen...
1604 set hdrend [string length $contents]
1606 set header [string range $contents 0 [expr {$hdrend - 1}]]
1607 set comment [string range $contents [expr {$hdrend + 2}] end]
1608 foreach line [split $header "\n"] {
1609 set line [split $line " "]
1610 set tag [lindex $line 0]
1611 if {$tag == "author"} {
1612 set audate [lindex $line end-1]
1613 set auname [join [lrange $line 1 end-2] " "]
1614 } elseif {$tag == "committer"} {
1615 set comdate [lindex $line end-1]
1616 set comname [join [lrange $line 1 end-2] " "]
1619 set headline {}
1620 # take the first non-blank line of the comment as the headline
1621 set headline [string trimleft $comment]
1622 set i [string first "\n" $headline]
1623 if {$i >= 0} {
1624 set headline [string range $headline 0 $i]
1626 set headline [string trimright $headline]
1627 set i [string first "\r" $headline]
1628 if {$i >= 0} {
1629 set headline [string trimright [string range $headline 0 $i]]
1631 if {!$listed} {
1632 # git log indents the comment by 4 spaces;
1633 # if we got this via git cat-file, add the indentation
1634 set newcomment {}
1635 foreach line [split $comment "\n"] {
1636 append newcomment " "
1637 append newcomment $line
1638 append newcomment "\n"
1640 set comment $newcomment
1642 if {$comdate != {}} {
1643 set cdate($id) $comdate
1645 set commitinfo($id) [list $headline $auname $audate \
1646 $comname $comdate $comment]
1649 proc getcommit {id} {
1650 global commitdata commitinfo
1652 if {[info exists commitdata($id)]} {
1653 parsecommit $id $commitdata($id) 1
1654 } else {
1655 readcommit $id
1656 if {![info exists commitinfo($id)]} {
1657 set commitinfo($id) [list [mc "No commit information available"]]
1660 return 1
1663 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1664 # and are present in the current view.
1665 # This is fairly slow...
1666 proc longid {prefix} {
1667 global varcid curview
1669 set ids {}
1670 foreach match [array names varcid "$curview,$prefix*"] {
1671 lappend ids [lindex [split $match ","] 1]
1673 return $ids
1676 proc readrefs {} {
1677 global tagids idtags headids idheads tagobjid
1678 global otherrefids idotherrefs mainhead mainheadid
1679 global selecthead selectheadid
1680 global hideremotes
1682 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1683 catch {unset $v}
1685 set refd [open [list | git show-ref -d] r]
1686 while {[gets $refd line] >= 0} {
1687 if {[string index $line 40] ne " "} continue
1688 set id [string range $line 0 39]
1689 set ref [string range $line 41 end]
1690 if {![string match "refs/*" $ref]} continue
1691 set name [string range $ref 5 end]
1692 if {[string match "remotes/*" $name]} {
1693 if {![string match "*/HEAD" $name] && !$hideremotes} {
1694 set headids($name) $id
1695 lappend idheads($id) $name
1697 } elseif {[string match "heads/*" $name]} {
1698 set name [string range $name 6 end]
1699 set headids($name) $id
1700 lappend idheads($id) $name
1701 } elseif {[string match "tags/*" $name]} {
1702 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1703 # which is what we want since the former is the commit ID
1704 set name [string range $name 5 end]
1705 if {[string match "*^{}" $name]} {
1706 set name [string range $name 0 end-3]
1707 } else {
1708 set tagobjid($name) $id
1710 set tagids($name) $id
1711 lappend idtags($id) $name
1712 } else {
1713 set otherrefids($name) $id
1714 lappend idotherrefs($id) $name
1717 catch {close $refd}
1718 set mainhead {}
1719 set mainheadid {}
1720 catch {
1721 set mainheadid [exec git rev-parse HEAD]
1722 set thehead [exec git symbolic-ref HEAD]
1723 if {[string match "refs/heads/*" $thehead]} {
1724 set mainhead [string range $thehead 11 end]
1727 set selectheadid {}
1728 if {$selecthead ne {}} {
1729 catch {
1730 set selectheadid [exec git rev-parse --verify $selecthead]
1735 # skip over fake commits
1736 proc first_real_row {} {
1737 global nullid nullid2 numcommits
1739 for {set row 0} {$row < $numcommits} {incr row} {
1740 set id [commitonrow $row]
1741 if {$id ne $nullid && $id ne $nullid2} {
1742 break
1745 return $row
1748 # update things for a head moved to a child of its previous location
1749 proc movehead {id name} {
1750 global headids idheads
1752 removehead $headids($name) $name
1753 set headids($name) $id
1754 lappend idheads($id) $name
1757 # update things when a head has been removed
1758 proc removehead {id name} {
1759 global headids idheads
1761 if {$idheads($id) eq $name} {
1762 unset idheads($id)
1763 } else {
1764 set i [lsearch -exact $idheads($id) $name]
1765 if {$i >= 0} {
1766 set idheads($id) [lreplace $idheads($id) $i $i]
1769 unset headids($name)
1772 proc make_transient {window origin} {
1773 global have_tk85
1775 # In MacOS Tk 8.4 transient appears to work by setting
1776 # overrideredirect, which is utterly useless, since the
1777 # windows get no border, and are not even kept above
1778 # the parent.
1779 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1781 wm transient $window $origin
1783 # Windows fails to place transient windows normally, so
1784 # schedule a callback to center them on the parent.
1785 if {[tk windowingsystem] eq {win32}} {
1786 after idle [list tk::PlaceWindow $window widget $origin]
1790 proc show_error {w top msg} {
1791 message $w.m -text $msg -justify center -aspect 400
1792 pack $w.m -side top -fill x -padx 20 -pady 20
1793 button $w.ok -text [mc OK] -command "destroy $top"
1794 pack $w.ok -side bottom -fill x
1795 bind $top <Visibility> "grab $top; focus $top"
1796 bind $top <Key-Return> "destroy $top"
1797 bind $top <Key-space> "destroy $top"
1798 bind $top <Key-Escape> "destroy $top"
1799 tkwait window $top
1802 proc error_popup {msg {owner .}} {
1803 set w .error
1804 toplevel $w
1805 make_transient $w $owner
1806 show_error $w $w $msg
1809 proc confirm_popup {msg {owner .}} {
1810 global confirm_ok
1811 set confirm_ok 0
1812 set w .confirm
1813 toplevel $w
1814 make_transient $w $owner
1815 message $w.m -text $msg -justify center -aspect 400
1816 pack $w.m -side top -fill x -padx 20 -pady 20
1817 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1818 pack $w.ok -side left -fill x
1819 button $w.cancel -text [mc Cancel] -command "destroy $w"
1820 pack $w.cancel -side right -fill x
1821 bind $w <Visibility> "grab $w; focus $w"
1822 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1823 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1824 bind $w <Key-Escape> "destroy $w"
1825 tkwait window $w
1826 return $confirm_ok
1829 proc setoptions {} {
1830 option add *Panedwindow.showHandle 1 startupFile
1831 option add *Panedwindow.sashRelief raised startupFile
1832 option add *Button.font uifont startupFile
1833 option add *Checkbutton.font uifont startupFile
1834 option add *Radiobutton.font uifont startupFile
1835 if {[tk windowingsystem] ne "aqua"} {
1836 option add *Menu.font uifont startupFile
1838 option add *Menubutton.font uifont startupFile
1839 option add *Label.font uifont startupFile
1840 option add *Message.font uifont startupFile
1841 option add *Entry.font uifont startupFile
1844 # Make a menu and submenus.
1845 # m is the window name for the menu, items is the list of menu items to add.
1846 # Each item is a list {mc label type description options...}
1847 # mc is ignored; it's so we can put mc there to alert xgettext
1848 # label is the string that appears in the menu
1849 # type is cascade, command or radiobutton (should add checkbutton)
1850 # description depends on type; it's the sublist for cascade, the
1851 # command to invoke for command, or {variable value} for radiobutton
1852 proc makemenu {m items} {
1853 menu $m
1854 if {[tk windowingsystem] eq {aqua}} {
1855 set Meta1 Cmd
1856 } else {
1857 set Meta1 Ctrl
1859 foreach i $items {
1860 set name [mc [lindex $i 1]]
1861 set type [lindex $i 2]
1862 set thing [lindex $i 3]
1863 set params [list $type]
1864 if {$name ne {}} {
1865 set u [string first "&" [string map {&& x} $name]]
1866 lappend params -label [string map {&& & & {}} $name]
1867 if {$u >= 0} {
1868 lappend params -underline $u
1871 switch -- $type {
1872 "cascade" {
1873 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1874 lappend params -menu $m.$submenu
1876 "command" {
1877 lappend params -command $thing
1879 "radiobutton" {
1880 lappend params -variable [lindex $thing 0] \
1881 -value [lindex $thing 1]
1884 set tail [lrange $i 4 end]
1885 regsub -all {\yMeta1\y} $tail $Meta1 tail
1886 eval $m add $params $tail
1887 if {$type eq "cascade"} {
1888 makemenu $m.$submenu $thing
1893 # translate string and remove ampersands
1894 proc mca {str} {
1895 return [string map {&& & & {}} [mc $str]]
1898 proc makewindow {} {
1899 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1900 global tabstop
1901 global findtype findtypemenu findloc findstring fstring geometry
1902 global entries sha1entry sha1string sha1but
1903 global diffcontextstring diffcontext
1904 global ignorespace
1905 global maincursor textcursor curtextcursor
1906 global rowctxmenu fakerowmenu mergemax wrapcomment
1907 global highlight_files gdttype
1908 global searchstring sstring
1909 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1910 global headctxmenu progresscanv progressitem progresscoords statusw
1911 global fprogitem fprogcoord lastprogupdate progupdatepending
1912 global rprogitem rprogcoord rownumsel numcommits
1913 global have_tk85
1915 # The "mc" arguments here are purely so that xgettext
1916 # sees the following string as needing to be translated
1917 set file {
1918 mc "File" cascade {
1919 {mc "Update" command updatecommits -accelerator F5}
1920 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1921 {mc "Reread references" command rereadrefs}
1922 {mc "List references" command showrefs -accelerator F2}
1923 {xx "" separator}
1924 {mc "Start git gui" command {exec git gui &}}
1925 {xx "" separator}
1926 {mc "Quit" command doquit -accelerator Meta1-Q}
1928 set edit {
1929 mc "Edit" cascade {
1930 {mc "Preferences" command doprefs}
1932 set view {
1933 mc "View" cascade {
1934 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1935 {mc "Edit view..." command editview -state disabled -accelerator F4}
1936 {mc "Delete view" command delview -state disabled}
1937 {xx "" separator}
1938 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1940 if {[tk windowingsystem] ne "aqua"} {
1941 set help {
1942 mc "Help" cascade {
1943 {mc "About gitk" command about}
1944 {mc "Key bindings" command keys}
1946 set bar [list $file $edit $view $help]
1947 } else {
1948 proc ::tk::mac::ShowPreferences {} {doprefs}
1949 proc ::tk::mac::Quit {} {doquit}
1950 lset file end [lreplace [lindex $file end] end-1 end]
1951 set apple {
1952 xx "Apple" cascade {
1953 {mc "About gitk" command about}
1954 {xx "" separator}
1956 set help {
1957 mc "Help" cascade {
1958 {mc "Key bindings" command keys}
1960 set bar [list $apple $file $view $help]
1962 makemenu .bar $bar
1963 . configure -menu .bar
1965 # the gui has upper and lower half, parts of a paned window.
1966 panedwindow .ctop -orient vertical
1968 # possibly use assumed geometry
1969 if {![info exists geometry(pwsash0)]} {
1970 set geometry(topheight) [expr {15 * $linespc}]
1971 set geometry(topwidth) [expr {80 * $charspc}]
1972 set geometry(botheight) [expr {15 * $linespc}]
1973 set geometry(botwidth) [expr {50 * $charspc}]
1974 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1975 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1978 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1979 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1980 frame .tf.histframe
1981 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1983 # create three canvases
1984 set cscroll .tf.histframe.csb
1985 set canv .tf.histframe.pwclist.canv
1986 canvas $canv \
1987 -selectbackground $selectbgcolor \
1988 -background $bgcolor -bd 0 \
1989 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1990 .tf.histframe.pwclist add $canv
1991 set canv2 .tf.histframe.pwclist.canv2
1992 canvas $canv2 \
1993 -selectbackground $selectbgcolor \
1994 -background $bgcolor -bd 0 -yscrollincr $linespc
1995 .tf.histframe.pwclist add $canv2
1996 set canv3 .tf.histframe.pwclist.canv3
1997 canvas $canv3 \
1998 -selectbackground $selectbgcolor \
1999 -background $bgcolor -bd 0 -yscrollincr $linespc
2000 .tf.histframe.pwclist add $canv3
2001 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2002 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2004 # a scroll bar to rule them
2005 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
2006 pack $cscroll -side right -fill y
2007 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2008 lappend bglist $canv $canv2 $canv3
2009 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2011 # we have two button bars at bottom of top frame. Bar 1
2012 frame .tf.bar
2013 frame .tf.lbar -height 15
2015 set sha1entry .tf.bar.sha1
2016 set entries $sha1entry
2017 set sha1but .tf.bar.sha1label
2018 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2019 -command gotocommit -width 8
2020 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2021 pack .tf.bar.sha1label -side left
2022 entry $sha1entry -width 40 -font textfont -textvariable sha1string
2023 trace add variable sha1string write sha1change
2024 pack $sha1entry -side left -pady 2
2026 image create bitmap bm-left -data {
2027 #define left_width 16
2028 #define left_height 16
2029 static unsigned char left_bits[] = {
2030 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2031 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2032 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2034 image create bitmap bm-right -data {
2035 #define right_width 16
2036 #define right_height 16
2037 static unsigned char right_bits[] = {
2038 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2039 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2040 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2042 button .tf.bar.leftbut -image bm-left -command goback \
2043 -state disabled -width 26
2044 pack .tf.bar.leftbut -side left -fill y
2045 button .tf.bar.rightbut -image bm-right -command goforw \
2046 -state disabled -width 26
2047 pack .tf.bar.rightbut -side left -fill y
2049 label .tf.bar.rowlabel -text [mc "Row"]
2050 set rownumsel {}
2051 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2052 -relief sunken -anchor e
2053 label .tf.bar.rowlabel2 -text "/"
2054 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2055 -relief sunken -anchor e
2056 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2057 -side left
2058 global selectedline
2059 trace add variable selectedline write selectedline_change
2061 # Status label and progress bar
2062 set statusw .tf.bar.status
2063 label $statusw -width 15 -relief sunken
2064 pack $statusw -side left -padx 5
2065 set h [expr {[font metrics uifont -linespace] + 2}]
2066 set progresscanv .tf.bar.progress
2067 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2068 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2069 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2070 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2071 pack $progresscanv -side right -expand 1 -fill x
2072 set progresscoords {0 0}
2073 set fprogcoord 0
2074 set rprogcoord 0
2075 bind $progresscanv <Configure> adjustprogress
2076 set lastprogupdate [clock clicks -milliseconds]
2077 set progupdatepending 0
2079 # build up the bottom bar of upper window
2080 label .tf.lbar.flabel -text "[mc "Find"] "
2081 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2082 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2083 label .tf.lbar.flab2 -text " [mc "commit"] "
2084 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2085 -side left -fill y
2086 set gdttype [mc "containing:"]
2087 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2088 [mc "containing:"] \
2089 [mc "touching paths:"] \
2090 [mc "adding/removing string:"]]
2091 trace add variable gdttype write gdttype_change
2092 pack .tf.lbar.gdttype -side left -fill y
2094 set findstring {}
2095 set fstring .tf.lbar.findstring
2096 lappend entries $fstring
2097 entry $fstring -width 30 -font textfont -textvariable findstring
2098 trace add variable findstring write find_change
2099 set findtype [mc "Exact"]
2100 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2101 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2102 trace add variable findtype write findcom_change
2103 set findloc [mc "All fields"]
2104 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2105 [mc "Comments"] [mc "Author"] [mc "Committer"]
2106 trace add variable findloc write find_change
2107 pack .tf.lbar.findloc -side right
2108 pack .tf.lbar.findtype -side right
2109 pack $fstring -side left -expand 1 -fill x
2111 # Finish putting the upper half of the viewer together
2112 pack .tf.lbar -in .tf -side bottom -fill x
2113 pack .tf.bar -in .tf -side bottom -fill x
2114 pack .tf.histframe -fill both -side top -expand 1
2115 .ctop add .tf
2116 .ctop paneconfigure .tf -height $geometry(topheight)
2117 .ctop paneconfigure .tf -width $geometry(topwidth)
2119 # now build up the bottom
2120 panedwindow .pwbottom -orient horizontal
2122 # lower left, a text box over search bar, scroll bar to the right
2123 # if we know window height, then that will set the lower text height, otherwise
2124 # we set lower text height which will drive window height
2125 if {[info exists geometry(main)]} {
2126 frame .bleft -width $geometry(botwidth)
2127 } else {
2128 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2130 frame .bleft.top
2131 frame .bleft.mid
2132 frame .bleft.bottom
2134 button .bleft.top.search -text [mc "Search"] -command dosearch
2135 pack .bleft.top.search -side left -padx 5
2136 set sstring .bleft.top.sstring
2137 entry $sstring -width 20 -font textfont -textvariable searchstring
2138 lappend entries $sstring
2139 trace add variable searchstring write incrsearch
2140 pack $sstring -side left -expand 1 -fill x
2141 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2142 -command changediffdisp -variable diffelide -value {0 0}
2143 radiobutton .bleft.mid.old -text [mc "Old version"] \
2144 -command changediffdisp -variable diffelide -value {0 1}
2145 radiobutton .bleft.mid.new -text [mc "New version"] \
2146 -command changediffdisp -variable diffelide -value {1 0}
2147 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2148 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2149 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2150 -from 0 -increment 1 -to 10000000 \
2151 -validate all -validatecommand "diffcontextvalidate %P" \
2152 -textvariable diffcontextstring
2153 .bleft.mid.diffcontext set $diffcontext
2154 trace add variable diffcontextstring write diffcontextchange
2155 lappend entries .bleft.mid.diffcontext
2156 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2157 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2158 -command changeignorespace -variable ignorespace
2159 pack .bleft.mid.ignspace -side left -padx 5
2160 set ctext .bleft.bottom.ctext
2161 text $ctext -background $bgcolor -foreground $fgcolor \
2162 -state disabled -font textfont \
2163 -yscrollcommand scrolltext -wrap none \
2164 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2165 if {$have_tk85} {
2166 $ctext conf -tabstyle wordprocessor
2168 scrollbar .bleft.bottom.sb -command "$ctext yview"
2169 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2170 -width 10
2171 pack .bleft.top -side top -fill x
2172 pack .bleft.mid -side top -fill x
2173 grid $ctext .bleft.bottom.sb -sticky nsew
2174 grid .bleft.bottom.sbhorizontal -sticky ew
2175 grid columnconfigure .bleft.bottom 0 -weight 1
2176 grid rowconfigure .bleft.bottom 0 -weight 1
2177 grid rowconfigure .bleft.bottom 1 -weight 0
2178 pack .bleft.bottom -side top -fill both -expand 1
2179 lappend bglist $ctext
2180 lappend fglist $ctext
2182 $ctext tag conf comment -wrap $wrapcomment
2183 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2184 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2185 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2186 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2187 $ctext tag conf m0 -fore red
2188 $ctext tag conf m1 -fore blue
2189 $ctext tag conf m2 -fore green
2190 $ctext tag conf m3 -fore purple
2191 $ctext tag conf m4 -fore brown
2192 $ctext tag conf m5 -fore "#009090"
2193 $ctext tag conf m6 -fore magenta
2194 $ctext tag conf m7 -fore "#808000"
2195 $ctext tag conf m8 -fore "#009000"
2196 $ctext tag conf m9 -fore "#ff0080"
2197 $ctext tag conf m10 -fore cyan
2198 $ctext tag conf m11 -fore "#b07070"
2199 $ctext tag conf m12 -fore "#70b0f0"
2200 $ctext tag conf m13 -fore "#70f0b0"
2201 $ctext tag conf m14 -fore "#f0b070"
2202 $ctext tag conf m15 -fore "#ff70b0"
2203 $ctext tag conf mmax -fore darkgrey
2204 set mergemax 16
2205 $ctext tag conf mresult -font textfontbold
2206 $ctext tag conf msep -font textfontbold
2207 $ctext tag conf found -back yellow
2209 .pwbottom add .bleft
2210 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2212 # lower right
2213 frame .bright
2214 frame .bright.mode
2215 radiobutton .bright.mode.patch -text [mc "Patch"] \
2216 -command reselectline -variable cmitmode -value "patch"
2217 radiobutton .bright.mode.tree -text [mc "Tree"] \
2218 -command reselectline -variable cmitmode -value "tree"
2219 grid .bright.mode.patch .bright.mode.tree -sticky ew
2220 pack .bright.mode -side top -fill x
2221 set cflist .bright.cfiles
2222 set indent [font measure mainfont "nn"]
2223 text $cflist \
2224 -selectbackground $selectbgcolor \
2225 -background $bgcolor -foreground $fgcolor \
2226 -font mainfont \
2227 -tabs [list $indent [expr {2 * $indent}]] \
2228 -yscrollcommand ".bright.sb set" \
2229 -cursor [. cget -cursor] \
2230 -spacing1 1 -spacing3 1
2231 lappend bglist $cflist
2232 lappend fglist $cflist
2233 scrollbar .bright.sb -command "$cflist yview"
2234 pack .bright.sb -side right -fill y
2235 pack $cflist -side left -fill both -expand 1
2236 $cflist tag configure highlight \
2237 -background [$cflist cget -selectbackground]
2238 $cflist tag configure bold -font mainfontbold
2240 .pwbottom add .bright
2241 .ctop add .pwbottom
2243 # restore window width & height if known
2244 if {[info exists geometry(main)]} {
2245 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2246 if {$w > [winfo screenwidth .]} {
2247 set w [winfo screenwidth .]
2249 if {$h > [winfo screenheight .]} {
2250 set h [winfo screenheight .]
2252 wm geometry . "${w}x$h"
2256 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2257 wm state . $geometry(state)
2260 if {[tk windowingsystem] eq {aqua}} {
2261 set M1B M1
2262 set ::BM "3"
2263 } else {
2264 set M1B Control
2265 set ::BM "2"
2268 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2269 pack .ctop -fill both -expand 1
2270 bindall <1> {selcanvline %W %x %y}
2271 #bindall <B1-Motion> {selcanvline %W %x %y}
2272 if {[tk windowingsystem] == "win32"} {
2273 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2274 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2275 } else {
2276 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2277 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2278 if {[tk windowingsystem] eq "aqua"} {
2279 bindall <MouseWheel> {
2280 set delta [expr {- (%D)}]
2281 allcanvs yview scroll $delta units
2283 bindall <Shift-MouseWheel> {
2284 set delta [expr {- (%D)}]
2285 $canv xview scroll $delta units
2289 bindall <$::BM> "canvscan mark %W %x %y"
2290 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2291 bindkey <Home> selfirstline
2292 bindkey <End> sellastline
2293 bind . <Key-Up> "selnextline -1"
2294 bind . <Key-Down> "selnextline 1"
2295 bind . <Shift-Key-Up> "dofind -1 0"
2296 bind . <Shift-Key-Down> "dofind 1 0"
2297 bindkey <Key-Right> "goforw"
2298 bindkey <Key-Left> "goback"
2299 bind . <Key-Prior> "selnextpage -1"
2300 bind . <Key-Next> "selnextpage 1"
2301 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2302 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2303 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2304 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2305 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2306 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2307 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2308 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2309 bindkey <Key-space> "$ctext yview scroll 1 pages"
2310 bindkey p "selnextline -1"
2311 bindkey n "selnextline 1"
2312 bindkey z "goback"
2313 bindkey x "goforw"
2314 bindkey i "selnextline -1"
2315 bindkey k "selnextline 1"
2316 bindkey j "goback"
2317 bindkey l "goforw"
2318 bindkey b prevfile
2319 bindkey d "$ctext yview scroll 18 units"
2320 bindkey u "$ctext yview scroll -18 units"
2321 bindkey / {focus $fstring}
2322 bindkey <Key-KP_Divide> {focus $fstring}
2323 bindkey <Key-Return> {dofind 1 1}
2324 bindkey ? {dofind -1 1}
2325 bindkey f nextfile
2326 bind . <F5> updatecommits
2327 bind . <$M1B-F5> reloadcommits
2328 bind . <F2> showrefs
2329 bind . <Shift-F4> {newview 0}
2330 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2331 bind . <F4> edit_or_newview
2332 bind . <$M1B-q> doquit
2333 bind . <$M1B-f> {dofind 1 1}
2334 bind . <$M1B-g> {dofind 1 0}
2335 bind . <$M1B-r> dosearchback
2336 bind . <$M1B-s> dosearch
2337 bind . <$M1B-equal> {incrfont 1}
2338 bind . <$M1B-plus> {incrfont 1}
2339 bind . <$M1B-KP_Add> {incrfont 1}
2340 bind . <$M1B-minus> {incrfont -1}
2341 bind . <$M1B-KP_Subtract> {incrfont -1}
2342 wm protocol . WM_DELETE_WINDOW doquit
2343 bind . <Destroy> {stop_backends}
2344 bind . <Button-1> "click %W"
2345 bind $fstring <Key-Return> {dofind 1 1}
2346 bind $sha1entry <Key-Return> {gotocommit; break}
2347 bind $sha1entry <<PasteSelection>> clearsha1
2348 bind $cflist <1> {sel_flist %W %x %y; break}
2349 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2350 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2351 global ctxbut
2352 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2353 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2355 set maincursor [. cget -cursor]
2356 set textcursor [$ctext cget -cursor]
2357 set curtextcursor $textcursor
2359 set rowctxmenu .rowctxmenu
2360 makemenu $rowctxmenu {
2361 {mc "Diff this -> selected" command {diffvssel 0}}
2362 {mc "Diff selected -> this" command {diffvssel 1}}
2363 {mc "Make patch" command mkpatch}
2364 {mc "Create tag" command mktag}
2365 {mc "Write commit to file" command writecommit}
2366 {mc "Create new branch" command mkbranch}
2367 {mc "Cherry-pick this commit" command cherrypick}
2368 {mc "Reset HEAD branch to here" command resethead}
2369 {mc "Mark this commit" command markhere}
2370 {mc "Return to mark" command gotomark}
2371 {mc "Find descendant of this and mark" command find_common_desc}
2372 {mc "Compare with marked commit" command compare_commits}
2374 $rowctxmenu configure -tearoff 0
2376 set fakerowmenu .fakerowmenu
2377 makemenu $fakerowmenu {
2378 {mc "Diff this -> selected" command {diffvssel 0}}
2379 {mc "Diff selected -> this" command {diffvssel 1}}
2380 {mc "Make patch" command mkpatch}
2382 $fakerowmenu configure -tearoff 0
2384 set headctxmenu .headctxmenu
2385 makemenu $headctxmenu {
2386 {mc "Check out this branch" command cobranch}
2387 {mc "Remove this branch" command rmbranch}
2389 $headctxmenu configure -tearoff 0
2391 global flist_menu
2392 set flist_menu .flistctxmenu
2393 makemenu $flist_menu {
2394 {mc "Highlight this too" command {flist_hl 0}}
2395 {mc "Highlight this only" command {flist_hl 1}}
2396 {mc "External diff" command {external_diff}}
2397 {mc "Blame parent commit" command {external_blame 1}}
2399 $flist_menu configure -tearoff 0
2401 global diff_menu
2402 set diff_menu .diffctxmenu
2403 makemenu $diff_menu {
2404 {mc "Show origin of this line" command show_line_source}
2405 {mc "Run git gui blame on this line" command {external_blame_diff}}
2407 $diff_menu configure -tearoff 0
2410 # Windows sends all mouse wheel events to the current focused window, not
2411 # the one where the mouse hovers, so bind those events here and redirect
2412 # to the correct window
2413 proc windows_mousewheel_redirector {W X Y D} {
2414 global canv canv2 canv3
2415 set w [winfo containing -displayof $W $X $Y]
2416 if {$w ne ""} {
2417 set u [expr {$D < 0 ? 5 : -5}]
2418 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2419 allcanvs yview scroll $u units
2420 } else {
2421 catch {
2422 $w yview scroll $u units
2428 # Update row number label when selectedline changes
2429 proc selectedline_change {n1 n2 op} {
2430 global selectedline rownumsel
2432 if {$selectedline eq {}} {
2433 set rownumsel {}
2434 } else {
2435 set rownumsel [expr {$selectedline + 1}]
2439 # mouse-2 makes all windows scan vertically, but only the one
2440 # the cursor is in scans horizontally
2441 proc canvscan {op w x y} {
2442 global canv canv2 canv3
2443 foreach c [list $canv $canv2 $canv3] {
2444 if {$c == $w} {
2445 $c scan $op $x $y
2446 } else {
2447 $c scan $op 0 $y
2452 proc scrollcanv {cscroll f0 f1} {
2453 $cscroll set $f0 $f1
2454 drawvisible
2455 flushhighlights
2458 # when we make a key binding for the toplevel, make sure
2459 # it doesn't get triggered when that key is pressed in the
2460 # find string entry widget.
2461 proc bindkey {ev script} {
2462 global entries
2463 bind . $ev $script
2464 set escript [bind Entry $ev]
2465 if {$escript == {}} {
2466 set escript [bind Entry <Key>]
2468 foreach e $entries {
2469 bind $e $ev "$escript; break"
2473 # set the focus back to the toplevel for any click outside
2474 # the entry widgets
2475 proc click {w} {
2476 global ctext entries
2477 foreach e [concat $entries $ctext] {
2478 if {$w == $e} return
2480 focus .
2483 # Adjust the progress bar for a change in requested extent or canvas size
2484 proc adjustprogress {} {
2485 global progresscanv progressitem progresscoords
2486 global fprogitem fprogcoord lastprogupdate progupdatepending
2487 global rprogitem rprogcoord
2489 set w [expr {[winfo width $progresscanv] - 4}]
2490 set x0 [expr {$w * [lindex $progresscoords 0]}]
2491 set x1 [expr {$w * [lindex $progresscoords 1]}]
2492 set h [winfo height $progresscanv]
2493 $progresscanv coords $progressitem $x0 0 $x1 $h
2494 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2495 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2496 set now [clock clicks -milliseconds]
2497 if {$now >= $lastprogupdate + 100} {
2498 set progupdatepending 0
2499 update
2500 } elseif {!$progupdatepending} {
2501 set progupdatepending 1
2502 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2506 proc doprogupdate {} {
2507 global lastprogupdate progupdatepending
2509 if {$progupdatepending} {
2510 set progupdatepending 0
2511 set lastprogupdate [clock clicks -milliseconds]
2512 update
2516 proc savestuff {w} {
2517 global canv canv2 canv3 mainfont textfont uifont tabstop
2518 global stuffsaved findmergefiles maxgraphpct
2519 global maxwidth showneartags showlocalchanges
2520 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2521 global cmitmode wrapcomment datetimeformat limitdiffs
2522 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2523 global autoselect extdifftool perfile_attrs markbgcolor
2524 global hideremotes
2526 if {$stuffsaved} return
2527 if {![winfo viewable .]} return
2528 catch {
2529 set f [open "~/.gitk-new" w]
2530 if {$::tcl_platform(platform) eq {windows}} {
2531 file attributes "~/.gitk-new" -hidden true
2533 puts $f [list set mainfont $mainfont]
2534 puts $f [list set textfont $textfont]
2535 puts $f [list set uifont $uifont]
2536 puts $f [list set tabstop $tabstop]
2537 puts $f [list set findmergefiles $findmergefiles]
2538 puts $f [list set maxgraphpct $maxgraphpct]
2539 puts $f [list set maxwidth $maxwidth]
2540 puts $f [list set cmitmode $cmitmode]
2541 puts $f [list set wrapcomment $wrapcomment]
2542 puts $f [list set autoselect $autoselect]
2543 puts $f [list set showneartags $showneartags]
2544 puts $f [list set hideremotes $hideremotes]
2545 puts $f [list set showlocalchanges $showlocalchanges]
2546 puts $f [list set datetimeformat $datetimeformat]
2547 puts $f [list set limitdiffs $limitdiffs]
2548 puts $f [list set bgcolor $bgcolor]
2549 puts $f [list set fgcolor $fgcolor]
2550 puts $f [list set colors $colors]
2551 puts $f [list set diffcolors $diffcolors]
2552 puts $f [list set markbgcolor $markbgcolor]
2553 puts $f [list set diffcontext $diffcontext]
2554 puts $f [list set selectbgcolor $selectbgcolor]
2555 puts $f [list set extdifftool $extdifftool]
2556 puts $f [list set perfile_attrs $perfile_attrs]
2558 puts $f "set geometry(main) [wm geometry .]"
2559 puts $f "set geometry(state) [wm state .]"
2560 puts $f "set geometry(topwidth) [winfo width .tf]"
2561 puts $f "set geometry(topheight) [winfo height .tf]"
2562 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2563 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2564 puts $f "set geometry(botwidth) [winfo width .bleft]"
2565 puts $f "set geometry(botheight) [winfo height .bleft]"
2567 puts -nonewline $f "set permviews {"
2568 for {set v 0} {$v < $nextviewnum} {incr v} {
2569 if {$viewperm($v)} {
2570 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2573 puts $f "}"
2574 close $f
2575 file rename -force "~/.gitk-new" "~/.gitk"
2577 set stuffsaved 1
2580 proc resizeclistpanes {win w} {
2581 global oldwidth
2582 if {[info exists oldwidth($win)]} {
2583 set s0 [$win sash coord 0]
2584 set s1 [$win sash coord 1]
2585 if {$w < 60} {
2586 set sash0 [expr {int($w/2 - 2)}]
2587 set sash1 [expr {int($w*5/6 - 2)}]
2588 } else {
2589 set factor [expr {1.0 * $w / $oldwidth($win)}]
2590 set sash0 [expr {int($factor * [lindex $s0 0])}]
2591 set sash1 [expr {int($factor * [lindex $s1 0])}]
2592 if {$sash0 < 30} {
2593 set sash0 30
2595 if {$sash1 < $sash0 + 20} {
2596 set sash1 [expr {$sash0 + 20}]
2598 if {$sash1 > $w - 10} {
2599 set sash1 [expr {$w - 10}]
2600 if {$sash0 > $sash1 - 20} {
2601 set sash0 [expr {$sash1 - 20}]
2605 $win sash place 0 $sash0 [lindex $s0 1]
2606 $win sash place 1 $sash1 [lindex $s1 1]
2608 set oldwidth($win) $w
2611 proc resizecdetpanes {win w} {
2612 global oldwidth
2613 if {[info exists oldwidth($win)]} {
2614 set s0 [$win sash coord 0]
2615 if {$w < 60} {
2616 set sash0 [expr {int($w*3/4 - 2)}]
2617 } else {
2618 set factor [expr {1.0 * $w / $oldwidth($win)}]
2619 set sash0 [expr {int($factor * [lindex $s0 0])}]
2620 if {$sash0 < 45} {
2621 set sash0 45
2623 if {$sash0 > $w - 15} {
2624 set sash0 [expr {$w - 15}]
2627 $win sash place 0 $sash0 [lindex $s0 1]
2629 set oldwidth($win) $w
2632 proc allcanvs args {
2633 global canv canv2 canv3
2634 eval $canv $args
2635 eval $canv2 $args
2636 eval $canv3 $args
2639 proc bindall {event action} {
2640 global canv canv2 canv3
2641 bind $canv $event $action
2642 bind $canv2 $event $action
2643 bind $canv3 $event $action
2646 proc about {} {
2647 global uifont
2648 set w .about
2649 if {[winfo exists $w]} {
2650 raise $w
2651 return
2653 toplevel $w
2654 wm title $w [mc "About gitk"]
2655 make_transient $w .
2656 message $w.m -text [mc "
2657 Gitk - a commit viewer for git
2659 Copyright © 2005-2008 Paul Mackerras
2661 Use and redistribute under the terms of the GNU General Public License"] \
2662 -justify center -aspect 400 -border 2 -bg white -relief groove
2663 pack $w.m -side top -fill x -padx 2 -pady 2
2664 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2665 pack $w.ok -side bottom
2666 bind $w <Visibility> "focus $w.ok"
2667 bind $w <Key-Escape> "destroy $w"
2668 bind $w <Key-Return> "destroy $w"
2671 proc keys {} {
2672 set w .keys
2673 if {[winfo exists $w]} {
2674 raise $w
2675 return
2677 if {[tk windowingsystem] eq {aqua}} {
2678 set M1T Cmd
2679 } else {
2680 set M1T Ctrl
2682 toplevel $w
2683 wm title $w [mc "Gitk key bindings"]
2684 make_transient $w .
2685 message $w.m -text "
2686 [mc "Gitk key bindings:"]
2688 [mc "<%s-Q> Quit" $M1T]
2689 [mc "<Home> Move to first commit"]
2690 [mc "<End> Move to last commit"]
2691 [mc "<Up>, p, i Move up one commit"]
2692 [mc "<Down>, n, k Move down one commit"]
2693 [mc "<Left>, z, j Go back in history list"]
2694 [mc "<Right>, x, l Go forward in history list"]
2695 [mc "<PageUp> Move up one page in commit list"]
2696 [mc "<PageDown> Move down one page in commit list"]
2697 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2698 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2699 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2700 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2701 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2702 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2703 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2704 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2705 [mc "<Delete>, b Scroll diff view up one page"]
2706 [mc "<Backspace> Scroll diff view up one page"]
2707 [mc "<Space> Scroll diff view down one page"]
2708 [mc "u Scroll diff view up 18 lines"]
2709 [mc "d Scroll diff view down 18 lines"]
2710 [mc "<%s-F> Find" $M1T]
2711 [mc "<%s-G> Move to next find hit" $M1T]
2712 [mc "<Return> Move to next find hit"]
2713 [mc "/ Focus the search box"]
2714 [mc "? Move to previous find hit"]
2715 [mc "f Scroll diff view to next file"]
2716 [mc "<%s-S> Search for next hit in diff view" $M1T]
2717 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2718 [mc "<%s-KP+> Increase font size" $M1T]
2719 [mc "<%s-plus> Increase font size" $M1T]
2720 [mc "<%s-KP-> Decrease font size" $M1T]
2721 [mc "<%s-minus> Decrease font size" $M1T]
2722 [mc "<F5> Update"]
2724 -justify left -bg white -border 2 -relief groove
2725 pack $w.m -side top -fill both -padx 2 -pady 2
2726 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2727 bind $w <Key-Escape> [list destroy $w]
2728 pack $w.ok -side bottom
2729 bind $w <Visibility> "focus $w.ok"
2730 bind $w <Key-Escape> "destroy $w"
2731 bind $w <Key-Return> "destroy $w"
2734 # Procedures for manipulating the file list window at the
2735 # bottom right of the overall window.
2737 proc treeview {w l openlevs} {
2738 global treecontents treediropen treeheight treeparent treeindex
2740 set ix 0
2741 set treeindex() 0
2742 set lev 0
2743 set prefix {}
2744 set prefixend -1
2745 set prefendstack {}
2746 set htstack {}
2747 set ht 0
2748 set treecontents() {}
2749 $w conf -state normal
2750 foreach f $l {
2751 while {[string range $f 0 $prefixend] ne $prefix} {
2752 if {$lev <= $openlevs} {
2753 $w mark set e:$treeindex($prefix) "end -1c"
2754 $w mark gravity e:$treeindex($prefix) left
2756 set treeheight($prefix) $ht
2757 incr ht [lindex $htstack end]
2758 set htstack [lreplace $htstack end end]
2759 set prefixend [lindex $prefendstack end]
2760 set prefendstack [lreplace $prefendstack end end]
2761 set prefix [string range $prefix 0 $prefixend]
2762 incr lev -1
2764 set tail [string range $f [expr {$prefixend+1}] end]
2765 while {[set slash [string first "/" $tail]] >= 0} {
2766 lappend htstack $ht
2767 set ht 0
2768 lappend prefendstack $prefixend
2769 incr prefixend [expr {$slash + 1}]
2770 set d [string range $tail 0 $slash]
2771 lappend treecontents($prefix) $d
2772 set oldprefix $prefix
2773 append prefix $d
2774 set treecontents($prefix) {}
2775 set treeindex($prefix) [incr ix]
2776 set treeparent($prefix) $oldprefix
2777 set tail [string range $tail [expr {$slash+1}] end]
2778 if {$lev <= $openlevs} {
2779 set ht 1
2780 set treediropen($prefix) [expr {$lev < $openlevs}]
2781 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2782 $w mark set d:$ix "end -1c"
2783 $w mark gravity d:$ix left
2784 set str "\n"
2785 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2786 $w insert end $str
2787 $w image create end -align center -image $bm -padx 1 \
2788 -name a:$ix
2789 $w insert end $d [highlight_tag $prefix]
2790 $w mark set s:$ix "end -1c"
2791 $w mark gravity s:$ix left
2793 incr lev
2795 if {$tail ne {}} {
2796 if {$lev <= $openlevs} {
2797 incr ht
2798 set str "\n"
2799 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2800 $w insert end $str
2801 $w insert end $tail [highlight_tag $f]
2803 lappend treecontents($prefix) $tail
2806 while {$htstack ne {}} {
2807 set treeheight($prefix) $ht
2808 incr ht [lindex $htstack end]
2809 set htstack [lreplace $htstack end end]
2810 set prefixend [lindex $prefendstack end]
2811 set prefendstack [lreplace $prefendstack end end]
2812 set prefix [string range $prefix 0 $prefixend]
2814 $w conf -state disabled
2817 proc linetoelt {l} {
2818 global treeheight treecontents
2820 set y 2
2821 set prefix {}
2822 while {1} {
2823 foreach e $treecontents($prefix) {
2824 if {$y == $l} {
2825 return "$prefix$e"
2827 set n 1
2828 if {[string index $e end] eq "/"} {
2829 set n $treeheight($prefix$e)
2830 if {$y + $n > $l} {
2831 append prefix $e
2832 incr y
2833 break
2836 incr y $n
2841 proc highlight_tree {y prefix} {
2842 global treeheight treecontents cflist
2844 foreach e $treecontents($prefix) {
2845 set path $prefix$e
2846 if {[highlight_tag $path] ne {}} {
2847 $cflist tag add bold $y.0 "$y.0 lineend"
2849 incr y
2850 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2851 set y [highlight_tree $y $path]
2854 return $y
2857 proc treeclosedir {w dir} {
2858 global treediropen treeheight treeparent treeindex
2860 set ix $treeindex($dir)
2861 $w conf -state normal
2862 $w delete s:$ix e:$ix
2863 set treediropen($dir) 0
2864 $w image configure a:$ix -image tri-rt
2865 $w conf -state disabled
2866 set n [expr {1 - $treeheight($dir)}]
2867 while {$dir ne {}} {
2868 incr treeheight($dir) $n
2869 set dir $treeparent($dir)
2873 proc treeopendir {w dir} {
2874 global treediropen treeheight treeparent treecontents treeindex
2876 set ix $treeindex($dir)
2877 $w conf -state normal
2878 $w image configure a:$ix -image tri-dn
2879 $w mark set e:$ix s:$ix
2880 $w mark gravity e:$ix right
2881 set lev 0
2882 set str "\n"
2883 set n [llength $treecontents($dir)]
2884 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2885 incr lev
2886 append str "\t"
2887 incr treeheight($x) $n
2889 foreach e $treecontents($dir) {
2890 set de $dir$e
2891 if {[string index $e end] eq "/"} {
2892 set iy $treeindex($de)
2893 $w mark set d:$iy e:$ix
2894 $w mark gravity d:$iy left
2895 $w insert e:$ix $str
2896 set treediropen($de) 0
2897 $w image create e:$ix -align center -image tri-rt -padx 1 \
2898 -name a:$iy
2899 $w insert e:$ix $e [highlight_tag $de]
2900 $w mark set s:$iy e:$ix
2901 $w mark gravity s:$iy left
2902 set treeheight($de) 1
2903 } else {
2904 $w insert e:$ix $str
2905 $w insert e:$ix $e [highlight_tag $de]
2908 $w mark gravity e:$ix right
2909 $w conf -state disabled
2910 set treediropen($dir) 1
2911 set top [lindex [split [$w index @0,0] .] 0]
2912 set ht [$w cget -height]
2913 set l [lindex [split [$w index s:$ix] .] 0]
2914 if {$l < $top} {
2915 $w yview $l.0
2916 } elseif {$l + $n + 1 > $top + $ht} {
2917 set top [expr {$l + $n + 2 - $ht}]
2918 if {$l < $top} {
2919 set top $l
2921 $w yview $top.0
2925 proc treeclick {w x y} {
2926 global treediropen cmitmode ctext cflist cflist_top
2928 if {$cmitmode ne "tree"} return
2929 if {![info exists cflist_top]} return
2930 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2931 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2932 $cflist tag add highlight $l.0 "$l.0 lineend"
2933 set cflist_top $l
2934 if {$l == 1} {
2935 $ctext yview 1.0
2936 return
2938 set e [linetoelt $l]
2939 if {[string index $e end] ne "/"} {
2940 showfile $e
2941 } elseif {$treediropen($e)} {
2942 treeclosedir $w $e
2943 } else {
2944 treeopendir $w $e
2948 proc setfilelist {id} {
2949 global treefilelist cflist jump_to_here
2951 treeview $cflist $treefilelist($id) 0
2952 if {$jump_to_here ne {}} {
2953 set f [lindex $jump_to_here 0]
2954 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2955 showfile $f
2960 image create bitmap tri-rt -background black -foreground blue -data {
2961 #define tri-rt_width 13
2962 #define tri-rt_height 13
2963 static unsigned char tri-rt_bits[] = {
2964 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2965 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2966 0x00, 0x00};
2967 } -maskdata {
2968 #define tri-rt-mask_width 13
2969 #define tri-rt-mask_height 13
2970 static unsigned char tri-rt-mask_bits[] = {
2971 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2972 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2973 0x08, 0x00};
2975 image create bitmap tri-dn -background black -foreground blue -data {
2976 #define tri-dn_width 13
2977 #define tri-dn_height 13
2978 static unsigned char tri-dn_bits[] = {
2979 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2980 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2981 0x00, 0x00};
2982 } -maskdata {
2983 #define tri-dn-mask_width 13
2984 #define tri-dn-mask_height 13
2985 static unsigned char tri-dn-mask_bits[] = {
2986 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2987 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2988 0x00, 0x00};
2991 image create bitmap reficon-T -background black -foreground yellow -data {
2992 #define tagicon_width 13
2993 #define tagicon_height 9
2994 static unsigned char tagicon_bits[] = {
2995 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2996 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2997 } -maskdata {
2998 #define tagicon-mask_width 13
2999 #define tagicon-mask_height 9
3000 static unsigned char tagicon-mask_bits[] = {
3001 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3002 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3004 set rectdata {
3005 #define headicon_width 13
3006 #define headicon_height 9
3007 static unsigned char headicon_bits[] = {
3008 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3009 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3011 set rectmask {
3012 #define headicon-mask_width 13
3013 #define headicon-mask_height 9
3014 static unsigned char headicon-mask_bits[] = {
3015 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3016 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3018 image create bitmap reficon-H -background black -foreground green \
3019 -data $rectdata -maskdata $rectmask
3020 image create bitmap reficon-o -background black -foreground "#ddddff" \
3021 -data $rectdata -maskdata $rectmask
3023 proc init_flist {first} {
3024 global cflist cflist_top difffilestart
3026 $cflist conf -state normal
3027 $cflist delete 0.0 end
3028 if {$first ne {}} {
3029 $cflist insert end $first
3030 set cflist_top 1
3031 $cflist tag add highlight 1.0 "1.0 lineend"
3032 } else {
3033 catch {unset cflist_top}
3035 $cflist conf -state disabled
3036 set difffilestart {}
3039 proc highlight_tag {f} {
3040 global highlight_paths
3042 foreach p $highlight_paths {
3043 if {[string match $p $f]} {
3044 return "bold"
3047 return {}
3050 proc highlight_filelist {} {
3051 global cmitmode cflist
3053 $cflist conf -state normal
3054 if {$cmitmode ne "tree"} {
3055 set end [lindex [split [$cflist index end] .] 0]
3056 for {set l 2} {$l < $end} {incr l} {
3057 set line [$cflist get $l.0 "$l.0 lineend"]
3058 if {[highlight_tag $line] ne {}} {
3059 $cflist tag add bold $l.0 "$l.0 lineend"
3062 } else {
3063 highlight_tree 2 {}
3065 $cflist conf -state disabled
3068 proc unhighlight_filelist {} {
3069 global cflist
3071 $cflist conf -state normal
3072 $cflist tag remove bold 1.0 end
3073 $cflist conf -state disabled
3076 proc add_flist {fl} {
3077 global cflist
3079 $cflist conf -state normal
3080 foreach f $fl {
3081 $cflist insert end "\n"
3082 $cflist insert end $f [highlight_tag $f]
3084 $cflist conf -state disabled
3087 proc sel_flist {w x y} {
3088 global ctext difffilestart cflist cflist_top cmitmode
3090 if {$cmitmode eq "tree"} return
3091 if {![info exists cflist_top]} return
3092 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3093 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3094 $cflist tag add highlight $l.0 "$l.0 lineend"
3095 set cflist_top $l
3096 if {$l == 1} {
3097 $ctext yview 1.0
3098 } else {
3099 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3103 proc pop_flist_menu {w X Y x y} {
3104 global ctext cflist cmitmode flist_menu flist_menu_file
3105 global treediffs diffids
3107 stopfinding
3108 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3109 if {$l <= 1} return
3110 if {$cmitmode eq "tree"} {
3111 set e [linetoelt $l]
3112 if {[string index $e end] eq "/"} return
3113 } else {
3114 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3116 set flist_menu_file $e
3117 set xdiffstate "normal"
3118 if {$cmitmode eq "tree"} {
3119 set xdiffstate "disabled"
3121 # Disable "External diff" item in tree mode
3122 $flist_menu entryconf 2 -state $xdiffstate
3123 tk_popup $flist_menu $X $Y
3126 proc find_ctext_fileinfo {line} {
3127 global ctext_file_names ctext_file_lines
3129 set ok [bsearch $ctext_file_lines $line]
3130 set tline [lindex $ctext_file_lines $ok]
3132 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3133 return {}
3134 } else {
3135 return [list [lindex $ctext_file_names $ok] $tline]
3139 proc pop_diff_menu {w X Y x y} {
3140 global ctext diff_menu flist_menu_file
3141 global diff_menu_txtpos diff_menu_line
3142 global diff_menu_filebase
3144 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3145 set diff_menu_line [lindex $diff_menu_txtpos 0]
3146 # don't pop up the menu on hunk-separator or file-separator lines
3147 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3148 return
3150 stopfinding
3151 set f [find_ctext_fileinfo $diff_menu_line]
3152 if {$f eq {}} return
3153 set flist_menu_file [lindex $f 0]
3154 set diff_menu_filebase [lindex $f 1]
3155 tk_popup $diff_menu $X $Y
3158 proc flist_hl {only} {
3159 global flist_menu_file findstring gdttype
3161 set x [shellquote $flist_menu_file]
3162 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3163 set findstring $x
3164 } else {
3165 append findstring " " $x
3167 set gdttype [mc "touching paths:"]
3170 proc save_file_from_commit {filename output what} {
3171 global nullfile
3173 if {[catch {exec git show $filename -- > $output} err]} {
3174 if {[string match "fatal: bad revision *" $err]} {
3175 return $nullfile
3177 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3178 return {}
3180 return $output
3183 proc external_diff_get_one_file {diffid filename diffdir} {
3184 global nullid nullid2 nullfile
3185 global gitdir
3187 if {$diffid == $nullid} {
3188 set difffile [file join [file dirname $gitdir] $filename]
3189 if {[file exists $difffile]} {
3190 return $difffile
3192 return $nullfile
3194 if {$diffid == $nullid2} {
3195 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3196 return [save_file_from_commit :$filename $difffile index]
3198 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3199 return [save_file_from_commit $diffid:$filename $difffile \
3200 "revision $diffid"]
3203 proc external_diff {} {
3204 global gitktmpdir nullid nullid2
3205 global flist_menu_file
3206 global diffids
3207 global diffnum
3208 global gitdir extdifftool
3210 if {[llength $diffids] == 1} {
3211 # no reference commit given
3212 set diffidto [lindex $diffids 0]
3213 if {$diffidto eq $nullid} {
3214 # diffing working copy with index
3215 set diffidfrom $nullid2
3216 } elseif {$diffidto eq $nullid2} {
3217 # diffing index with HEAD
3218 set diffidfrom "HEAD"
3219 } else {
3220 # use first parent commit
3221 global parentlist selectedline
3222 set diffidfrom [lindex $parentlist $selectedline 0]
3224 } else {
3225 set diffidfrom [lindex $diffids 0]
3226 set diffidto [lindex $diffids 1]
3229 # make sure that several diffs wont collide
3230 if {![info exists gitktmpdir]} {
3231 set gitktmpdir [file join [file dirname $gitdir] \
3232 [format ".gitk-tmp.%s" [pid]]]
3233 if {[catch {file mkdir $gitktmpdir} err]} {
3234 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3235 unset gitktmpdir
3236 return
3238 set diffnum 0
3240 incr diffnum
3241 set diffdir [file join $gitktmpdir $diffnum]
3242 if {[catch {file mkdir $diffdir} err]} {
3243 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3244 return
3247 # gather files to diff
3248 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3249 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3251 if {$difffromfile ne {} && $difftofile ne {}} {
3252 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3253 if {[catch {set fl [open |$cmd r]} err]} {
3254 file delete -force $diffdir
3255 error_popup "$extdifftool: [mc "command failed:"] $err"
3256 } else {
3257 fconfigure $fl -blocking 0
3258 filerun $fl [list delete_at_eof $fl $diffdir]
3263 proc find_hunk_blamespec {base line} {
3264 global ctext
3266 # Find and parse the hunk header
3267 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3268 if {$s_lix eq {}} return
3270 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3271 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3272 s_line old_specs osz osz1 new_line nsz]} {
3273 return
3276 # base lines for the parents
3277 set base_lines [list $new_line]
3278 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3279 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3280 old_spec old_line osz]} {
3281 return
3283 lappend base_lines $old_line
3286 # Now scan the lines to determine offset within the hunk
3287 set max_parent [expr {[llength $base_lines]-2}]
3288 set dline 0
3289 set s_lno [lindex [split $s_lix "."] 0]
3291 # Determine if the line is removed
3292 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3293 if {[string match {[-+ ]*} $chunk]} {
3294 set removed_idx [string first "-" $chunk]
3295 # Choose a parent index
3296 if {$removed_idx >= 0} {
3297 set parent $removed_idx
3298 } else {
3299 set unchanged_idx [string first " " $chunk]
3300 if {$unchanged_idx >= 0} {
3301 set parent $unchanged_idx
3302 } else {
3303 # blame the current commit
3304 set parent -1
3307 # then count other lines that belong to it
3308 for {set i $line} {[incr i -1] > $s_lno} {} {
3309 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3310 # Determine if the line is removed
3311 set removed_idx [string first "-" $chunk]
3312 if {$parent >= 0} {
3313 set code [string index $chunk $parent]
3314 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3315 incr dline
3317 } else {
3318 if {$removed_idx < 0} {
3319 incr dline
3323 incr parent
3324 } else {
3325 set parent 0
3328 incr dline [lindex $base_lines $parent]
3329 return [list $parent $dline]
3332 proc external_blame_diff {} {
3333 global currentid cmitmode
3334 global diff_menu_txtpos diff_menu_line
3335 global diff_menu_filebase flist_menu_file
3337 if {$cmitmode eq "tree"} {
3338 set parent_idx 0
3339 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3340 } else {
3341 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3342 if {$hinfo ne {}} {
3343 set parent_idx [lindex $hinfo 0]
3344 set line [lindex $hinfo 1]
3345 } else {
3346 set parent_idx 0
3347 set line 0
3351 external_blame $parent_idx $line
3354 # Find the SHA1 ID of the blob for file $fname in the index
3355 # at stage 0 or 2
3356 proc index_sha1 {fname} {
3357 set f [open [list | git ls-files -s $fname] r]
3358 while {[gets $f line] >= 0} {
3359 set info [lindex [split $line "\t"] 0]
3360 set stage [lindex $info 2]
3361 if {$stage eq "0" || $stage eq "2"} {
3362 close $f
3363 return [lindex $info 1]
3366 close $f
3367 return {}
3370 # Turn an absolute path into one relative to the current directory
3371 proc make_relative {f} {
3372 set elts [file split $f]
3373 set here [file split [pwd]]
3374 set ei 0
3375 set hi 0
3376 set res {}
3377 foreach d $here {
3378 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3379 lappend res ".."
3380 } else {
3381 incr ei
3383 incr hi
3385 set elts [concat $res [lrange $elts $ei end]]
3386 return [eval file join $elts]
3389 proc external_blame {parent_idx {line {}}} {
3390 global flist_menu_file gitdir
3391 global nullid nullid2
3392 global parentlist selectedline currentid
3394 if {$parent_idx > 0} {
3395 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3396 } else {
3397 set base_commit $currentid
3400 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3401 error_popup [mc "No such commit"]
3402 return
3405 set cmdline [list git gui blame]
3406 if {$line ne {} && $line > 1} {
3407 lappend cmdline "--line=$line"
3409 set f [file join [file dirname $gitdir] $flist_menu_file]
3410 # Unfortunately it seems git gui blame doesn't like
3411 # being given an absolute path...
3412 set f [make_relative $f]
3413 lappend cmdline $base_commit $f
3414 if {[catch {eval exec $cmdline &} err]} {
3415 error_popup "[mc "git gui blame: command failed:"] $err"
3419 proc show_line_source {} {
3420 global cmitmode currentid parents curview blamestuff blameinst
3421 global diff_menu_line diff_menu_filebase flist_menu_file
3422 global nullid nullid2 gitdir
3424 set from_index {}
3425 if {$cmitmode eq "tree"} {
3426 set id $currentid
3427 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3428 } else {
3429 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3430 if {$h eq {}} return
3431 set pi [lindex $h 0]
3432 if {$pi == 0} {
3433 mark_ctext_line $diff_menu_line
3434 return
3436 incr pi -1
3437 if {$currentid eq $nullid} {
3438 if {$pi > 0} {
3439 # must be a merge in progress...
3440 if {[catch {
3441 # get the last line from .git/MERGE_HEAD
3442 set f [open [file join $gitdir MERGE_HEAD] r]
3443 set id [lindex [split [read $f] "\n"] end-1]
3444 close $f
3445 } err]} {
3446 error_popup [mc "Couldn't read merge head: %s" $err]
3447 return
3449 } elseif {$parents($curview,$currentid) eq $nullid2} {
3450 # need to do the blame from the index
3451 if {[catch {
3452 set from_index [index_sha1 $flist_menu_file]
3453 } err]} {
3454 error_popup [mc "Error reading index: %s" $err]
3455 return
3457 } else {
3458 set id $parents($curview,$currentid)
3460 } else {
3461 set id [lindex $parents($curview,$currentid) $pi]
3463 set line [lindex $h 1]
3465 set blameargs {}
3466 if {$from_index ne {}} {
3467 lappend blameargs | git cat-file blob $from_index
3469 lappend blameargs | git blame -p -L$line,+1
3470 if {$from_index ne {}} {
3471 lappend blameargs --contents -
3472 } else {
3473 lappend blameargs $id
3475 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3476 if {[catch {
3477 set f [open $blameargs r]
3478 } err]} {
3479 error_popup [mc "Couldn't start git blame: %s" $err]
3480 return
3482 nowbusy blaming [mc "Searching"]
3483 fconfigure $f -blocking 0
3484 set i [reg_instance $f]
3485 set blamestuff($i) {}
3486 set blameinst $i
3487 filerun $f [list read_line_source $f $i]
3490 proc stopblaming {} {
3491 global blameinst
3493 if {[info exists blameinst]} {
3494 stop_instance $blameinst
3495 unset blameinst
3496 notbusy blaming
3500 proc read_line_source {fd inst} {
3501 global blamestuff curview commfd blameinst nullid nullid2
3503 while {[gets $fd line] >= 0} {
3504 lappend blamestuff($inst) $line
3506 if {![eof $fd]} {
3507 return 1
3509 unset commfd($inst)
3510 unset blameinst
3511 notbusy blaming
3512 fconfigure $fd -blocking 1
3513 if {[catch {close $fd} err]} {
3514 error_popup [mc "Error running git blame: %s" $err]
3515 return 0
3518 set fname {}
3519 set line [split [lindex $blamestuff($inst) 0] " "]
3520 set id [lindex $line 0]
3521 set lnum [lindex $line 1]
3522 if {[string length $id] == 40 && [string is xdigit $id] &&
3523 [string is digit -strict $lnum]} {
3524 # look for "filename" line
3525 foreach l $blamestuff($inst) {
3526 if {[string match "filename *" $l]} {
3527 set fname [string range $l 9 end]
3528 break
3532 if {$fname ne {}} {
3533 # all looks good, select it
3534 if {$id eq $nullid} {
3535 # blame uses all-zeroes to mean not committed,
3536 # which would mean a change in the index
3537 set id $nullid2
3539 if {[commitinview $id $curview]} {
3540 selectline [rowofcommit $id] 1 [list $fname $lnum]
3541 } else {
3542 error_popup [mc "That line comes from commit %s, \
3543 which is not in this view" [shortids $id]]
3545 } else {
3546 puts "oops couldn't parse git blame output"
3548 return 0
3551 # delete $dir when we see eof on $f (presumably because the child has exited)
3552 proc delete_at_eof {f dir} {
3553 while {[gets $f line] >= 0} {}
3554 if {[eof $f]} {
3555 if {[catch {close $f} err]} {
3556 error_popup "[mc "External diff viewer failed:"] $err"
3558 file delete -force $dir
3559 return 0
3561 return 1
3564 # Functions for adding and removing shell-type quoting
3566 proc shellquote {str} {
3567 if {![string match "*\['\"\\ \t]*" $str]} {
3568 return $str
3570 if {![string match "*\['\"\\]*" $str]} {
3571 return "\"$str\""
3573 if {![string match "*'*" $str]} {
3574 return "'$str'"
3576 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3579 proc shellarglist {l} {
3580 set str {}
3581 foreach a $l {
3582 if {$str ne {}} {
3583 append str " "
3585 append str [shellquote $a]
3587 return $str
3590 proc shelldequote {str} {
3591 set ret {}
3592 set used -1
3593 while {1} {
3594 incr used
3595 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3596 append ret [string range $str $used end]
3597 set used [string length $str]
3598 break
3600 set first [lindex $first 0]
3601 set ch [string index $str $first]
3602 if {$first > $used} {
3603 append ret [string range $str $used [expr {$first - 1}]]
3604 set used $first
3606 if {$ch eq " " || $ch eq "\t"} break
3607 incr used
3608 if {$ch eq "'"} {
3609 set first [string first "'" $str $used]
3610 if {$first < 0} {
3611 error "unmatched single-quote"
3613 append ret [string range $str $used [expr {$first - 1}]]
3614 set used $first
3615 continue
3617 if {$ch eq "\\"} {
3618 if {$used >= [string length $str]} {
3619 error "trailing backslash"
3621 append ret [string index $str $used]
3622 continue
3624 # here ch == "\""
3625 while {1} {
3626 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3627 error "unmatched double-quote"
3629 set first [lindex $first 0]
3630 set ch [string index $str $first]
3631 if {$first > $used} {
3632 append ret [string range $str $used [expr {$first - 1}]]
3633 set used $first
3635 if {$ch eq "\""} break
3636 incr used
3637 append ret [string index $str $used]
3638 incr used
3641 return [list $used $ret]
3644 proc shellsplit {str} {
3645 set l {}
3646 while {1} {
3647 set str [string trimleft $str]
3648 if {$str eq {}} break
3649 set dq [shelldequote $str]
3650 set n [lindex $dq 0]
3651 set word [lindex $dq 1]
3652 set str [string range $str $n end]
3653 lappend l $word
3655 return $l
3658 # Code to implement multiple views
3660 proc newview {ishighlight} {
3661 global nextviewnum newviewname newishighlight
3662 global revtreeargs viewargscmd newviewopts curview
3664 set newishighlight $ishighlight
3665 set top .gitkview
3666 if {[winfo exists $top]} {
3667 raise $top
3668 return
3670 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3671 set newviewopts($nextviewnum,perm) 0
3672 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3673 decode_view_opts $nextviewnum $revtreeargs
3674 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3677 set known_view_options {
3678 {perm b . {} {mc "Remember this view"}}
3679 {reflabel l + {} {mc "References (space separated list):"}}
3680 {refs t15 .. {} {mc "Branches & tags:"}}
3681 {allrefs b *. "--all" {mc "All refs"}}
3682 {branches b . "--branches" {mc "All (local) branches"}}
3683 {tags b . "--tags" {mc "All tags"}}
3684 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3685 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3686 {author t15 .. "--author=*" {mc "Author:"}}
3687 {committer t15 . "--committer=*" {mc "Committer:"}}
3688 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3689 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3690 {changes_l l + {} {mc "Changes to Files:"}}
3691 {pickaxe_s r0 . {} {mc "Fixed String"}}
3692 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3693 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3694 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3695 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3696 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3697 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3698 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3699 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3700 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3701 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3702 {lright b . "--left-right" {mc "Mark branch sides"}}
3703 {first b . "--first-parent" {mc "Limit to first parent"}}
3704 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3705 {args t50 *. {} {mc "Additional arguments to git log:"}}
3706 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3707 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3710 proc encode_view_opts {n} {
3711 global known_view_options newviewopts
3713 set rargs [list]
3714 foreach opt $known_view_options {
3715 set patterns [lindex $opt 3]
3716 if {$patterns eq {}} continue
3717 set pattern [lindex $patterns 0]
3719 if {[lindex $opt 1] eq "b"} {
3720 set val $newviewopts($n,[lindex $opt 0])
3721 if {$val} {
3722 lappend rargs $pattern
3724 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3725 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3726 set val $newviewopts($n,$button_id)
3727 if {$val eq $value} {
3728 lappend rargs $pattern
3730 } else {
3731 set val $newviewopts($n,[lindex $opt 0])
3732 set val [string trim $val]
3733 if {$val ne {}} {
3734 set pfix [string range $pattern 0 end-1]
3735 lappend rargs $pfix$val
3739 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3740 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3743 proc decode_view_opts {n view_args} {
3744 global known_view_options newviewopts
3746 foreach opt $known_view_options {
3747 set id [lindex $opt 0]
3748 if {[lindex $opt 1] eq "b"} {
3749 # Checkboxes
3750 set val 0
3751 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3752 # Radiobuttons
3753 regexp {^(.*_)} $id uselessvar id
3754 set val 0
3755 } else {
3756 # Text fields
3757 set val {}
3759 set newviewopts($n,$id) $val
3761 set oargs [list]
3762 set refargs [list]
3763 foreach arg $view_args {
3764 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3765 && ![info exists found(limit)]} {
3766 set newviewopts($n,limit) $cnt
3767 set found(limit) 1
3768 continue
3770 catch { unset val }
3771 foreach opt $known_view_options {
3772 set id [lindex $opt 0]
3773 if {[info exists found($id)]} continue
3774 foreach pattern [lindex $opt 3] {
3775 if {![string match $pattern $arg]} continue
3776 if {[lindex $opt 1] eq "b"} {
3777 # Check buttons
3778 set val 1
3779 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3780 # Radio buttons
3781 regexp {^(.*_)} $id uselessvar id
3782 set val $num
3783 } else {
3784 # Text input fields
3785 set size [string length $pattern]
3786 set val [string range $arg [expr {$size-1}] end]
3788 set newviewopts($n,$id) $val
3789 set found($id) 1
3790 break
3792 if {[info exists val]} break
3794 if {[info exists val]} continue
3795 if {[regexp {^-} $arg]} {
3796 lappend oargs $arg
3797 } else {
3798 lappend refargs $arg
3801 set newviewopts($n,refs) [shellarglist $refargs]
3802 set newviewopts($n,args) [shellarglist $oargs]
3805 proc edit_or_newview {} {
3806 global curview
3808 if {$curview > 0} {
3809 editview
3810 } else {
3811 newview 0
3815 proc editview {} {
3816 global curview
3817 global viewname viewperm newviewname newviewopts
3818 global viewargs viewargscmd
3820 set top .gitkvedit-$curview
3821 if {[winfo exists $top]} {
3822 raise $top
3823 return
3825 set newviewname($curview) $viewname($curview)
3826 set newviewopts($curview,perm) $viewperm($curview)
3827 set newviewopts($curview,cmd) $viewargscmd($curview)
3828 decode_view_opts $curview $viewargs($curview)
3829 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3832 proc vieweditor {top n title} {
3833 global newviewname newviewopts viewfiles bgcolor
3834 global known_view_options
3836 toplevel $top
3837 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3838 make_transient $top .
3840 # View name
3841 frame $top.nfr
3842 label $top.nl -text [mc "View Name:"]
3843 entry $top.name -width 20 -textvariable newviewname($n)
3844 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3845 pack $top.nl -in $top.nfr -side left -padx {0 5}
3846 pack $top.name -in $top.nfr -side left -padx {0 25}
3848 # View options
3849 set cframe $top.nfr
3850 set cexpand 0
3851 set cnt 0
3852 foreach opt $known_view_options {
3853 set id [lindex $opt 0]
3854 set type [lindex $opt 1]
3855 set flags [lindex $opt 2]
3856 set title [eval [lindex $opt 4]]
3857 set lxpad 0
3859 if {$flags eq "+" || $flags eq "*"} {
3860 set cframe $top.fr$cnt
3861 incr cnt
3862 frame $cframe
3863 pack $cframe -in $top -fill x -pady 3 -padx 3
3864 set cexpand [expr {$flags eq "*"}]
3865 } elseif {$flags eq ".." || $flags eq "*."} {
3866 set cframe $top.fr$cnt
3867 incr cnt
3868 frame $cframe
3869 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
3870 set cexpand [expr {$flags eq "*."}]
3871 } else {
3872 set lxpad 5
3875 if {$type eq "l"} {
3876 label $cframe.l_$id -text $title
3877 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
3878 } elseif {$type eq "b"} {
3879 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3880 pack $cframe.c_$id -in $cframe -side left \
3881 -padx [list $lxpad 0] -expand $cexpand -anchor w
3882 } elseif {[regexp {^r(\d+)$} $type type sz]} {
3883 regexp {^(.*_)} $id uselessvar button_id
3884 radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
3885 pack $cframe.c_$id -in $cframe -side left \
3886 -padx [list $lxpad 0] -expand $cexpand -anchor w
3887 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3888 message $cframe.l_$id -aspect 1500 -text $title
3889 entry $cframe.e_$id -width $sz -background $bgcolor \
3890 -textvariable newviewopts($n,$id)
3891 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3892 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3893 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3894 message $cframe.l_$id -aspect 1500 -text $title
3895 entry $cframe.e_$id -width $sz -background $bgcolor \
3896 -textvariable newviewopts($n,$id)
3897 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3898 pack $cframe.e_$id -in $cframe -side top -fill x
3899 } elseif {$type eq "path"} {
3900 message $top.l -aspect 1500 -text $title
3901 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
3902 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3903 if {[info exists viewfiles($n)]} {
3904 foreach f $viewfiles($n) {
3905 $top.t insert end $f
3906 $top.t insert end "\n"
3908 $top.t delete {end - 1c} end
3909 $top.t mark set insert 0.0
3911 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3915 frame $top.buts
3916 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3917 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3918 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3919 bind $top <Control-Return> [list newviewok $top $n]
3920 bind $top <F5> [list newviewok $top $n 1]
3921 bind $top <Escape> [list destroy $top]
3922 grid $top.buts.ok $top.buts.apply $top.buts.can
3923 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3924 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3925 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3926 pack $top.buts -in $top -side top -fill x
3927 focus $top.t
3930 proc doviewmenu {m first cmd op argv} {
3931 set nmenu [$m index end]
3932 for {set i $first} {$i <= $nmenu} {incr i} {
3933 if {[$m entrycget $i -command] eq $cmd} {
3934 eval $m $op $i $argv
3935 break
3940 proc allviewmenus {n op args} {
3941 # global viewhlmenu
3943 doviewmenu .bar.view 5 [list showview $n] $op $args
3944 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3947 proc newviewok {top n {apply 0}} {
3948 global nextviewnum newviewperm newviewname newishighlight
3949 global viewname viewfiles viewperm selectedview curview
3950 global viewargs viewargscmd newviewopts viewhlmenu
3952 if {[catch {
3953 set newargs [encode_view_opts $n]
3954 } err]} {
3955 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3956 return
3958 set files {}
3959 foreach f [split [$top.t get 0.0 end] "\n"] {
3960 set ft [string trim $f]
3961 if {$ft ne {}} {
3962 lappend files $ft
3965 if {![info exists viewfiles($n)]} {
3966 # creating a new view
3967 incr nextviewnum
3968 set viewname($n) $newviewname($n)
3969 set viewperm($n) $newviewopts($n,perm)
3970 set viewfiles($n) $files
3971 set viewargs($n) $newargs
3972 set viewargscmd($n) $newviewopts($n,cmd)
3973 addviewmenu $n
3974 if {!$newishighlight} {
3975 run showview $n
3976 } else {
3977 run addvhighlight $n
3979 } else {
3980 # editing an existing view
3981 set viewperm($n) $newviewopts($n,perm)
3982 if {$newviewname($n) ne $viewname($n)} {
3983 set viewname($n) $newviewname($n)
3984 doviewmenu .bar.view 5 [list showview $n] \
3985 entryconf [list -label $viewname($n)]
3986 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3987 # entryconf [list -label $viewname($n) -value $viewname($n)]
3989 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3990 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3991 set viewfiles($n) $files
3992 set viewargs($n) $newargs
3993 set viewargscmd($n) $newviewopts($n,cmd)
3994 if {$curview == $n} {
3995 run reloadcommits
3999 if {$apply} return
4000 catch {destroy $top}
4003 proc delview {} {
4004 global curview viewperm hlview selectedhlview
4006 if {$curview == 0} return
4007 if {[info exists hlview] && $hlview == $curview} {
4008 set selectedhlview [mc "None"]
4009 unset hlview
4011 allviewmenus $curview delete
4012 set viewperm($curview) 0
4013 showview 0
4016 proc addviewmenu {n} {
4017 global viewname viewhlmenu
4019 .bar.view add radiobutton -label $viewname($n) \
4020 -command [list showview $n] -variable selectedview -value $n
4021 #$viewhlmenu add radiobutton -label $viewname($n) \
4022 # -command [list addvhighlight $n] -variable selectedhlview
4025 proc showview {n} {
4026 global curview cached_commitrow ordertok
4027 global displayorder parentlist rowidlist rowisopt rowfinal
4028 global colormap rowtextx nextcolor canvxmax
4029 global numcommits viewcomplete
4030 global selectedline currentid canv canvy0
4031 global treediffs
4032 global pending_select mainheadid
4033 global commitidx
4034 global selectedview
4035 global hlview selectedhlview commitinterest
4037 if {$n == $curview} return
4038 set selid {}
4039 set ymax [lindex [$canv cget -scrollregion] 3]
4040 set span [$canv yview]
4041 set ytop [expr {[lindex $span 0] * $ymax}]
4042 set ybot [expr {[lindex $span 1] * $ymax}]
4043 set yscreen [expr {($ybot - $ytop) / 2}]
4044 if {$selectedline ne {}} {
4045 set selid $currentid
4046 set y [yc $selectedline]
4047 if {$ytop < $y && $y < $ybot} {
4048 set yscreen [expr {$y - $ytop}]
4050 } elseif {[info exists pending_select]} {
4051 set selid $pending_select
4052 unset pending_select
4054 unselectline
4055 normalline
4056 catch {unset treediffs}
4057 clear_display
4058 if {[info exists hlview] && $hlview == $n} {
4059 unset hlview
4060 set selectedhlview [mc "None"]
4062 catch {unset commitinterest}
4063 catch {unset cached_commitrow}
4064 catch {unset ordertok}
4066 set curview $n
4067 set selectedview $n
4068 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4069 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4071 run refill_reflist
4072 if {![info exists viewcomplete($n)]} {
4073 getcommits $selid
4074 return
4077 set displayorder {}
4078 set parentlist {}
4079 set rowidlist {}
4080 set rowisopt {}
4081 set rowfinal {}
4082 set numcommits $commitidx($n)
4084 catch {unset colormap}
4085 catch {unset rowtextx}
4086 set nextcolor 0
4087 set canvxmax [$canv cget -width]
4088 set curview $n
4089 set row 0
4090 setcanvscroll
4091 set yf 0
4092 set row {}
4093 if {$selid ne {} && [commitinview $selid $n]} {
4094 set row [rowofcommit $selid]
4095 # try to get the selected row in the same position on the screen
4096 set ymax [lindex [$canv cget -scrollregion] 3]
4097 set ytop [expr {[yc $row] - $yscreen}]
4098 if {$ytop < 0} {
4099 set ytop 0
4101 set yf [expr {$ytop * 1.0 / $ymax}]
4103 allcanvs yview moveto $yf
4104 drawvisible
4105 if {$row ne {}} {
4106 selectline $row 0
4107 } elseif {!$viewcomplete($n)} {
4108 reset_pending_select $selid
4109 } else {
4110 reset_pending_select {}
4112 if {[commitinview $pending_select $curview]} {
4113 selectline [rowofcommit $pending_select] 1
4114 } else {
4115 set row [first_real_row]
4116 if {$row < $numcommits} {
4117 selectline $row 0
4121 if {!$viewcomplete($n)} {
4122 if {$numcommits == 0} {
4123 show_status [mc "Reading commits..."]
4125 } elseif {$numcommits == 0} {
4126 show_status [mc "No commits selected"]
4130 # Stuff relating to the highlighting facility
4132 proc ishighlighted {id} {
4133 global vhighlights fhighlights nhighlights rhighlights
4135 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4136 return $nhighlights($id)
4138 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4139 return $vhighlights($id)
4141 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4142 return $fhighlights($id)
4144 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4145 return $rhighlights($id)
4147 return 0
4150 proc bolden {id font} {
4151 global canv linehtag currentid boldids need_redisplay markedid
4153 # need_redisplay = 1 means the display is stale and about to be redrawn
4154 if {$need_redisplay} return
4155 lappend boldids $id
4156 $canv itemconf $linehtag($id) -font $font
4157 if {[info exists currentid] && $id eq $currentid} {
4158 $canv delete secsel
4159 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4160 -outline {{}} -tags secsel \
4161 -fill [$canv cget -selectbackground]]
4162 $canv lower $t
4164 if {[info exists markedid] && $id eq $markedid} {
4165 make_idmark $id
4169 proc bolden_name {id font} {
4170 global canv2 linentag currentid boldnameids need_redisplay
4172 if {$need_redisplay} return
4173 lappend boldnameids $id
4174 $canv2 itemconf $linentag($id) -font $font
4175 if {[info exists currentid] && $id eq $currentid} {
4176 $canv2 delete secsel
4177 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4178 -outline {{}} -tags secsel \
4179 -fill [$canv2 cget -selectbackground]]
4180 $canv2 lower $t
4184 proc unbolden {} {
4185 global boldids
4187 set stillbold {}
4188 foreach id $boldids {
4189 if {![ishighlighted $id]} {
4190 bolden $id mainfont
4191 } else {
4192 lappend stillbold $id
4195 set boldids $stillbold
4198 proc addvhighlight {n} {
4199 global hlview viewcomplete curview vhl_done commitidx
4201 if {[info exists hlview]} {
4202 delvhighlight
4204 set hlview $n
4205 if {$n != $curview && ![info exists viewcomplete($n)]} {
4206 start_rev_list $n
4208 set vhl_done $commitidx($hlview)
4209 if {$vhl_done > 0} {
4210 drawvisible
4214 proc delvhighlight {} {
4215 global hlview vhighlights
4217 if {![info exists hlview]} return
4218 unset hlview
4219 catch {unset vhighlights}
4220 unbolden
4223 proc vhighlightmore {} {
4224 global hlview vhl_done commitidx vhighlights curview
4226 set max $commitidx($hlview)
4227 set vr [visiblerows]
4228 set r0 [lindex $vr 0]
4229 set r1 [lindex $vr 1]
4230 for {set i $vhl_done} {$i < $max} {incr i} {
4231 set id [commitonrow $i $hlview]
4232 if {[commitinview $id $curview]} {
4233 set row [rowofcommit $id]
4234 if {$r0 <= $row && $row <= $r1} {
4235 if {![highlighted $row]} {
4236 bolden $id mainfontbold
4238 set vhighlights($id) 1
4242 set vhl_done $max
4243 return 0
4246 proc askvhighlight {row id} {
4247 global hlview vhighlights iddrawn
4249 if {[commitinview $id $hlview]} {
4250 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4251 bolden $id mainfontbold
4253 set vhighlights($id) 1
4254 } else {
4255 set vhighlights($id) 0
4259 proc hfiles_change {} {
4260 global highlight_files filehighlight fhighlights fh_serial
4261 global highlight_paths
4263 if {[info exists filehighlight]} {
4264 # delete previous highlights
4265 catch {close $filehighlight}
4266 unset filehighlight
4267 catch {unset fhighlights}
4268 unbolden
4269 unhighlight_filelist
4271 set highlight_paths {}
4272 after cancel do_file_hl $fh_serial
4273 incr fh_serial
4274 if {$highlight_files ne {}} {
4275 after 300 do_file_hl $fh_serial
4279 proc gdttype_change {name ix op} {
4280 global gdttype highlight_files findstring findpattern
4282 stopfinding
4283 if {$findstring ne {}} {
4284 if {$gdttype eq [mc "containing:"]} {
4285 if {$highlight_files ne {}} {
4286 set highlight_files {}
4287 hfiles_change
4289 findcom_change
4290 } else {
4291 if {$findpattern ne {}} {
4292 set findpattern {}
4293 findcom_change
4295 set highlight_files $findstring
4296 hfiles_change
4298 drawvisible
4300 # enable/disable findtype/findloc menus too
4303 proc find_change {name ix op} {
4304 global gdttype findstring highlight_files
4306 stopfinding
4307 if {$gdttype eq [mc "containing:"]} {
4308 findcom_change
4309 } else {
4310 if {$highlight_files ne $findstring} {
4311 set highlight_files $findstring
4312 hfiles_change
4315 drawvisible
4318 proc findcom_change args {
4319 global nhighlights boldnameids
4320 global findpattern findtype findstring gdttype
4322 stopfinding
4323 # delete previous highlights, if any
4324 foreach id $boldnameids {
4325 bolden_name $id mainfont
4327 set boldnameids {}
4328 catch {unset nhighlights}
4329 unbolden
4330 unmarkmatches
4331 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4332 set findpattern {}
4333 } elseif {$findtype eq [mc "Regexp"]} {
4334 set findpattern $findstring
4335 } else {
4336 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4337 $findstring]
4338 set findpattern "*$e*"
4342 proc makepatterns {l} {
4343 set ret {}
4344 foreach e $l {
4345 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4346 if {[string index $ee end] eq "/"} {
4347 lappend ret "$ee*"
4348 } else {
4349 lappend ret $ee
4350 lappend ret "$ee/*"
4353 return $ret
4356 proc do_file_hl {serial} {
4357 global highlight_files filehighlight highlight_paths gdttype fhl_list
4359 if {$gdttype eq [mc "touching paths:"]} {
4360 if {[catch {set paths [shellsplit $highlight_files]}]} return
4361 set highlight_paths [makepatterns $paths]
4362 highlight_filelist
4363 set gdtargs [concat -- $paths]
4364 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4365 set gdtargs [list "-S$highlight_files"]
4366 } else {
4367 # must be "containing:", i.e. we're searching commit info
4368 return
4370 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4371 set filehighlight [open $cmd r+]
4372 fconfigure $filehighlight -blocking 0
4373 filerun $filehighlight readfhighlight
4374 set fhl_list {}
4375 drawvisible
4376 flushhighlights
4379 proc flushhighlights {} {
4380 global filehighlight fhl_list
4382 if {[info exists filehighlight]} {
4383 lappend fhl_list {}
4384 puts $filehighlight ""
4385 flush $filehighlight
4389 proc askfilehighlight {row id} {
4390 global filehighlight fhighlights fhl_list
4392 lappend fhl_list $id
4393 set fhighlights($id) -1
4394 puts $filehighlight $id
4397 proc readfhighlight {} {
4398 global filehighlight fhighlights curview iddrawn
4399 global fhl_list find_dirn
4401 if {![info exists filehighlight]} {
4402 return 0
4404 set nr 0
4405 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4406 set line [string trim $line]
4407 set i [lsearch -exact $fhl_list $line]
4408 if {$i < 0} continue
4409 for {set j 0} {$j < $i} {incr j} {
4410 set id [lindex $fhl_list $j]
4411 set fhighlights($id) 0
4413 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4414 if {$line eq {}} continue
4415 if {![commitinview $line $curview]} continue
4416 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4417 bolden $line mainfontbold
4419 set fhighlights($line) 1
4421 if {[eof $filehighlight]} {
4422 # strange...
4423 puts "oops, git diff-tree died"
4424 catch {close $filehighlight}
4425 unset filehighlight
4426 return 0
4428 if {[info exists find_dirn]} {
4429 run findmore
4431 return 1
4434 proc doesmatch {f} {
4435 global findtype findpattern
4437 if {$findtype eq [mc "Regexp"]} {
4438 return [regexp $findpattern $f]
4439 } elseif {$findtype eq [mc "IgnCase"]} {
4440 return [string match -nocase $findpattern $f]
4441 } else {
4442 return [string match $findpattern $f]
4446 proc askfindhighlight {row id} {
4447 global nhighlights commitinfo iddrawn
4448 global findloc
4449 global markingmatches
4451 if {![info exists commitinfo($id)]} {
4452 getcommit $id
4454 set info $commitinfo($id)
4455 set isbold 0
4456 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4457 foreach f $info ty $fldtypes {
4458 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4459 [doesmatch $f]} {
4460 if {$ty eq [mc "Author"]} {
4461 set isbold 2
4462 break
4464 set isbold 1
4467 if {$isbold && [info exists iddrawn($id)]} {
4468 if {![ishighlighted $id]} {
4469 bolden $id mainfontbold
4470 if {$isbold > 1} {
4471 bolden_name $id mainfontbold
4474 if {$markingmatches} {
4475 markrowmatches $row $id
4478 set nhighlights($id) $isbold
4481 proc markrowmatches {row id} {
4482 global canv canv2 linehtag linentag commitinfo findloc
4484 set headline [lindex $commitinfo($id) 0]
4485 set author [lindex $commitinfo($id) 1]
4486 $canv delete match$row
4487 $canv2 delete match$row
4488 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4489 set m [findmatches $headline]
4490 if {$m ne {}} {
4491 markmatches $canv $row $headline $linehtag($id) $m \
4492 [$canv itemcget $linehtag($id) -font] $row
4495 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4496 set m [findmatches $author]
4497 if {$m ne {}} {
4498 markmatches $canv2 $row $author $linentag($id) $m \
4499 [$canv2 itemcget $linentag($id) -font] $row
4504 proc vrel_change {name ix op} {
4505 global highlight_related
4507 rhighlight_none
4508 if {$highlight_related ne [mc "None"]} {
4509 run drawvisible
4513 # prepare for testing whether commits are descendents or ancestors of a
4514 proc rhighlight_sel {a} {
4515 global descendent desc_todo ancestor anc_todo
4516 global highlight_related
4518 catch {unset descendent}
4519 set desc_todo [list $a]
4520 catch {unset ancestor}
4521 set anc_todo [list $a]
4522 if {$highlight_related ne [mc "None"]} {
4523 rhighlight_none
4524 run drawvisible
4528 proc rhighlight_none {} {
4529 global rhighlights
4531 catch {unset rhighlights}
4532 unbolden
4535 proc is_descendent {a} {
4536 global curview children descendent desc_todo
4538 set v $curview
4539 set la [rowofcommit $a]
4540 set todo $desc_todo
4541 set leftover {}
4542 set done 0
4543 for {set i 0} {$i < [llength $todo]} {incr i} {
4544 set do [lindex $todo $i]
4545 if {[rowofcommit $do] < $la} {
4546 lappend leftover $do
4547 continue
4549 foreach nk $children($v,$do) {
4550 if {![info exists descendent($nk)]} {
4551 set descendent($nk) 1
4552 lappend todo $nk
4553 if {$nk eq $a} {
4554 set done 1
4558 if {$done} {
4559 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4560 return
4563 set descendent($a) 0
4564 set desc_todo $leftover
4567 proc is_ancestor {a} {
4568 global curview parents ancestor anc_todo
4570 set v $curview
4571 set la [rowofcommit $a]
4572 set todo $anc_todo
4573 set leftover {}
4574 set done 0
4575 for {set i 0} {$i < [llength $todo]} {incr i} {
4576 set do [lindex $todo $i]
4577 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4578 lappend leftover $do
4579 continue
4581 foreach np $parents($v,$do) {
4582 if {![info exists ancestor($np)]} {
4583 set ancestor($np) 1
4584 lappend todo $np
4585 if {$np eq $a} {
4586 set done 1
4590 if {$done} {
4591 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4592 return
4595 set ancestor($a) 0
4596 set anc_todo $leftover
4599 proc askrelhighlight {row id} {
4600 global descendent highlight_related iddrawn rhighlights
4601 global selectedline ancestor
4603 if {$selectedline eq {}} return
4604 set isbold 0
4605 if {$highlight_related eq [mc "Descendant"] ||
4606 $highlight_related eq [mc "Not descendant"]} {
4607 if {![info exists descendent($id)]} {
4608 is_descendent $id
4610 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4611 set isbold 1
4613 } elseif {$highlight_related eq [mc "Ancestor"] ||
4614 $highlight_related eq [mc "Not ancestor"]} {
4615 if {![info exists ancestor($id)]} {
4616 is_ancestor $id
4618 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4619 set isbold 1
4622 if {[info exists iddrawn($id)]} {
4623 if {$isbold && ![ishighlighted $id]} {
4624 bolden $id mainfontbold
4627 set rhighlights($id) $isbold
4630 # Graph layout functions
4632 proc shortids {ids} {
4633 set res {}
4634 foreach id $ids {
4635 if {[llength $id] > 1} {
4636 lappend res [shortids $id]
4637 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4638 lappend res [string range $id 0 7]
4639 } else {
4640 lappend res $id
4643 return $res
4646 proc ntimes {n o} {
4647 set ret {}
4648 set o [list $o]
4649 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4650 if {($n & $mask) != 0} {
4651 set ret [concat $ret $o]
4653 set o [concat $o $o]
4655 return $ret
4658 proc ordertoken {id} {
4659 global ordertok curview varcid varcstart varctok curview parents children
4660 global nullid nullid2
4662 if {[info exists ordertok($id)]} {
4663 return $ordertok($id)
4665 set origid $id
4666 set todo {}
4667 while {1} {
4668 if {[info exists varcid($curview,$id)]} {
4669 set a $varcid($curview,$id)
4670 set p [lindex $varcstart($curview) $a]
4671 } else {
4672 set p [lindex $children($curview,$id) 0]
4674 if {[info exists ordertok($p)]} {
4675 set tok $ordertok($p)
4676 break
4678 set id [first_real_child $curview,$p]
4679 if {$id eq {}} {
4680 # it's a root
4681 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4682 break
4684 if {[llength $parents($curview,$id)] == 1} {
4685 lappend todo [list $p {}]
4686 } else {
4687 set j [lsearch -exact $parents($curview,$id) $p]
4688 if {$j < 0} {
4689 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4691 lappend todo [list $p [strrep $j]]
4694 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4695 set p [lindex $todo $i 0]
4696 append tok [lindex $todo $i 1]
4697 set ordertok($p) $tok
4699 set ordertok($origid) $tok
4700 return $tok
4703 # Work out where id should go in idlist so that order-token
4704 # values increase from left to right
4705 proc idcol {idlist id {i 0}} {
4706 set t [ordertoken $id]
4707 if {$i < 0} {
4708 set i 0
4710 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4711 if {$i > [llength $idlist]} {
4712 set i [llength $idlist]
4714 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4715 incr i
4716 } else {
4717 if {$t > [ordertoken [lindex $idlist $i]]} {
4718 while {[incr i] < [llength $idlist] &&
4719 $t >= [ordertoken [lindex $idlist $i]]} {}
4722 return $i
4725 proc initlayout {} {
4726 global rowidlist rowisopt rowfinal displayorder parentlist
4727 global numcommits canvxmax canv
4728 global nextcolor
4729 global colormap rowtextx
4731 set numcommits 0
4732 set displayorder {}
4733 set parentlist {}
4734 set nextcolor 0
4735 set rowidlist {}
4736 set rowisopt {}
4737 set rowfinal {}
4738 set canvxmax [$canv cget -width]
4739 catch {unset colormap}
4740 catch {unset rowtextx}
4741 setcanvscroll
4744 proc setcanvscroll {} {
4745 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4746 global lastscrollset lastscrollrows
4748 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4749 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4750 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4751 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4752 set lastscrollset [clock clicks -milliseconds]
4753 set lastscrollrows $numcommits
4756 proc visiblerows {} {
4757 global canv numcommits linespc
4759 set ymax [lindex [$canv cget -scrollregion] 3]
4760 if {$ymax eq {} || $ymax == 0} return
4761 set f [$canv yview]
4762 set y0 [expr {int([lindex $f 0] * $ymax)}]
4763 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4764 if {$r0 < 0} {
4765 set r0 0
4767 set y1 [expr {int([lindex $f 1] * $ymax)}]
4768 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4769 if {$r1 >= $numcommits} {
4770 set r1 [expr {$numcommits - 1}]
4772 return [list $r0 $r1]
4775 proc layoutmore {} {
4776 global commitidx viewcomplete curview
4777 global numcommits pending_select curview
4778 global lastscrollset lastscrollrows
4780 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4781 [clock clicks -milliseconds] - $lastscrollset > 500} {
4782 setcanvscroll
4784 if {[info exists pending_select] &&
4785 [commitinview $pending_select $curview]} {
4786 update
4787 selectline [rowofcommit $pending_select] 1
4789 drawvisible
4792 # With path limiting, we mightn't get the actual HEAD commit,
4793 # so ask git rev-list what is the first ancestor of HEAD that
4794 # touches a file in the path limit.
4795 proc get_viewmainhead {view} {
4796 global viewmainheadid vfilelimit viewinstances mainheadid
4798 catch {
4799 set rfd [open [concat | git rev-list -1 $mainheadid \
4800 -- $vfilelimit($view)] r]
4801 set j [reg_instance $rfd]
4802 lappend viewinstances($view) $j
4803 fconfigure $rfd -blocking 0
4804 filerun $rfd [list getviewhead $rfd $j $view]
4805 set viewmainheadid($curview) {}
4809 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4810 proc getviewhead {fd inst view} {
4811 global viewmainheadid commfd curview viewinstances showlocalchanges
4813 set id {}
4814 if {[gets $fd line] < 0} {
4815 if {![eof $fd]} {
4816 return 1
4818 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4819 set id $line
4821 set viewmainheadid($view) $id
4822 close $fd
4823 unset commfd($inst)
4824 set i [lsearch -exact $viewinstances($view) $inst]
4825 if {$i >= 0} {
4826 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4828 if {$showlocalchanges && $id ne {} && $view == $curview} {
4829 doshowlocalchanges
4831 return 0
4834 proc doshowlocalchanges {} {
4835 global curview viewmainheadid
4837 if {$viewmainheadid($curview) eq {}} return
4838 if {[commitinview $viewmainheadid($curview) $curview]} {
4839 dodiffindex
4840 } else {
4841 interestedin $viewmainheadid($curview) dodiffindex
4845 proc dohidelocalchanges {} {
4846 global nullid nullid2 lserial curview
4848 if {[commitinview $nullid $curview]} {
4849 removefakerow $nullid
4851 if {[commitinview $nullid2 $curview]} {
4852 removefakerow $nullid2
4854 incr lserial
4857 # spawn off a process to do git diff-index --cached HEAD
4858 proc dodiffindex {} {
4859 global lserial showlocalchanges vfilelimit curview
4860 global isworktree
4862 if {!$showlocalchanges || !$isworktree} return
4863 incr lserial
4864 set cmd "|git diff-index --cached HEAD"
4865 if {$vfilelimit($curview) ne {}} {
4866 set cmd [concat $cmd -- $vfilelimit($curview)]
4868 set fd [open $cmd r]
4869 fconfigure $fd -blocking 0
4870 set i [reg_instance $fd]
4871 filerun $fd [list readdiffindex $fd $lserial $i]
4874 proc readdiffindex {fd serial inst} {
4875 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4876 global vfilelimit
4878 set isdiff 1
4879 if {[gets $fd line] < 0} {
4880 if {![eof $fd]} {
4881 return 1
4883 set isdiff 0
4885 # we only need to see one line and we don't really care what it says...
4886 stop_instance $inst
4888 if {$serial != $lserial} {
4889 return 0
4892 # now see if there are any local changes not checked in to the index
4893 set cmd "|git diff-files"
4894 if {$vfilelimit($curview) ne {}} {
4895 set cmd [concat $cmd -- $vfilelimit($curview)]
4897 set fd [open $cmd r]
4898 fconfigure $fd -blocking 0
4899 set i [reg_instance $fd]
4900 filerun $fd [list readdifffiles $fd $serial $i]
4902 if {$isdiff && ![commitinview $nullid2 $curview]} {
4903 # add the line for the changes in the index to the graph
4904 set hl [mc "Local changes checked in to index but not committed"]
4905 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4906 set commitdata($nullid2) "\n $hl\n"
4907 if {[commitinview $nullid $curview]} {
4908 removefakerow $nullid
4910 insertfakerow $nullid2 $viewmainheadid($curview)
4911 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4912 if {[commitinview $nullid $curview]} {
4913 removefakerow $nullid
4915 removefakerow $nullid2
4917 return 0
4920 proc readdifffiles {fd serial inst} {
4921 global viewmainheadid nullid nullid2 curview
4922 global commitinfo commitdata lserial
4924 set isdiff 1
4925 if {[gets $fd line] < 0} {
4926 if {![eof $fd]} {
4927 return 1
4929 set isdiff 0
4931 # we only need to see one line and we don't really care what it says...
4932 stop_instance $inst
4934 if {$serial != $lserial} {
4935 return 0
4938 if {$isdiff && ![commitinview $nullid $curview]} {
4939 # add the line for the local diff to the graph
4940 set hl [mc "Local uncommitted changes, not checked in to index"]
4941 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4942 set commitdata($nullid) "\n $hl\n"
4943 if {[commitinview $nullid2 $curview]} {
4944 set p $nullid2
4945 } else {
4946 set p $viewmainheadid($curview)
4948 insertfakerow $nullid $p
4949 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4950 removefakerow $nullid
4952 return 0
4955 proc nextuse {id row} {
4956 global curview children
4958 if {[info exists children($curview,$id)]} {
4959 foreach kid $children($curview,$id) {
4960 if {![commitinview $kid $curview]} {
4961 return -1
4963 if {[rowofcommit $kid] > $row} {
4964 return [rowofcommit $kid]
4968 if {[commitinview $id $curview]} {
4969 return [rowofcommit $id]
4971 return -1
4974 proc prevuse {id row} {
4975 global curview children
4977 set ret -1
4978 if {[info exists children($curview,$id)]} {
4979 foreach kid $children($curview,$id) {
4980 if {![commitinview $kid $curview]} break
4981 if {[rowofcommit $kid] < $row} {
4982 set ret [rowofcommit $kid]
4986 return $ret
4989 proc make_idlist {row} {
4990 global displayorder parentlist uparrowlen downarrowlen mingaplen
4991 global commitidx curview children
4993 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4994 if {$r < 0} {
4995 set r 0
4997 set ra [expr {$row - $downarrowlen}]
4998 if {$ra < 0} {
4999 set ra 0
5001 set rb [expr {$row + $uparrowlen}]
5002 if {$rb > $commitidx($curview)} {
5003 set rb $commitidx($curview)
5005 make_disporder $r [expr {$rb + 1}]
5006 set ids {}
5007 for {} {$r < $ra} {incr r} {
5008 set nextid [lindex $displayorder [expr {$r + 1}]]
5009 foreach p [lindex $parentlist $r] {
5010 if {$p eq $nextid} continue
5011 set rn [nextuse $p $r]
5012 if {$rn >= $row &&
5013 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5014 lappend ids [list [ordertoken $p] $p]
5018 for {} {$r < $row} {incr r} {
5019 set nextid [lindex $displayorder [expr {$r + 1}]]
5020 foreach p [lindex $parentlist $r] {
5021 if {$p eq $nextid} continue
5022 set rn [nextuse $p $r]
5023 if {$rn < 0 || $rn >= $row} {
5024 lappend ids [list [ordertoken $p] $p]
5028 set id [lindex $displayorder $row]
5029 lappend ids [list [ordertoken $id] $id]
5030 while {$r < $rb} {
5031 foreach p [lindex $parentlist $r] {
5032 set firstkid [lindex $children($curview,$p) 0]
5033 if {[rowofcommit $firstkid] < $row} {
5034 lappend ids [list [ordertoken $p] $p]
5037 incr r
5038 set id [lindex $displayorder $r]
5039 if {$id ne {}} {
5040 set firstkid [lindex $children($curview,$id) 0]
5041 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5042 lappend ids [list [ordertoken $id] $id]
5046 set idlist {}
5047 foreach idx [lsort -unique $ids] {
5048 lappend idlist [lindex $idx 1]
5050 return $idlist
5053 proc rowsequal {a b} {
5054 while {[set i [lsearch -exact $a {}]] >= 0} {
5055 set a [lreplace $a $i $i]
5057 while {[set i [lsearch -exact $b {}]] >= 0} {
5058 set b [lreplace $b $i $i]
5060 return [expr {$a eq $b}]
5063 proc makeupline {id row rend col} {
5064 global rowidlist uparrowlen downarrowlen mingaplen
5066 for {set r $rend} {1} {set r $rstart} {
5067 set rstart [prevuse $id $r]
5068 if {$rstart < 0} return
5069 if {$rstart < $row} break
5071 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5072 set rstart [expr {$rend - $uparrowlen - 1}]
5074 for {set r $rstart} {[incr r] <= $row} {} {
5075 set idlist [lindex $rowidlist $r]
5076 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5077 set col [idcol $idlist $id $col]
5078 lset rowidlist $r [linsert $idlist $col $id]
5079 changedrow $r
5084 proc layoutrows {row endrow} {
5085 global rowidlist rowisopt rowfinal displayorder
5086 global uparrowlen downarrowlen maxwidth mingaplen
5087 global children parentlist
5088 global commitidx viewcomplete curview
5090 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5091 set idlist {}
5092 if {$row > 0} {
5093 set rm1 [expr {$row - 1}]
5094 foreach id [lindex $rowidlist $rm1] {
5095 if {$id ne {}} {
5096 lappend idlist $id
5099 set final [lindex $rowfinal $rm1]
5101 for {} {$row < $endrow} {incr row} {
5102 set rm1 [expr {$row - 1}]
5103 if {$rm1 < 0 || $idlist eq {}} {
5104 set idlist [make_idlist $row]
5105 set final 1
5106 } else {
5107 set id [lindex $displayorder $rm1]
5108 set col [lsearch -exact $idlist $id]
5109 set idlist [lreplace $idlist $col $col]
5110 foreach p [lindex $parentlist $rm1] {
5111 if {[lsearch -exact $idlist $p] < 0} {
5112 set col [idcol $idlist $p $col]
5113 set idlist [linsert $idlist $col $p]
5114 # if not the first child, we have to insert a line going up
5115 if {$id ne [lindex $children($curview,$p) 0]} {
5116 makeupline $p $rm1 $row $col
5120 set id [lindex $displayorder $row]
5121 if {$row > $downarrowlen} {
5122 set termrow [expr {$row - $downarrowlen - 1}]
5123 foreach p [lindex $parentlist $termrow] {
5124 set i [lsearch -exact $idlist $p]
5125 if {$i < 0} continue
5126 set nr [nextuse $p $termrow]
5127 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5128 set idlist [lreplace $idlist $i $i]
5132 set col [lsearch -exact $idlist $id]
5133 if {$col < 0} {
5134 set col [idcol $idlist $id]
5135 set idlist [linsert $idlist $col $id]
5136 if {$children($curview,$id) ne {}} {
5137 makeupline $id $rm1 $row $col
5140 set r [expr {$row + $uparrowlen - 1}]
5141 if {$r < $commitidx($curview)} {
5142 set x $col
5143 foreach p [lindex $parentlist $r] {
5144 if {[lsearch -exact $idlist $p] >= 0} continue
5145 set fk [lindex $children($curview,$p) 0]
5146 if {[rowofcommit $fk] < $row} {
5147 set x [idcol $idlist $p $x]
5148 set idlist [linsert $idlist $x $p]
5151 if {[incr r] < $commitidx($curview)} {
5152 set p [lindex $displayorder $r]
5153 if {[lsearch -exact $idlist $p] < 0} {
5154 set fk [lindex $children($curview,$p) 0]
5155 if {$fk ne {} && [rowofcommit $fk] < $row} {
5156 set x [idcol $idlist $p $x]
5157 set idlist [linsert $idlist $x $p]
5163 if {$final && !$viewcomplete($curview) &&
5164 $row + $uparrowlen + $mingaplen + $downarrowlen
5165 >= $commitidx($curview)} {
5166 set final 0
5168 set l [llength $rowidlist]
5169 if {$row == $l} {
5170 lappend rowidlist $idlist
5171 lappend rowisopt 0
5172 lappend rowfinal $final
5173 } elseif {$row < $l} {
5174 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5175 lset rowidlist $row $idlist
5176 changedrow $row
5178 lset rowfinal $row $final
5179 } else {
5180 set pad [ntimes [expr {$row - $l}] {}]
5181 set rowidlist [concat $rowidlist $pad]
5182 lappend rowidlist $idlist
5183 set rowfinal [concat $rowfinal $pad]
5184 lappend rowfinal $final
5185 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5188 return $row
5191 proc changedrow {row} {
5192 global displayorder iddrawn rowisopt need_redisplay
5194 set l [llength $rowisopt]
5195 if {$row < $l} {
5196 lset rowisopt $row 0
5197 if {$row + 1 < $l} {
5198 lset rowisopt [expr {$row + 1}] 0
5199 if {$row + 2 < $l} {
5200 lset rowisopt [expr {$row + 2}] 0
5204 set id [lindex $displayorder $row]
5205 if {[info exists iddrawn($id)]} {
5206 set need_redisplay 1
5210 proc insert_pad {row col npad} {
5211 global rowidlist
5213 set pad [ntimes $npad {}]
5214 set idlist [lindex $rowidlist $row]
5215 set bef [lrange $idlist 0 [expr {$col - 1}]]
5216 set aft [lrange $idlist $col end]
5217 set i [lsearch -exact $aft {}]
5218 if {$i > 0} {
5219 set aft [lreplace $aft $i $i]
5221 lset rowidlist $row [concat $bef $pad $aft]
5222 changedrow $row
5225 proc optimize_rows {row col endrow} {
5226 global rowidlist rowisopt displayorder curview children
5228 if {$row < 1} {
5229 set row 1
5231 for {} {$row < $endrow} {incr row; set col 0} {
5232 if {[lindex $rowisopt $row]} continue
5233 set haspad 0
5234 set y0 [expr {$row - 1}]
5235 set ym [expr {$row - 2}]
5236 set idlist [lindex $rowidlist $row]
5237 set previdlist [lindex $rowidlist $y0]
5238 if {$idlist eq {} || $previdlist eq {}} continue
5239 if {$ym >= 0} {
5240 set pprevidlist [lindex $rowidlist $ym]
5241 if {$pprevidlist eq {}} continue
5242 } else {
5243 set pprevidlist {}
5245 set x0 -1
5246 set xm -1
5247 for {} {$col < [llength $idlist]} {incr col} {
5248 set id [lindex $idlist $col]
5249 if {[lindex $previdlist $col] eq $id} continue
5250 if {$id eq {}} {
5251 set haspad 1
5252 continue
5254 set x0 [lsearch -exact $previdlist $id]
5255 if {$x0 < 0} continue
5256 set z [expr {$x0 - $col}]
5257 set isarrow 0
5258 set z0 {}
5259 if {$ym >= 0} {
5260 set xm [lsearch -exact $pprevidlist $id]
5261 if {$xm >= 0} {
5262 set z0 [expr {$xm - $x0}]
5265 if {$z0 eq {}} {
5266 # if row y0 is the first child of $id then it's not an arrow
5267 if {[lindex $children($curview,$id) 0] ne
5268 [lindex $displayorder $y0]} {
5269 set isarrow 1
5272 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5273 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5274 set isarrow 1
5276 # Looking at lines from this row to the previous row,
5277 # make them go straight up if they end in an arrow on
5278 # the previous row; otherwise make them go straight up
5279 # or at 45 degrees.
5280 if {$z < -1 || ($z < 0 && $isarrow)} {
5281 # Line currently goes left too much;
5282 # insert pads in the previous row, then optimize it
5283 set npad [expr {-1 - $z + $isarrow}]
5284 insert_pad $y0 $x0 $npad
5285 if {$y0 > 0} {
5286 optimize_rows $y0 $x0 $row
5288 set previdlist [lindex $rowidlist $y0]
5289 set x0 [lsearch -exact $previdlist $id]
5290 set z [expr {$x0 - $col}]
5291 if {$z0 ne {}} {
5292 set pprevidlist [lindex $rowidlist $ym]
5293 set xm [lsearch -exact $pprevidlist $id]
5294 set z0 [expr {$xm - $x0}]
5296 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5297 # Line currently goes right too much;
5298 # insert pads in this line
5299 set npad [expr {$z - 1 + $isarrow}]
5300 insert_pad $row $col $npad
5301 set idlist [lindex $rowidlist $row]
5302 incr col $npad
5303 set z [expr {$x0 - $col}]
5304 set haspad 1
5306 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5307 # this line links to its first child on row $row-2
5308 set id [lindex $displayorder $ym]
5309 set xc [lsearch -exact $pprevidlist $id]
5310 if {$xc >= 0} {
5311 set z0 [expr {$xc - $x0}]
5314 # avoid lines jigging left then immediately right
5315 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5316 insert_pad $y0 $x0 1
5317 incr x0
5318 optimize_rows $y0 $x0 $row
5319 set previdlist [lindex $rowidlist $y0]
5322 if {!$haspad} {
5323 # Find the first column that doesn't have a line going right
5324 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5325 set id [lindex $idlist $col]
5326 if {$id eq {}} break
5327 set x0 [lsearch -exact $previdlist $id]
5328 if {$x0 < 0} {
5329 # check if this is the link to the first child
5330 set kid [lindex $displayorder $y0]
5331 if {[lindex $children($curview,$id) 0] eq $kid} {
5332 # it is, work out offset to child
5333 set x0 [lsearch -exact $previdlist $kid]
5336 if {$x0 <= $col} break
5338 # Insert a pad at that column as long as it has a line and
5339 # isn't the last column
5340 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5341 set idlist [linsert $idlist $col {}]
5342 lset rowidlist $row $idlist
5343 changedrow $row
5349 proc xc {row col} {
5350 global canvx0 linespc
5351 return [expr {$canvx0 + $col * $linespc}]
5354 proc yc {row} {
5355 global canvy0 linespc
5356 return [expr {$canvy0 + $row * $linespc}]
5359 proc linewidth {id} {
5360 global thickerline lthickness
5362 set wid $lthickness
5363 if {[info exists thickerline] && $id eq $thickerline} {
5364 set wid [expr {2 * $lthickness}]
5366 return $wid
5369 proc rowranges {id} {
5370 global curview children uparrowlen downarrowlen
5371 global rowidlist
5373 set kids $children($curview,$id)
5374 if {$kids eq {}} {
5375 return {}
5377 set ret {}
5378 lappend kids $id
5379 foreach child $kids {
5380 if {![commitinview $child $curview]} break
5381 set row [rowofcommit $child]
5382 if {![info exists prev]} {
5383 lappend ret [expr {$row + 1}]
5384 } else {
5385 if {$row <= $prevrow} {
5386 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5388 # see if the line extends the whole way from prevrow to row
5389 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5390 [lsearch -exact [lindex $rowidlist \
5391 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5392 # it doesn't, see where it ends
5393 set r [expr {$prevrow + $downarrowlen}]
5394 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5395 while {[incr r -1] > $prevrow &&
5396 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5397 } else {
5398 while {[incr r] <= $row &&
5399 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5400 incr r -1
5402 lappend ret $r
5403 # see where it starts up again
5404 set r [expr {$row - $uparrowlen}]
5405 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5406 while {[incr r] < $row &&
5407 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5408 } else {
5409 while {[incr r -1] >= $prevrow &&
5410 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5411 incr r
5413 lappend ret $r
5416 if {$child eq $id} {
5417 lappend ret $row
5419 set prev $child
5420 set prevrow $row
5422 return $ret
5425 proc drawlineseg {id row endrow arrowlow} {
5426 global rowidlist displayorder iddrawn linesegs
5427 global canv colormap linespc curview maxlinelen parentlist
5429 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5430 set le [expr {$row + 1}]
5431 set arrowhigh 1
5432 while {1} {
5433 set c [lsearch -exact [lindex $rowidlist $le] $id]
5434 if {$c < 0} {
5435 incr le -1
5436 break
5438 lappend cols $c
5439 set x [lindex $displayorder $le]
5440 if {$x eq $id} {
5441 set arrowhigh 0
5442 break
5444 if {[info exists iddrawn($x)] || $le == $endrow} {
5445 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5446 if {$c >= 0} {
5447 lappend cols $c
5448 set arrowhigh 0
5450 break
5452 incr le
5454 if {$le <= $row} {
5455 return $row
5458 set lines {}
5459 set i 0
5460 set joinhigh 0
5461 if {[info exists linesegs($id)]} {
5462 set lines $linesegs($id)
5463 foreach li $lines {
5464 set r0 [lindex $li 0]
5465 if {$r0 > $row} {
5466 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5467 set joinhigh 1
5469 break
5471 incr i
5474 set joinlow 0
5475 if {$i > 0} {
5476 set li [lindex $lines [expr {$i-1}]]
5477 set r1 [lindex $li 1]
5478 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5479 set joinlow 1
5483 set x [lindex $cols [expr {$le - $row}]]
5484 set xp [lindex $cols [expr {$le - 1 - $row}]]
5485 set dir [expr {$xp - $x}]
5486 if {$joinhigh} {
5487 set ith [lindex $lines $i 2]
5488 set coords [$canv coords $ith]
5489 set ah [$canv itemcget $ith -arrow]
5490 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5491 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5492 if {$x2 ne {} && $x - $x2 == $dir} {
5493 set coords [lrange $coords 0 end-2]
5495 } else {
5496 set coords [list [xc $le $x] [yc $le]]
5498 if {$joinlow} {
5499 set itl [lindex $lines [expr {$i-1}] 2]
5500 set al [$canv itemcget $itl -arrow]
5501 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5502 } elseif {$arrowlow} {
5503 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5504 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5505 set arrowlow 0
5508 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5509 for {set y $le} {[incr y -1] > $row} {} {
5510 set x $xp
5511 set xp [lindex $cols [expr {$y - 1 - $row}]]
5512 set ndir [expr {$xp - $x}]
5513 if {$dir != $ndir || $xp < 0} {
5514 lappend coords [xc $y $x] [yc $y]
5516 set dir $ndir
5518 if {!$joinlow} {
5519 if {$xp < 0} {
5520 # join parent line to first child
5521 set ch [lindex $displayorder $row]
5522 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5523 if {$xc < 0} {
5524 puts "oops: drawlineseg: child $ch not on row $row"
5525 } elseif {$xc != $x} {
5526 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5527 set d [expr {int(0.5 * $linespc)}]
5528 set x1 [xc $row $x]
5529 if {$xc < $x} {
5530 set x2 [expr {$x1 - $d}]
5531 } else {
5532 set x2 [expr {$x1 + $d}]
5534 set y2 [yc $row]
5535 set y1 [expr {$y2 + $d}]
5536 lappend coords $x1 $y1 $x2 $y2
5537 } elseif {$xc < $x - 1} {
5538 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5539 } elseif {$xc > $x + 1} {
5540 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5542 set x $xc
5544 lappend coords [xc $row $x] [yc $row]
5545 } else {
5546 set xn [xc $row $xp]
5547 set yn [yc $row]
5548 lappend coords $xn $yn
5550 if {!$joinhigh} {
5551 assigncolor $id
5552 set t [$canv create line $coords -width [linewidth $id] \
5553 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5554 $canv lower $t
5555 bindline $t $id
5556 set lines [linsert $lines $i [list $row $le $t]]
5557 } else {
5558 $canv coords $ith $coords
5559 if {$arrow ne $ah} {
5560 $canv itemconf $ith -arrow $arrow
5562 lset lines $i 0 $row
5564 } else {
5565 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5566 set ndir [expr {$xo - $xp}]
5567 set clow [$canv coords $itl]
5568 if {$dir == $ndir} {
5569 set clow [lrange $clow 2 end]
5571 set coords [concat $coords $clow]
5572 if {!$joinhigh} {
5573 lset lines [expr {$i-1}] 1 $le
5574 } else {
5575 # coalesce two pieces
5576 $canv delete $ith
5577 set b [lindex $lines [expr {$i-1}] 0]
5578 set e [lindex $lines $i 1]
5579 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5581 $canv coords $itl $coords
5582 if {$arrow ne $al} {
5583 $canv itemconf $itl -arrow $arrow
5587 set linesegs($id) $lines
5588 return $le
5591 proc drawparentlinks {id row} {
5592 global rowidlist canv colormap curview parentlist
5593 global idpos linespc
5595 set rowids [lindex $rowidlist $row]
5596 set col [lsearch -exact $rowids $id]
5597 if {$col < 0} return
5598 set olds [lindex $parentlist $row]
5599 set row2 [expr {$row + 1}]
5600 set x [xc $row $col]
5601 set y [yc $row]
5602 set y2 [yc $row2]
5603 set d [expr {int(0.5 * $linespc)}]
5604 set ymid [expr {$y + $d}]
5605 set ids [lindex $rowidlist $row2]
5606 # rmx = right-most X coord used
5607 set rmx 0
5608 foreach p $olds {
5609 set i [lsearch -exact $ids $p]
5610 if {$i < 0} {
5611 puts "oops, parent $p of $id not in list"
5612 continue
5614 set x2 [xc $row2 $i]
5615 if {$x2 > $rmx} {
5616 set rmx $x2
5618 set j [lsearch -exact $rowids $p]
5619 if {$j < 0} {
5620 # drawlineseg will do this one for us
5621 continue
5623 assigncolor $p
5624 # should handle duplicated parents here...
5625 set coords [list $x $y]
5626 if {$i != $col} {
5627 # if attaching to a vertical segment, draw a smaller
5628 # slant for visual distinctness
5629 if {$i == $j} {
5630 if {$i < $col} {
5631 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5632 } else {
5633 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5635 } elseif {$i < $col && $i < $j} {
5636 # segment slants towards us already
5637 lappend coords [xc $row $j] $y
5638 } else {
5639 if {$i < $col - 1} {
5640 lappend coords [expr {$x2 + $linespc}] $y
5641 } elseif {$i > $col + 1} {
5642 lappend coords [expr {$x2 - $linespc}] $y
5644 lappend coords $x2 $y2
5646 } else {
5647 lappend coords $x2 $y2
5649 set t [$canv create line $coords -width [linewidth $p] \
5650 -fill $colormap($p) -tags lines.$p]
5651 $canv lower $t
5652 bindline $t $p
5654 if {$rmx > [lindex $idpos($id) 1]} {
5655 lset idpos($id) 1 $rmx
5656 redrawtags $id
5660 proc drawlines {id} {
5661 global canv
5663 $canv itemconf lines.$id -width [linewidth $id]
5666 proc drawcmittext {id row col} {
5667 global linespc canv canv2 canv3 fgcolor curview
5668 global cmitlisted commitinfo rowidlist parentlist
5669 global rowtextx idpos idtags idheads idotherrefs
5670 global linehtag linentag linedtag selectedline
5671 global canvxmax boldids boldnameids fgcolor markedid
5672 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5674 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5675 set listed $cmitlisted($curview,$id)
5676 if {$id eq $nullid} {
5677 set ofill red
5678 } elseif {$id eq $nullid2} {
5679 set ofill green
5680 } elseif {$id eq $mainheadid} {
5681 set ofill yellow
5682 } else {
5683 set ofill [lindex $circlecolors $listed]
5685 set x [xc $row $col]
5686 set y [yc $row]
5687 set orad [expr {$linespc / 3}]
5688 if {$listed <= 2} {
5689 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5690 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5691 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5692 } elseif {$listed == 3} {
5693 # triangle pointing left for left-side commits
5694 set t [$canv create polygon \
5695 [expr {$x - $orad}] $y \
5696 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5697 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5698 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5699 } else {
5700 # triangle pointing right for right-side commits
5701 set t [$canv create polygon \
5702 [expr {$x + $orad - 1}] $y \
5703 [expr {$x - $orad}] [expr {$y - $orad}] \
5704 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5705 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5707 set circleitem($row) $t
5708 $canv raise $t
5709 $canv bind $t <1> {selcanvline {} %x %y}
5710 set rmx [llength [lindex $rowidlist $row]]
5711 set olds [lindex $parentlist $row]
5712 if {$olds ne {}} {
5713 set nextids [lindex $rowidlist [expr {$row + 1}]]
5714 foreach p $olds {
5715 set i [lsearch -exact $nextids $p]
5716 if {$i > $rmx} {
5717 set rmx $i
5721 set xt [xc $row $rmx]
5722 set rowtextx($row) $xt
5723 set idpos($id) [list $x $xt $y]
5724 if {[info exists idtags($id)] || [info exists idheads($id)]
5725 || [info exists idotherrefs($id)]} {
5726 set xt [drawtags $id $x $xt $y]
5728 set headline [lindex $commitinfo($id) 0]
5729 set name [lindex $commitinfo($id) 1]
5730 set date [lindex $commitinfo($id) 2]
5731 set date [formatdate $date]
5732 set font mainfont
5733 set nfont mainfont
5734 set isbold [ishighlighted $id]
5735 if {$isbold > 0} {
5736 lappend boldids $id
5737 set font mainfontbold
5738 if {$isbold > 1} {
5739 lappend boldnameids $id
5740 set nfont mainfontbold
5743 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5744 -text $headline -font $font -tags text]
5745 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5746 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5747 -text $name -font $nfont -tags text]
5748 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5749 -text $date -font mainfont -tags text]
5750 if {$selectedline == $row} {
5751 make_secsel $id
5753 if {[info exists markedid] && $markedid eq $id} {
5754 make_idmark $id
5756 set xr [expr {$xt + [font measure $font $headline]}]
5757 if {$xr > $canvxmax} {
5758 set canvxmax $xr
5759 setcanvscroll
5763 proc drawcmitrow {row} {
5764 global displayorder rowidlist nrows_drawn
5765 global iddrawn markingmatches
5766 global commitinfo numcommits
5767 global filehighlight fhighlights findpattern nhighlights
5768 global hlview vhighlights
5769 global highlight_related rhighlights
5771 if {$row >= $numcommits} return
5773 set id [lindex $displayorder $row]
5774 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5775 askvhighlight $row $id
5777 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5778 askfilehighlight $row $id
5780 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5781 askfindhighlight $row $id
5783 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5784 askrelhighlight $row $id
5786 if {![info exists iddrawn($id)]} {
5787 set col [lsearch -exact [lindex $rowidlist $row] $id]
5788 if {$col < 0} {
5789 puts "oops, row $row id $id not in list"
5790 return
5792 if {![info exists commitinfo($id)]} {
5793 getcommit $id
5795 assigncolor $id
5796 drawcmittext $id $row $col
5797 set iddrawn($id) 1
5798 incr nrows_drawn
5800 if {$markingmatches} {
5801 markrowmatches $row $id
5805 proc drawcommits {row {endrow {}}} {
5806 global numcommits iddrawn displayorder curview need_redisplay
5807 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5809 if {$row < 0} {
5810 set row 0
5812 if {$endrow eq {}} {
5813 set endrow $row
5815 if {$endrow >= $numcommits} {
5816 set endrow [expr {$numcommits - 1}]
5819 set rl1 [expr {$row - $downarrowlen - 3}]
5820 if {$rl1 < 0} {
5821 set rl1 0
5823 set ro1 [expr {$row - 3}]
5824 if {$ro1 < 0} {
5825 set ro1 0
5827 set r2 [expr {$endrow + $uparrowlen + 3}]
5828 if {$r2 > $numcommits} {
5829 set r2 $numcommits
5831 for {set r $rl1} {$r < $r2} {incr r} {
5832 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5833 if {$rl1 < $r} {
5834 layoutrows $rl1 $r
5836 set rl1 [expr {$r + 1}]
5839 if {$rl1 < $r} {
5840 layoutrows $rl1 $r
5842 optimize_rows $ro1 0 $r2
5843 if {$need_redisplay || $nrows_drawn > 2000} {
5844 clear_display
5847 # make the lines join to already-drawn rows either side
5848 set r [expr {$row - 1}]
5849 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5850 set r $row
5852 set er [expr {$endrow + 1}]
5853 if {$er >= $numcommits ||
5854 ![info exists iddrawn([lindex $displayorder $er])]} {
5855 set er $endrow
5857 for {} {$r <= $er} {incr r} {
5858 set id [lindex $displayorder $r]
5859 set wasdrawn [info exists iddrawn($id)]
5860 drawcmitrow $r
5861 if {$r == $er} break
5862 set nextid [lindex $displayorder [expr {$r + 1}]]
5863 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5864 drawparentlinks $id $r
5866 set rowids [lindex $rowidlist $r]
5867 foreach lid $rowids {
5868 if {$lid eq {}} continue
5869 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5870 if {$lid eq $id} {
5871 # see if this is the first child of any of its parents
5872 foreach p [lindex $parentlist $r] {
5873 if {[lsearch -exact $rowids $p] < 0} {
5874 # make this line extend up to the child
5875 set lineend($p) [drawlineseg $p $r $er 0]
5878 } else {
5879 set lineend($lid) [drawlineseg $lid $r $er 1]
5885 proc undolayout {row} {
5886 global uparrowlen mingaplen downarrowlen
5887 global rowidlist rowisopt rowfinal need_redisplay
5889 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5890 if {$r < 0} {
5891 set r 0
5893 if {[llength $rowidlist] > $r} {
5894 incr r -1
5895 set rowidlist [lrange $rowidlist 0 $r]
5896 set rowfinal [lrange $rowfinal 0 $r]
5897 set rowisopt [lrange $rowisopt 0 $r]
5898 set need_redisplay 1
5899 run drawvisible
5903 proc drawvisible {} {
5904 global canv linespc curview vrowmod selectedline targetrow targetid
5905 global need_redisplay cscroll numcommits
5907 set fs [$canv yview]
5908 set ymax [lindex [$canv cget -scrollregion] 3]
5909 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5910 set f0 [lindex $fs 0]
5911 set f1 [lindex $fs 1]
5912 set y0 [expr {int($f0 * $ymax)}]
5913 set y1 [expr {int($f1 * $ymax)}]
5915 if {[info exists targetid]} {
5916 if {[commitinview $targetid $curview]} {
5917 set r [rowofcommit $targetid]
5918 if {$r != $targetrow} {
5919 # Fix up the scrollregion and change the scrolling position
5920 # now that our target row has moved.
5921 set diff [expr {($r - $targetrow) * $linespc}]
5922 set targetrow $r
5923 setcanvscroll
5924 set ymax [lindex [$canv cget -scrollregion] 3]
5925 incr y0 $diff
5926 incr y1 $diff
5927 set f0 [expr {$y0 / $ymax}]
5928 set f1 [expr {$y1 / $ymax}]
5929 allcanvs yview moveto $f0
5930 $cscroll set $f0 $f1
5931 set need_redisplay 1
5933 } else {
5934 unset targetid
5938 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5939 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5940 if {$endrow >= $vrowmod($curview)} {
5941 update_arcrows $curview
5943 if {$selectedline ne {} &&
5944 $row <= $selectedline && $selectedline <= $endrow} {
5945 set targetrow $selectedline
5946 } elseif {[info exists targetid]} {
5947 set targetrow [expr {int(($row + $endrow) / 2)}]
5949 if {[info exists targetrow]} {
5950 if {$targetrow >= $numcommits} {
5951 set targetrow [expr {$numcommits - 1}]
5953 set targetid [commitonrow $targetrow]
5955 drawcommits $row $endrow
5958 proc clear_display {} {
5959 global iddrawn linesegs need_redisplay nrows_drawn
5960 global vhighlights fhighlights nhighlights rhighlights
5961 global linehtag linentag linedtag boldids boldnameids
5963 allcanvs delete all
5964 catch {unset iddrawn}
5965 catch {unset linesegs}
5966 catch {unset linehtag}
5967 catch {unset linentag}
5968 catch {unset linedtag}
5969 set boldids {}
5970 set boldnameids {}
5971 catch {unset vhighlights}
5972 catch {unset fhighlights}
5973 catch {unset nhighlights}
5974 catch {unset rhighlights}
5975 set need_redisplay 0
5976 set nrows_drawn 0
5979 proc findcrossings {id} {
5980 global rowidlist parentlist numcommits displayorder
5982 set cross {}
5983 set ccross {}
5984 foreach {s e} [rowranges $id] {
5985 if {$e >= $numcommits} {
5986 set e [expr {$numcommits - 1}]
5988 if {$e <= $s} continue
5989 for {set row $e} {[incr row -1] >= $s} {} {
5990 set x [lsearch -exact [lindex $rowidlist $row] $id]
5991 if {$x < 0} break
5992 set olds [lindex $parentlist $row]
5993 set kid [lindex $displayorder $row]
5994 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5995 if {$kidx < 0} continue
5996 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5997 foreach p $olds {
5998 set px [lsearch -exact $nextrow $p]
5999 if {$px < 0} continue
6000 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6001 if {[lsearch -exact $ccross $p] >= 0} continue
6002 if {$x == $px + ($kidx < $px? -1: 1)} {
6003 lappend ccross $p
6004 } elseif {[lsearch -exact $cross $p] < 0} {
6005 lappend cross $p
6011 return [concat $ccross {{}} $cross]
6014 proc assigncolor {id} {
6015 global colormap colors nextcolor
6016 global parents children children curview
6018 if {[info exists colormap($id)]} return
6019 set ncolors [llength $colors]
6020 if {[info exists children($curview,$id)]} {
6021 set kids $children($curview,$id)
6022 } else {
6023 set kids {}
6025 if {[llength $kids] == 1} {
6026 set child [lindex $kids 0]
6027 if {[info exists colormap($child)]
6028 && [llength $parents($curview,$child)] == 1} {
6029 set colormap($id) $colormap($child)
6030 return
6033 set badcolors {}
6034 set origbad {}
6035 foreach x [findcrossings $id] {
6036 if {$x eq {}} {
6037 # delimiter between corner crossings and other crossings
6038 if {[llength $badcolors] >= $ncolors - 1} break
6039 set origbad $badcolors
6041 if {[info exists colormap($x)]
6042 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6043 lappend badcolors $colormap($x)
6046 if {[llength $badcolors] >= $ncolors} {
6047 set badcolors $origbad
6049 set origbad $badcolors
6050 if {[llength $badcolors] < $ncolors - 1} {
6051 foreach child $kids {
6052 if {[info exists colormap($child)]
6053 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6054 lappend badcolors $colormap($child)
6056 foreach p $parents($curview,$child) {
6057 if {[info exists colormap($p)]
6058 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6059 lappend badcolors $colormap($p)
6063 if {[llength $badcolors] >= $ncolors} {
6064 set badcolors $origbad
6067 for {set i 0} {$i <= $ncolors} {incr i} {
6068 set c [lindex $colors $nextcolor]
6069 if {[incr nextcolor] >= $ncolors} {
6070 set nextcolor 0
6072 if {[lsearch -exact $badcolors $c]} break
6074 set colormap($id) $c
6077 proc bindline {t id} {
6078 global canv
6080 $canv bind $t <Enter> "lineenter %x %y $id"
6081 $canv bind $t <Motion> "linemotion %x %y $id"
6082 $canv bind $t <Leave> "lineleave $id"
6083 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6086 proc drawtags {id x xt y1} {
6087 global idtags idheads idotherrefs mainhead
6088 global linespc lthickness
6089 global canv rowtextx curview fgcolor bgcolor ctxbut
6091 set marks {}
6092 set ntags 0
6093 set nheads 0
6094 if {[info exists idtags($id)]} {
6095 set marks $idtags($id)
6096 set ntags [llength $marks]
6098 if {[info exists idheads($id)]} {
6099 set marks [concat $marks $idheads($id)]
6100 set nheads [llength $idheads($id)]
6102 if {[info exists idotherrefs($id)]} {
6103 set marks [concat $marks $idotherrefs($id)]
6105 if {$marks eq {}} {
6106 return $xt
6109 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6110 set yt [expr {$y1 - 0.5 * $linespc}]
6111 set yb [expr {$yt + $linespc - 1}]
6112 set xvals {}
6113 set wvals {}
6114 set i -1
6115 foreach tag $marks {
6116 incr i
6117 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6118 set wid [font measure mainfontbold $tag]
6119 } else {
6120 set wid [font measure mainfont $tag]
6122 lappend xvals $xt
6123 lappend wvals $wid
6124 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6126 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6127 -width $lthickness -fill black -tags tag.$id]
6128 $canv lower $t
6129 foreach tag $marks x $xvals wid $wvals {
6130 set xl [expr {$x + $delta}]
6131 set xr [expr {$x + $delta + $wid + $lthickness}]
6132 set font mainfont
6133 if {[incr ntags -1] >= 0} {
6134 # draw a tag
6135 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6136 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6137 -width 1 -outline black -fill yellow -tags tag.$id]
6138 $canv bind $t <1> [list showtag $tag 1]
6139 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6140 } else {
6141 # draw a head or other ref
6142 if {[incr nheads -1] >= 0} {
6143 set col green
6144 if {$tag eq $mainhead} {
6145 set font mainfontbold
6147 } else {
6148 set col "#ddddff"
6150 set xl [expr {$xl - $delta/2}]
6151 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6152 -width 1 -outline black -fill $col -tags tag.$id
6153 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6154 set rwid [font measure mainfont $remoteprefix]
6155 set xi [expr {$x + 1}]
6156 set yti [expr {$yt + 1}]
6157 set xri [expr {$x + $rwid}]
6158 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6159 -width 0 -fill "#ffddaa" -tags tag.$id
6162 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6163 -font $font -tags [list tag.$id text]]
6164 if {$ntags >= 0} {
6165 $canv bind $t <1> [list showtag $tag 1]
6166 } elseif {$nheads >= 0} {
6167 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6170 return $xt
6173 proc xcoord {i level ln} {
6174 global canvx0 xspc1 xspc2
6176 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6177 if {$i > 0 && $i == $level} {
6178 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6179 } elseif {$i > $level} {
6180 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6182 return $x
6185 proc show_status {msg} {
6186 global canv fgcolor
6188 clear_display
6189 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6190 -tags text -fill $fgcolor
6193 # Don't change the text pane cursor if it is currently the hand cursor,
6194 # showing that we are over a sha1 ID link.
6195 proc settextcursor {c} {
6196 global ctext curtextcursor
6198 if {[$ctext cget -cursor] == $curtextcursor} {
6199 $ctext config -cursor $c
6201 set curtextcursor $c
6204 proc nowbusy {what {name {}}} {
6205 global isbusy busyname statusw
6207 if {[array names isbusy] eq {}} {
6208 . config -cursor watch
6209 settextcursor watch
6211 set isbusy($what) 1
6212 set busyname($what) $name
6213 if {$name ne {}} {
6214 $statusw conf -text $name
6218 proc notbusy {what} {
6219 global isbusy maincursor textcursor busyname statusw
6221 catch {
6222 unset isbusy($what)
6223 if {$busyname($what) ne {} &&
6224 [$statusw cget -text] eq $busyname($what)} {
6225 $statusw conf -text {}
6228 if {[array names isbusy] eq {}} {
6229 . config -cursor $maincursor
6230 settextcursor $textcursor
6234 proc findmatches {f} {
6235 global findtype findstring
6236 if {$findtype == [mc "Regexp"]} {
6237 set matches [regexp -indices -all -inline $findstring $f]
6238 } else {
6239 set fs $findstring
6240 if {$findtype == [mc "IgnCase"]} {
6241 set f [string tolower $f]
6242 set fs [string tolower $fs]
6244 set matches {}
6245 set i 0
6246 set l [string length $fs]
6247 while {[set j [string first $fs $f $i]] >= 0} {
6248 lappend matches [list $j [expr {$j+$l-1}]]
6249 set i [expr {$j + $l}]
6252 return $matches
6255 proc dofind {{dirn 1} {wrap 1}} {
6256 global findstring findstartline findcurline selectedline numcommits
6257 global gdttype filehighlight fh_serial find_dirn findallowwrap
6259 if {[info exists find_dirn]} {
6260 if {$find_dirn == $dirn} return
6261 stopfinding
6263 focus .
6264 if {$findstring eq {} || $numcommits == 0} return
6265 if {$selectedline eq {}} {
6266 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6267 } else {
6268 set findstartline $selectedline
6270 set findcurline $findstartline
6271 nowbusy finding [mc "Searching"]
6272 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6273 after cancel do_file_hl $fh_serial
6274 do_file_hl $fh_serial
6276 set find_dirn $dirn
6277 set findallowwrap $wrap
6278 run findmore
6281 proc stopfinding {} {
6282 global find_dirn findcurline fprogcoord
6284 if {[info exists find_dirn]} {
6285 unset find_dirn
6286 unset findcurline
6287 notbusy finding
6288 set fprogcoord 0
6289 adjustprogress
6291 stopblaming
6294 proc findmore {} {
6295 global commitdata commitinfo numcommits findpattern findloc
6296 global findstartline findcurline findallowwrap
6297 global find_dirn gdttype fhighlights fprogcoord
6298 global curview varcorder vrownum varccommits vrowmod
6300 if {![info exists find_dirn]} {
6301 return 0
6303 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6304 set l $findcurline
6305 set moretodo 0
6306 if {$find_dirn > 0} {
6307 incr l
6308 if {$l >= $numcommits} {
6309 set l 0
6311 if {$l <= $findstartline} {
6312 set lim [expr {$findstartline + 1}]
6313 } else {
6314 set lim $numcommits
6315 set moretodo $findallowwrap
6317 } else {
6318 if {$l == 0} {
6319 set l $numcommits
6321 incr l -1
6322 if {$l >= $findstartline} {
6323 set lim [expr {$findstartline - 1}]
6324 } else {
6325 set lim -1
6326 set moretodo $findallowwrap
6329 set n [expr {($lim - $l) * $find_dirn}]
6330 if {$n > 500} {
6331 set n 500
6332 set moretodo 1
6334 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6335 update_arcrows $curview
6337 set found 0
6338 set domore 1
6339 set ai [bsearch $vrownum($curview) $l]
6340 set a [lindex $varcorder($curview) $ai]
6341 set arow [lindex $vrownum($curview) $ai]
6342 set ids [lindex $varccommits($curview,$a)]
6343 set arowend [expr {$arow + [llength $ids]}]
6344 if {$gdttype eq [mc "containing:"]} {
6345 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6346 if {$l < $arow || $l >= $arowend} {
6347 incr ai $find_dirn
6348 set a [lindex $varcorder($curview) $ai]
6349 set arow [lindex $vrownum($curview) $ai]
6350 set ids [lindex $varccommits($curview,$a)]
6351 set arowend [expr {$arow + [llength $ids]}]
6353 set id [lindex $ids [expr {$l - $arow}]]
6354 # shouldn't happen unless git log doesn't give all the commits...
6355 if {![info exists commitdata($id)] ||
6356 ![doesmatch $commitdata($id)]} {
6357 continue
6359 if {![info exists commitinfo($id)]} {
6360 getcommit $id
6362 set info $commitinfo($id)
6363 foreach f $info ty $fldtypes {
6364 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6365 [doesmatch $f]} {
6366 set found 1
6367 break
6370 if {$found} break
6372 } else {
6373 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6374 if {$l < $arow || $l >= $arowend} {
6375 incr ai $find_dirn
6376 set a [lindex $varcorder($curview) $ai]
6377 set arow [lindex $vrownum($curview) $ai]
6378 set ids [lindex $varccommits($curview,$a)]
6379 set arowend [expr {$arow + [llength $ids]}]
6381 set id [lindex $ids [expr {$l - $arow}]]
6382 if {![info exists fhighlights($id)]} {
6383 # this sets fhighlights($id) to -1
6384 askfilehighlight $l $id
6386 if {$fhighlights($id) > 0} {
6387 set found $domore
6388 break
6390 if {$fhighlights($id) < 0} {
6391 if {$domore} {
6392 set domore 0
6393 set findcurline [expr {$l - $find_dirn}]
6398 if {$found || ($domore && !$moretodo)} {
6399 unset findcurline
6400 unset find_dirn
6401 notbusy finding
6402 set fprogcoord 0
6403 adjustprogress
6404 if {$found} {
6405 findselectline $l
6406 } else {
6407 bell
6409 return 0
6411 if {!$domore} {
6412 flushhighlights
6413 } else {
6414 set findcurline [expr {$l - $find_dirn}]
6416 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6417 if {$n < 0} {
6418 incr n $numcommits
6420 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6421 adjustprogress
6422 return $domore
6425 proc findselectline {l} {
6426 global findloc commentend ctext findcurline markingmatches gdttype
6428 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6429 set findcurline $l
6430 selectline $l 1
6431 if {$markingmatches &&
6432 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6433 # highlight the matches in the comments
6434 set f [$ctext get 1.0 $commentend]
6435 set matches [findmatches $f]
6436 foreach match $matches {
6437 set start [lindex $match 0]
6438 set end [expr {[lindex $match 1] + 1}]
6439 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6442 drawvisible
6445 # mark the bits of a headline or author that match a find string
6446 proc markmatches {canv l str tag matches font row} {
6447 global selectedline
6449 set bbox [$canv bbox $tag]
6450 set x0 [lindex $bbox 0]
6451 set y0 [lindex $bbox 1]
6452 set y1 [lindex $bbox 3]
6453 foreach match $matches {
6454 set start [lindex $match 0]
6455 set end [lindex $match 1]
6456 if {$start > $end} continue
6457 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6458 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6459 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6460 [expr {$x0+$xlen+2}] $y1 \
6461 -outline {} -tags [list match$l matches] -fill yellow]
6462 $canv lower $t
6463 if {$row == $selectedline} {
6464 $canv raise $t secsel
6469 proc unmarkmatches {} {
6470 global markingmatches
6472 allcanvs delete matches
6473 set markingmatches 0
6474 stopfinding
6477 proc selcanvline {w x y} {
6478 global canv canvy0 ctext linespc
6479 global rowtextx
6480 set ymax [lindex [$canv cget -scrollregion] 3]
6481 if {$ymax == {}} return
6482 set yfrac [lindex [$canv yview] 0]
6483 set y [expr {$y + $yfrac * $ymax}]
6484 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6485 if {$l < 0} {
6486 set l 0
6488 if {$w eq $canv} {
6489 set xmax [lindex [$canv cget -scrollregion] 2]
6490 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6491 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6493 unmarkmatches
6494 selectline $l 1
6497 proc commit_descriptor {p} {
6498 global commitinfo
6499 if {![info exists commitinfo($p)]} {
6500 getcommit $p
6502 set l "..."
6503 if {[llength $commitinfo($p)] > 1} {
6504 set l [lindex $commitinfo($p) 0]
6506 return "$p ($l)\n"
6509 # append some text to the ctext widget, and make any SHA1 ID
6510 # that we know about be a clickable link.
6511 proc appendwithlinks {text tags} {
6512 global ctext linknum curview
6514 set start [$ctext index "end - 1c"]
6515 $ctext insert end $text $tags
6516 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6517 foreach l $links {
6518 set s [lindex $l 0]
6519 set e [lindex $l 1]
6520 set linkid [string range $text $s $e]
6521 incr e
6522 $ctext tag delete link$linknum
6523 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6524 setlink $linkid link$linknum
6525 incr linknum
6529 proc setlink {id lk} {
6530 global curview ctext pendinglinks
6532 set known 0
6533 if {[string length $id] < 40} {
6534 set matches [longid $id]
6535 if {[llength $matches] > 0} {
6536 if {[llength $matches] > 1} return
6537 set known 1
6538 set id [lindex $matches 0]
6540 } else {
6541 set known [commitinview $id $curview]
6543 if {$known} {
6544 $ctext tag conf $lk -foreground blue -underline 1
6545 $ctext tag bind $lk <1> [list selbyid $id]
6546 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6547 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6548 } else {
6549 lappend pendinglinks($id) $lk
6550 interestedin $id {makelink %P}
6554 proc appendshortlink {id {pre {}} {post {}}} {
6555 global ctext linknum
6557 $ctext insert end $pre
6558 $ctext tag delete link$linknum
6559 $ctext insert end [string range $id 0 7] link$linknum
6560 $ctext insert end $post
6561 setlink $id link$linknum
6562 incr linknum
6565 proc makelink {id} {
6566 global pendinglinks
6568 if {![info exists pendinglinks($id)]} return
6569 foreach lk $pendinglinks($id) {
6570 setlink $id $lk
6572 unset pendinglinks($id)
6575 proc linkcursor {w inc} {
6576 global linkentercount curtextcursor
6578 if {[incr linkentercount $inc] > 0} {
6579 $w configure -cursor hand2
6580 } else {
6581 $w configure -cursor $curtextcursor
6582 if {$linkentercount < 0} {
6583 set linkentercount 0
6588 proc viewnextline {dir} {
6589 global canv linespc
6591 $canv delete hover
6592 set ymax [lindex [$canv cget -scrollregion] 3]
6593 set wnow [$canv yview]
6594 set wtop [expr {[lindex $wnow 0] * $ymax}]
6595 set newtop [expr {$wtop + $dir * $linespc}]
6596 if {$newtop < 0} {
6597 set newtop 0
6598 } elseif {$newtop > $ymax} {
6599 set newtop $ymax
6601 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6604 # add a list of tag or branch names at position pos
6605 # returns the number of names inserted
6606 proc appendrefs {pos ids var} {
6607 global ctext linknum curview $var maxrefs
6609 if {[catch {$ctext index $pos}]} {
6610 return 0
6612 $ctext conf -state normal
6613 $ctext delete $pos "$pos lineend"
6614 set tags {}
6615 foreach id $ids {
6616 foreach tag [set $var\($id\)] {
6617 lappend tags [list $tag $id]
6620 if {[llength $tags] > $maxrefs} {
6621 $ctext insert $pos "[mc "many"] ([llength $tags])"
6622 } else {
6623 set tags [lsort -index 0 -decreasing $tags]
6624 set sep {}
6625 foreach ti $tags {
6626 set id [lindex $ti 1]
6627 set lk link$linknum
6628 incr linknum
6629 $ctext tag delete $lk
6630 $ctext insert $pos $sep
6631 $ctext insert $pos [lindex $ti 0] $lk
6632 setlink $id $lk
6633 set sep ", "
6636 $ctext conf -state disabled
6637 return [llength $tags]
6640 # called when we have finished computing the nearby tags
6641 proc dispneartags {delay} {
6642 global selectedline currentid showneartags tagphase
6644 if {$selectedline eq {} || !$showneartags} return
6645 after cancel dispnexttag
6646 if {$delay} {
6647 after 200 dispnexttag
6648 set tagphase -1
6649 } else {
6650 after idle dispnexttag
6651 set tagphase 0
6655 proc dispnexttag {} {
6656 global selectedline currentid showneartags tagphase ctext
6658 if {$selectedline eq {} || !$showneartags} return
6659 switch -- $tagphase {
6661 set dtags [desctags $currentid]
6662 if {$dtags ne {}} {
6663 appendrefs precedes $dtags idtags
6667 set atags [anctags $currentid]
6668 if {$atags ne {}} {
6669 appendrefs follows $atags idtags
6673 set dheads [descheads $currentid]
6674 if {$dheads ne {}} {
6675 if {[appendrefs branch $dheads idheads] > 1
6676 && [$ctext get "branch -3c"] eq "h"} {
6677 # turn "Branch" into "Branches"
6678 $ctext conf -state normal
6679 $ctext insert "branch -2c" "es"
6680 $ctext conf -state disabled
6685 if {[incr tagphase] <= 2} {
6686 after idle dispnexttag
6690 proc make_secsel {id} {
6691 global linehtag linentag linedtag canv canv2 canv3
6693 if {![info exists linehtag($id)]} return
6694 $canv delete secsel
6695 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6696 -tags secsel -fill [$canv cget -selectbackground]]
6697 $canv lower $t
6698 $canv2 delete secsel
6699 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6700 -tags secsel -fill [$canv2 cget -selectbackground]]
6701 $canv2 lower $t
6702 $canv3 delete secsel
6703 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6704 -tags secsel -fill [$canv3 cget -selectbackground]]
6705 $canv3 lower $t
6708 proc make_idmark {id} {
6709 global linehtag canv fgcolor
6711 if {![info exists linehtag($id)]} return
6712 $canv delete markid
6713 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6714 -tags markid -outline $fgcolor]
6715 $canv raise $t
6718 proc selectline {l isnew {desired_loc {}}} {
6719 global canv ctext commitinfo selectedline
6720 global canvy0 linespc parents children curview
6721 global currentid sha1entry
6722 global commentend idtags linknum
6723 global mergemax numcommits pending_select
6724 global cmitmode showneartags allcommits
6725 global targetrow targetid lastscrollrows
6726 global autoselect jump_to_here
6728 catch {unset pending_select}
6729 $canv delete hover
6730 normalline
6731 unsel_reflist
6732 stopfinding
6733 if {$l < 0 || $l >= $numcommits} return
6734 set id [commitonrow $l]
6735 set targetid $id
6736 set targetrow $l
6737 set selectedline $l
6738 set currentid $id
6739 if {$lastscrollrows < $numcommits} {
6740 setcanvscroll
6743 set y [expr {$canvy0 + $l * $linespc}]
6744 set ymax [lindex [$canv cget -scrollregion] 3]
6745 set ytop [expr {$y - $linespc - 1}]
6746 set ybot [expr {$y + $linespc + 1}]
6747 set wnow [$canv yview]
6748 set wtop [expr {[lindex $wnow 0] * $ymax}]
6749 set wbot [expr {[lindex $wnow 1] * $ymax}]
6750 set wh [expr {$wbot - $wtop}]
6751 set newtop $wtop
6752 if {$ytop < $wtop} {
6753 if {$ybot < $wtop} {
6754 set newtop [expr {$y - $wh / 2.0}]
6755 } else {
6756 set newtop $ytop
6757 if {$newtop > $wtop - $linespc} {
6758 set newtop [expr {$wtop - $linespc}]
6761 } elseif {$ybot > $wbot} {
6762 if {$ytop > $wbot} {
6763 set newtop [expr {$y - $wh / 2.0}]
6764 } else {
6765 set newtop [expr {$ybot - $wh}]
6766 if {$newtop < $wtop + $linespc} {
6767 set newtop [expr {$wtop + $linespc}]
6771 if {$newtop != $wtop} {
6772 if {$newtop < 0} {
6773 set newtop 0
6775 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6776 drawvisible
6779 make_secsel $id
6781 if {$isnew} {
6782 addtohistory [list selbyid $id]
6785 $sha1entry delete 0 end
6786 $sha1entry insert 0 $id
6787 if {$autoselect} {
6788 $sha1entry selection from 0
6789 $sha1entry selection to end
6791 rhighlight_sel $id
6793 $ctext conf -state normal
6794 clear_ctext
6795 set linknum 0
6796 if {![info exists commitinfo($id)]} {
6797 getcommit $id
6799 set info $commitinfo($id)
6800 set date [formatdate [lindex $info 2]]
6801 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6802 set date [formatdate [lindex $info 4]]
6803 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6804 if {[info exists idtags($id)]} {
6805 $ctext insert end [mc "Tags:"]
6806 foreach tag $idtags($id) {
6807 $ctext insert end " $tag"
6809 $ctext insert end "\n"
6812 set headers {}
6813 set olds $parents($curview,$id)
6814 if {[llength $olds] > 1} {
6815 set np 0
6816 foreach p $olds {
6817 if {$np >= $mergemax} {
6818 set tag mmax
6819 } else {
6820 set tag m$np
6822 $ctext insert end "[mc "Parent"]: " $tag
6823 appendwithlinks [commit_descriptor $p] {}
6824 incr np
6826 } else {
6827 foreach p $olds {
6828 append headers "[mc "Parent"]: [commit_descriptor $p]"
6832 foreach c $children($curview,$id) {
6833 append headers "[mc "Child"]: [commit_descriptor $c]"
6836 # make anything that looks like a SHA1 ID be a clickable link
6837 appendwithlinks $headers {}
6838 if {$showneartags} {
6839 if {![info exists allcommits]} {
6840 getallcommits
6842 $ctext insert end "[mc "Branch"]: "
6843 $ctext mark set branch "end -1c"
6844 $ctext mark gravity branch left
6845 $ctext insert end "\n[mc "Follows"]: "
6846 $ctext mark set follows "end -1c"
6847 $ctext mark gravity follows left
6848 $ctext insert end "\n[mc "Precedes"]: "
6849 $ctext mark set precedes "end -1c"
6850 $ctext mark gravity precedes left
6851 $ctext insert end "\n"
6852 dispneartags 1
6854 $ctext insert end "\n"
6855 set comment [lindex $info 5]
6856 if {[string first "\r" $comment] >= 0} {
6857 set comment [string map {"\r" "\n "} $comment]
6859 appendwithlinks $comment {comment}
6861 $ctext tag remove found 1.0 end
6862 $ctext conf -state disabled
6863 set commentend [$ctext index "end - 1c"]
6865 set jump_to_here $desired_loc
6866 init_flist [mc "Comments"]
6867 if {$cmitmode eq "tree"} {
6868 gettree $id
6869 } elseif {[llength $olds] <= 1} {
6870 startdiff $id
6871 } else {
6872 mergediff $id
6876 proc selfirstline {} {
6877 unmarkmatches
6878 selectline 0 1
6881 proc sellastline {} {
6882 global numcommits
6883 unmarkmatches
6884 set l [expr {$numcommits - 1}]
6885 selectline $l 1
6888 proc selnextline {dir} {
6889 global selectedline
6890 focus .
6891 if {$selectedline eq {}} return
6892 set l [expr {$selectedline + $dir}]
6893 unmarkmatches
6894 selectline $l 1
6897 proc selnextpage {dir} {
6898 global canv linespc selectedline numcommits
6900 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6901 if {$lpp < 1} {
6902 set lpp 1
6904 allcanvs yview scroll [expr {$dir * $lpp}] units
6905 drawvisible
6906 if {$selectedline eq {}} return
6907 set l [expr {$selectedline + $dir * $lpp}]
6908 if {$l < 0} {
6909 set l 0
6910 } elseif {$l >= $numcommits} {
6911 set l [expr $numcommits - 1]
6913 unmarkmatches
6914 selectline $l 1
6917 proc unselectline {} {
6918 global selectedline currentid
6920 set selectedline {}
6921 catch {unset currentid}
6922 allcanvs delete secsel
6923 rhighlight_none
6926 proc reselectline {} {
6927 global selectedline
6929 if {$selectedline ne {}} {
6930 selectline $selectedline 0
6934 proc addtohistory {cmd} {
6935 global history historyindex curview
6937 set elt [list $curview $cmd]
6938 if {$historyindex > 0
6939 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6940 return
6943 if {$historyindex < [llength $history]} {
6944 set history [lreplace $history $historyindex end $elt]
6945 } else {
6946 lappend history $elt
6948 incr historyindex
6949 if {$historyindex > 1} {
6950 .tf.bar.leftbut conf -state normal
6951 } else {
6952 .tf.bar.leftbut conf -state disabled
6954 .tf.bar.rightbut conf -state disabled
6957 proc godo {elt} {
6958 global curview
6960 set view [lindex $elt 0]
6961 set cmd [lindex $elt 1]
6962 if {$curview != $view} {
6963 showview $view
6965 eval $cmd
6968 proc goback {} {
6969 global history historyindex
6970 focus .
6972 if {$historyindex > 1} {
6973 incr historyindex -1
6974 godo [lindex $history [expr {$historyindex - 1}]]
6975 .tf.bar.rightbut conf -state normal
6977 if {$historyindex <= 1} {
6978 .tf.bar.leftbut conf -state disabled
6982 proc goforw {} {
6983 global history historyindex
6984 focus .
6986 if {$historyindex < [llength $history]} {
6987 set cmd [lindex $history $historyindex]
6988 incr historyindex
6989 godo $cmd
6990 .tf.bar.leftbut conf -state normal
6992 if {$historyindex >= [llength $history]} {
6993 .tf.bar.rightbut conf -state disabled
6997 proc gettree {id} {
6998 global treefilelist treeidlist diffids diffmergeid treepending
6999 global nullid nullid2
7001 set diffids $id
7002 catch {unset diffmergeid}
7003 if {![info exists treefilelist($id)]} {
7004 if {![info exists treepending]} {
7005 if {$id eq $nullid} {
7006 set cmd [list | git ls-files]
7007 } elseif {$id eq $nullid2} {
7008 set cmd [list | git ls-files --stage -t]
7009 } else {
7010 set cmd [list | git ls-tree -r $id]
7012 if {[catch {set gtf [open $cmd r]}]} {
7013 return
7015 set treepending $id
7016 set treefilelist($id) {}
7017 set treeidlist($id) {}
7018 fconfigure $gtf -blocking 0 -encoding binary
7019 filerun $gtf [list gettreeline $gtf $id]
7021 } else {
7022 setfilelist $id
7026 proc gettreeline {gtf id} {
7027 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7029 set nl 0
7030 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7031 if {$diffids eq $nullid} {
7032 set fname $line
7033 } else {
7034 set i [string first "\t" $line]
7035 if {$i < 0} continue
7036 set fname [string range $line [expr {$i+1}] end]
7037 set line [string range $line 0 [expr {$i-1}]]
7038 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7039 set sha1 [lindex $line 2]
7040 lappend treeidlist($id) $sha1
7042 if {[string index $fname 0] eq "\""} {
7043 set fname [lindex $fname 0]
7045 set fname [encoding convertfrom $fname]
7046 lappend treefilelist($id) $fname
7048 if {![eof $gtf]} {
7049 return [expr {$nl >= 1000? 2: 1}]
7051 close $gtf
7052 unset treepending
7053 if {$cmitmode ne "tree"} {
7054 if {![info exists diffmergeid]} {
7055 gettreediffs $diffids
7057 } elseif {$id ne $diffids} {
7058 gettree $diffids
7059 } else {
7060 setfilelist $id
7062 return 0
7065 proc showfile {f} {
7066 global treefilelist treeidlist diffids nullid nullid2
7067 global ctext_file_names ctext_file_lines
7068 global ctext commentend
7070 set i [lsearch -exact $treefilelist($diffids) $f]
7071 if {$i < 0} {
7072 puts "oops, $f not in list for id $diffids"
7073 return
7075 if {$diffids eq $nullid} {
7076 if {[catch {set bf [open $f r]} err]} {
7077 puts "oops, can't read $f: $err"
7078 return
7080 } else {
7081 set blob [lindex $treeidlist($diffids) $i]
7082 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7083 puts "oops, error reading blob $blob: $err"
7084 return
7087 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7088 filerun $bf [list getblobline $bf $diffids]
7089 $ctext config -state normal
7090 clear_ctext $commentend
7091 lappend ctext_file_names $f
7092 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7093 $ctext insert end "\n"
7094 $ctext insert end "$f\n" filesep
7095 $ctext config -state disabled
7096 $ctext yview $commentend
7097 settabs 0
7100 proc getblobline {bf id} {
7101 global diffids cmitmode ctext
7103 if {$id ne $diffids || $cmitmode ne "tree"} {
7104 catch {close $bf}
7105 return 0
7107 $ctext config -state normal
7108 set nl 0
7109 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7110 $ctext insert end "$line\n"
7112 if {[eof $bf]} {
7113 global jump_to_here ctext_file_names commentend
7115 # delete last newline
7116 $ctext delete "end - 2c" "end - 1c"
7117 close $bf
7118 if {$jump_to_here ne {} &&
7119 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7120 set lnum [expr {[lindex $jump_to_here 1] +
7121 [lindex [split $commentend .] 0]}]
7122 mark_ctext_line $lnum
7124 return 0
7126 $ctext config -state disabled
7127 return [expr {$nl >= 1000? 2: 1}]
7130 proc mark_ctext_line {lnum} {
7131 global ctext markbgcolor
7133 $ctext tag delete omark
7134 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7135 $ctext tag conf omark -background $markbgcolor
7136 $ctext see $lnum.0
7139 proc mergediff {id} {
7140 global diffmergeid
7141 global diffids treediffs
7142 global parents curview
7144 set diffmergeid $id
7145 set diffids $id
7146 set treediffs($id) {}
7147 set np [llength $parents($curview,$id)]
7148 settabs $np
7149 getblobdiffs $id
7152 proc startdiff {ids} {
7153 global treediffs diffids treepending diffmergeid nullid nullid2
7155 settabs 1
7156 set diffids $ids
7157 catch {unset diffmergeid}
7158 if {![info exists treediffs($ids)] ||
7159 [lsearch -exact $ids $nullid] >= 0 ||
7160 [lsearch -exact $ids $nullid2] >= 0} {
7161 if {![info exists treepending]} {
7162 gettreediffs $ids
7164 } else {
7165 addtocflist $ids
7169 proc path_filter {filter name} {
7170 foreach p $filter {
7171 set l [string length $p]
7172 if {[string index $p end] eq "/"} {
7173 if {[string compare -length $l $p $name] == 0} {
7174 return 1
7176 } else {
7177 if {[string compare -length $l $p $name] == 0 &&
7178 ([string length $name] == $l ||
7179 [string index $name $l] eq "/")} {
7180 return 1
7184 return 0
7187 proc addtocflist {ids} {
7188 global treediffs
7190 add_flist $treediffs($ids)
7191 getblobdiffs $ids
7194 proc diffcmd {ids flags} {
7195 global nullid nullid2
7197 set i [lsearch -exact $ids $nullid]
7198 set j [lsearch -exact $ids $nullid2]
7199 if {$i >= 0} {
7200 if {[llength $ids] > 1 && $j < 0} {
7201 # comparing working directory with some specific revision
7202 set cmd [concat | git diff-index $flags]
7203 if {$i == 0} {
7204 lappend cmd -R [lindex $ids 1]
7205 } else {
7206 lappend cmd [lindex $ids 0]
7208 } else {
7209 # comparing working directory with index
7210 set cmd [concat | git diff-files $flags]
7211 if {$j == 1} {
7212 lappend cmd -R
7215 } elseif {$j >= 0} {
7216 set cmd [concat | git diff-index --cached $flags]
7217 if {[llength $ids] > 1} {
7218 # comparing index with specific revision
7219 if {$i == 0} {
7220 lappend cmd -R [lindex $ids 1]
7221 } else {
7222 lappend cmd [lindex $ids 0]
7224 } else {
7225 # comparing index with HEAD
7226 lappend cmd HEAD
7228 } else {
7229 set cmd [concat | git diff-tree -r $flags $ids]
7231 return $cmd
7234 proc gettreediffs {ids} {
7235 global treediff treepending
7237 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7239 set treepending $ids
7240 set treediff {}
7241 fconfigure $gdtf -blocking 0 -encoding binary
7242 filerun $gdtf [list gettreediffline $gdtf $ids]
7245 proc gettreediffline {gdtf ids} {
7246 global treediff treediffs treepending diffids diffmergeid
7247 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7249 set nr 0
7250 set sublist {}
7251 set max 1000
7252 if {$perfile_attrs} {
7253 # cache_gitattr is slow, and even slower on win32 where we
7254 # have to invoke it for only about 30 paths at a time
7255 set max 500
7256 if {[tk windowingsystem] == "win32"} {
7257 set max 120
7260 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7261 set i [string first "\t" $line]
7262 if {$i >= 0} {
7263 set file [string range $line [expr {$i+1}] end]
7264 if {[string index $file 0] eq "\""} {
7265 set file [lindex $file 0]
7267 set file [encoding convertfrom $file]
7268 if {$file ne [lindex $treediff end]} {
7269 lappend treediff $file
7270 lappend sublist $file
7274 if {$perfile_attrs} {
7275 cache_gitattr encoding $sublist
7277 if {![eof $gdtf]} {
7278 return [expr {$nr >= $max? 2: 1}]
7280 close $gdtf
7281 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7282 set flist {}
7283 foreach f $treediff {
7284 if {[path_filter $vfilelimit($curview) $f]} {
7285 lappend flist $f
7288 set treediffs($ids) $flist
7289 } else {
7290 set treediffs($ids) $treediff
7292 unset treepending
7293 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7294 gettree $diffids
7295 } elseif {$ids != $diffids} {
7296 if {![info exists diffmergeid]} {
7297 gettreediffs $diffids
7299 } else {
7300 addtocflist $ids
7302 return 0
7305 # empty string or positive integer
7306 proc diffcontextvalidate {v} {
7307 return [regexp {^(|[1-9][0-9]*)$} $v]
7310 proc diffcontextchange {n1 n2 op} {
7311 global diffcontextstring diffcontext
7313 if {[string is integer -strict $diffcontextstring]} {
7314 if {$diffcontextstring >= 0} {
7315 set diffcontext $diffcontextstring
7316 reselectline
7321 proc changeignorespace {} {
7322 reselectline
7325 proc getblobdiffs {ids} {
7326 global blobdifffd diffids env
7327 global diffinhdr treediffs
7328 global diffcontext
7329 global ignorespace
7330 global limitdiffs vfilelimit curview
7331 global diffencoding targetline diffnparents
7332 global git_version
7334 set textconv {}
7335 if {[package vcompare $git_version "1.6.1"] >= 0} {
7336 set textconv "--textconv"
7338 set cmd [diffcmd $ids "-p $textconv -C --cc --no-commit-id -U$diffcontext"]
7339 if {$ignorespace} {
7340 append cmd " -w"
7342 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7343 set cmd [concat $cmd -- $vfilelimit($curview)]
7345 if {[catch {set bdf [open $cmd r]} err]} {
7346 error_popup [mc "Error getting diffs: %s" $err]
7347 return
7349 set targetline {}
7350 set diffnparents 0
7351 set diffinhdr 0
7352 set diffencoding [get_path_encoding {}]
7353 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7354 set blobdifffd($ids) $bdf
7355 filerun $bdf [list getblobdiffline $bdf $diffids]
7358 proc setinlist {var i val} {
7359 global $var
7361 while {[llength [set $var]] < $i} {
7362 lappend $var {}
7364 if {[llength [set $var]] == $i} {
7365 lappend $var $val
7366 } else {
7367 lset $var $i $val
7371 proc makediffhdr {fname ids} {
7372 global ctext curdiffstart treediffs diffencoding
7373 global ctext_file_names jump_to_here targetline diffline
7375 set fname [encoding convertfrom $fname]
7376 set diffencoding [get_path_encoding $fname]
7377 set i [lsearch -exact $treediffs($ids) $fname]
7378 if {$i >= 0} {
7379 setinlist difffilestart $i $curdiffstart
7381 lset ctext_file_names end $fname
7382 set l [expr {(78 - [string length $fname]) / 2}]
7383 set pad [string range "----------------------------------------" 1 $l]
7384 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7385 set targetline {}
7386 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7387 set targetline [lindex $jump_to_here 1]
7389 set diffline 0
7392 proc getblobdiffline {bdf ids} {
7393 global diffids blobdifffd ctext curdiffstart
7394 global diffnexthead diffnextnote difffilestart
7395 global ctext_file_names ctext_file_lines
7396 global diffinhdr treediffs mergemax diffnparents
7397 global diffencoding jump_to_here targetline diffline
7399 set nr 0
7400 $ctext conf -state normal
7401 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7402 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7403 close $bdf
7404 return 0
7406 if {![string compare -length 5 "diff " $line]} {
7407 if {![regexp {^diff (--cc|--git) } $line m type]} {
7408 set line [encoding convertfrom $line]
7409 $ctext insert end "$line\n" hunksep
7410 continue
7412 # start of a new file
7413 set diffinhdr 1
7414 $ctext insert end "\n"
7415 set curdiffstart [$ctext index "end - 1c"]
7416 lappend ctext_file_names ""
7417 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7418 $ctext insert end "\n" filesep
7420 if {$type eq "--cc"} {
7421 # start of a new file in a merge diff
7422 set fname [string range $line 10 end]
7423 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7424 lappend treediffs($ids) $fname
7425 add_flist [list $fname]
7428 } else {
7429 set line [string range $line 11 end]
7430 # If the name hasn't changed the length will be odd,
7431 # the middle char will be a space, and the two bits either
7432 # side will be a/name and b/name, or "a/name" and "b/name".
7433 # If the name has changed we'll get "rename from" and
7434 # "rename to" or "copy from" and "copy to" lines following
7435 # this, and we'll use them to get the filenames.
7436 # This complexity is necessary because spaces in the
7437 # filename(s) don't get escaped.
7438 set l [string length $line]
7439 set i [expr {$l / 2}]
7440 if {!(($l & 1) && [string index $line $i] eq " " &&
7441 [string range $line 2 [expr {$i - 1}]] eq \
7442 [string range $line [expr {$i + 3}] end])} {
7443 continue
7445 # unescape if quoted and chop off the a/ from the front
7446 if {[string index $line 0] eq "\""} {
7447 set fname [string range [lindex $line 0] 2 end]
7448 } else {
7449 set fname [string range $line 2 [expr {$i - 1}]]
7452 makediffhdr $fname $ids
7454 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7455 set fname [encoding convertfrom [string range $line 16 end]]
7456 $ctext insert end "\n"
7457 set curdiffstart [$ctext index "end - 1c"]
7458 lappend ctext_file_names $fname
7459 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7460 $ctext insert end "$line\n" filesep
7461 set i [lsearch -exact $treediffs($ids) $fname]
7462 if {$i >= 0} {
7463 setinlist difffilestart $i $curdiffstart
7466 } elseif {![string compare -length 2 "@@" $line]} {
7467 regexp {^@@+} $line ats
7468 set line [encoding convertfrom $diffencoding $line]
7469 $ctext insert end "$line\n" hunksep
7470 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7471 set diffline $nl
7473 set diffnparents [expr {[string length $ats] - 1}]
7474 set diffinhdr 0
7476 } elseif {$diffinhdr} {
7477 if {![string compare -length 12 "rename from " $line]} {
7478 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7479 if {[string index $fname 0] eq "\""} {
7480 set fname [lindex $fname 0]
7482 set fname [encoding convertfrom $fname]
7483 set i [lsearch -exact $treediffs($ids) $fname]
7484 if {$i >= 0} {
7485 setinlist difffilestart $i $curdiffstart
7487 } elseif {![string compare -length 10 $line "rename to "] ||
7488 ![string compare -length 8 $line "copy to "]} {
7489 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7490 if {[string index $fname 0] eq "\""} {
7491 set fname [lindex $fname 0]
7493 makediffhdr $fname $ids
7494 } elseif {[string compare -length 3 $line "---"] == 0} {
7495 # do nothing
7496 continue
7497 } elseif {[string compare -length 3 $line "+++"] == 0} {
7498 set diffinhdr 0
7499 continue
7501 $ctext insert end "$line\n" filesep
7503 } else {
7504 set line [string map {\x1A ^Z} \
7505 [encoding convertfrom $diffencoding $line]]
7506 # parse the prefix - one ' ', '-' or '+' for each parent
7507 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7508 set tag [expr {$diffnparents > 1? "m": "d"}]
7509 if {[string trim $prefix " -+"] eq {}} {
7510 # prefix only has " ", "-" and "+" in it: normal diff line
7511 set num [string first "-" $prefix]
7512 if {$num >= 0} {
7513 # removed line, first parent with line is $num
7514 if {$num >= $mergemax} {
7515 set num "max"
7517 $ctext insert end "$line\n" $tag$num
7518 } else {
7519 set tags {}
7520 if {[string first "+" $prefix] >= 0} {
7521 # added line
7522 lappend tags ${tag}result
7523 if {$diffnparents > 1} {
7524 set num [string first " " $prefix]
7525 if {$num >= 0} {
7526 if {$num >= $mergemax} {
7527 set num "max"
7529 lappend tags m$num
7533 if {$targetline ne {}} {
7534 if {$diffline == $targetline} {
7535 set seehere [$ctext index "end - 1 chars"]
7536 set targetline {}
7537 } else {
7538 incr diffline
7541 $ctext insert end "$line\n" $tags
7543 } else {
7544 # "\ No newline at end of file",
7545 # or something else we don't recognize
7546 $ctext insert end "$line\n" hunksep
7550 if {[info exists seehere]} {
7551 mark_ctext_line [lindex [split $seehere .] 0]
7553 $ctext conf -state disabled
7554 if {[eof $bdf]} {
7555 close $bdf
7556 return 0
7558 return [expr {$nr >= 1000? 2: 1}]
7561 proc changediffdisp {} {
7562 global ctext diffelide
7564 $ctext tag conf d0 -elide [lindex $diffelide 0]
7565 $ctext tag conf dresult -elide [lindex $diffelide 1]
7568 proc highlightfile {loc cline} {
7569 global ctext cflist cflist_top
7571 $ctext yview $loc
7572 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7573 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7574 $cflist see $cline.0
7575 set cflist_top $cline
7578 proc prevfile {} {
7579 global difffilestart ctext cmitmode
7581 if {$cmitmode eq "tree"} return
7582 set prev 0.0
7583 set prevline 1
7584 set here [$ctext index @0,0]
7585 foreach loc $difffilestart {
7586 if {[$ctext compare $loc >= $here]} {
7587 highlightfile $prev $prevline
7588 return
7590 set prev $loc
7591 incr prevline
7593 highlightfile $prev $prevline
7596 proc nextfile {} {
7597 global difffilestart ctext cmitmode
7599 if {$cmitmode eq "tree"} return
7600 set here [$ctext index @0,0]
7601 set line 1
7602 foreach loc $difffilestart {
7603 incr line
7604 if {[$ctext compare $loc > $here]} {
7605 highlightfile $loc $line
7606 return
7611 proc clear_ctext {{first 1.0}} {
7612 global ctext smarktop smarkbot
7613 global ctext_file_names ctext_file_lines
7614 global pendinglinks
7616 set l [lindex [split $first .] 0]
7617 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7618 set smarktop $l
7620 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7621 set smarkbot $l
7623 $ctext delete $first end
7624 if {$first eq "1.0"} {
7625 catch {unset pendinglinks}
7627 set ctext_file_names {}
7628 set ctext_file_lines {}
7631 proc settabs {{firstab {}}} {
7632 global firsttabstop tabstop ctext have_tk85
7634 if {$firstab ne {} && $have_tk85} {
7635 set firsttabstop $firstab
7637 set w [font measure textfont "0"]
7638 if {$firsttabstop != 0} {
7639 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7640 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7641 } elseif {$have_tk85 || $tabstop != 8} {
7642 $ctext conf -tabs [expr {$tabstop * $w}]
7643 } else {
7644 $ctext conf -tabs {}
7648 proc incrsearch {name ix op} {
7649 global ctext searchstring searchdirn
7651 $ctext tag remove found 1.0 end
7652 if {[catch {$ctext index anchor}]} {
7653 # no anchor set, use start of selection, or of visible area
7654 set sel [$ctext tag ranges sel]
7655 if {$sel ne {}} {
7656 $ctext mark set anchor [lindex $sel 0]
7657 } elseif {$searchdirn eq "-forwards"} {
7658 $ctext mark set anchor @0,0
7659 } else {
7660 $ctext mark set anchor @0,[winfo height $ctext]
7663 if {$searchstring ne {}} {
7664 set here [$ctext search $searchdirn -- $searchstring anchor]
7665 if {$here ne {}} {
7666 $ctext see $here
7668 searchmarkvisible 1
7672 proc dosearch {} {
7673 global sstring ctext searchstring searchdirn
7675 focus $sstring
7676 $sstring icursor end
7677 set searchdirn -forwards
7678 if {$searchstring ne {}} {
7679 set sel [$ctext tag ranges sel]
7680 if {$sel ne {}} {
7681 set start "[lindex $sel 0] + 1c"
7682 } elseif {[catch {set start [$ctext index anchor]}]} {
7683 set start "@0,0"
7685 set match [$ctext search -count mlen -- $searchstring $start]
7686 $ctext tag remove sel 1.0 end
7687 if {$match eq {}} {
7688 bell
7689 return
7691 $ctext see $match
7692 set mend "$match + $mlen c"
7693 $ctext tag add sel $match $mend
7694 $ctext mark unset anchor
7698 proc dosearchback {} {
7699 global sstring ctext searchstring searchdirn
7701 focus $sstring
7702 $sstring icursor end
7703 set searchdirn -backwards
7704 if {$searchstring ne {}} {
7705 set sel [$ctext tag ranges sel]
7706 if {$sel ne {}} {
7707 set start [lindex $sel 0]
7708 } elseif {[catch {set start [$ctext index anchor]}]} {
7709 set start @0,[winfo height $ctext]
7711 set match [$ctext search -backwards -count ml -- $searchstring $start]
7712 $ctext tag remove sel 1.0 end
7713 if {$match eq {}} {
7714 bell
7715 return
7717 $ctext see $match
7718 set mend "$match + $ml c"
7719 $ctext tag add sel $match $mend
7720 $ctext mark unset anchor
7724 proc searchmark {first last} {
7725 global ctext searchstring
7727 set mend $first.0
7728 while {1} {
7729 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7730 if {$match eq {}} break
7731 set mend "$match + $mlen c"
7732 $ctext tag add found $match $mend
7736 proc searchmarkvisible {doall} {
7737 global ctext smarktop smarkbot
7739 set topline [lindex [split [$ctext index @0,0] .] 0]
7740 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7741 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7742 # no overlap with previous
7743 searchmark $topline $botline
7744 set smarktop $topline
7745 set smarkbot $botline
7746 } else {
7747 if {$topline < $smarktop} {
7748 searchmark $topline [expr {$smarktop-1}]
7749 set smarktop $topline
7751 if {$botline > $smarkbot} {
7752 searchmark [expr {$smarkbot+1}] $botline
7753 set smarkbot $botline
7758 proc scrolltext {f0 f1} {
7759 global searchstring
7761 .bleft.bottom.sb set $f0 $f1
7762 if {$searchstring ne {}} {
7763 searchmarkvisible 0
7767 proc setcoords {} {
7768 global linespc charspc canvx0 canvy0
7769 global xspc1 xspc2 lthickness
7771 set linespc [font metrics mainfont -linespace]
7772 set charspc [font measure mainfont "m"]
7773 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7774 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7775 set lthickness [expr {int($linespc / 9) + 1}]
7776 set xspc1(0) $linespc
7777 set xspc2 $linespc
7780 proc redisplay {} {
7781 global canv
7782 global selectedline
7784 set ymax [lindex [$canv cget -scrollregion] 3]
7785 if {$ymax eq {} || $ymax == 0} return
7786 set span [$canv yview]
7787 clear_display
7788 setcanvscroll
7789 allcanvs yview moveto [lindex $span 0]
7790 drawvisible
7791 if {$selectedline ne {}} {
7792 selectline $selectedline 0
7793 allcanvs yview moveto [lindex $span 0]
7797 proc parsefont {f n} {
7798 global fontattr
7800 set fontattr($f,family) [lindex $n 0]
7801 set s [lindex $n 1]
7802 if {$s eq {} || $s == 0} {
7803 set s 10
7804 } elseif {$s < 0} {
7805 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7807 set fontattr($f,size) $s
7808 set fontattr($f,weight) normal
7809 set fontattr($f,slant) roman
7810 foreach style [lrange $n 2 end] {
7811 switch -- $style {
7812 "normal" -
7813 "bold" {set fontattr($f,weight) $style}
7814 "roman" -
7815 "italic" {set fontattr($f,slant) $style}
7820 proc fontflags {f {isbold 0}} {
7821 global fontattr
7823 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7824 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7825 -slant $fontattr($f,slant)]
7828 proc fontname {f} {
7829 global fontattr
7831 set n [list $fontattr($f,family) $fontattr($f,size)]
7832 if {$fontattr($f,weight) eq "bold"} {
7833 lappend n "bold"
7835 if {$fontattr($f,slant) eq "italic"} {
7836 lappend n "italic"
7838 return $n
7841 proc incrfont {inc} {
7842 global mainfont textfont ctext canv cflist showrefstop
7843 global stopped entries fontattr
7845 unmarkmatches
7846 set s $fontattr(mainfont,size)
7847 incr s $inc
7848 if {$s < 1} {
7849 set s 1
7851 set fontattr(mainfont,size) $s
7852 font config mainfont -size $s
7853 font config mainfontbold -size $s
7854 set mainfont [fontname mainfont]
7855 set s $fontattr(textfont,size)
7856 incr s $inc
7857 if {$s < 1} {
7858 set s 1
7860 set fontattr(textfont,size) $s
7861 font config textfont -size $s
7862 font config textfontbold -size $s
7863 set textfont [fontname textfont]
7864 setcoords
7865 settabs
7866 redisplay
7869 proc clearsha1 {} {
7870 global sha1entry sha1string
7871 if {[string length $sha1string] == 40} {
7872 $sha1entry delete 0 end
7876 proc sha1change {n1 n2 op} {
7877 global sha1string currentid sha1but
7878 if {$sha1string == {}
7879 || ([info exists currentid] && $sha1string == $currentid)} {
7880 set state disabled
7881 } else {
7882 set state normal
7884 if {[$sha1but cget -state] == $state} return
7885 if {$state == "normal"} {
7886 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7887 } else {
7888 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7892 proc gotocommit {} {
7893 global sha1string tagids headids curview varcid
7895 if {$sha1string == {}
7896 || ([info exists currentid] && $sha1string == $currentid)} return
7897 if {[info exists tagids($sha1string)]} {
7898 set id $tagids($sha1string)
7899 } elseif {[info exists headids($sha1string)]} {
7900 set id $headids($sha1string)
7901 } else {
7902 set id [string tolower $sha1string]
7903 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7904 set matches [longid $id]
7905 if {$matches ne {}} {
7906 if {[llength $matches] > 1} {
7907 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7908 return
7910 set id [lindex $matches 0]
7912 } else {
7913 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
7914 error_popup [mc "Revision %s is not known" $sha1string]
7915 return
7919 if {[commitinview $id $curview]} {
7920 selectline [rowofcommit $id] 1
7921 return
7923 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7924 set msg [mc "SHA1 id %s is not known" $sha1string]
7925 } else {
7926 set msg [mc "Revision %s is not in the current view" $sha1string]
7928 error_popup $msg
7931 proc lineenter {x y id} {
7932 global hoverx hovery hoverid hovertimer
7933 global commitinfo canv
7935 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7936 set hoverx $x
7937 set hovery $y
7938 set hoverid $id
7939 if {[info exists hovertimer]} {
7940 after cancel $hovertimer
7942 set hovertimer [after 500 linehover]
7943 $canv delete hover
7946 proc linemotion {x y id} {
7947 global hoverx hovery hoverid hovertimer
7949 if {[info exists hoverid] && $id == $hoverid} {
7950 set hoverx $x
7951 set hovery $y
7952 if {[info exists hovertimer]} {
7953 after cancel $hovertimer
7955 set hovertimer [after 500 linehover]
7959 proc lineleave {id} {
7960 global hoverid hovertimer canv
7962 if {[info exists hoverid] && $id == $hoverid} {
7963 $canv delete hover
7964 if {[info exists hovertimer]} {
7965 after cancel $hovertimer
7966 unset hovertimer
7968 unset hoverid
7972 proc linehover {} {
7973 global hoverx hovery hoverid hovertimer
7974 global canv linespc lthickness
7975 global commitinfo
7977 set text [lindex $commitinfo($hoverid) 0]
7978 set ymax [lindex [$canv cget -scrollregion] 3]
7979 if {$ymax == {}} return
7980 set yfrac [lindex [$canv yview] 0]
7981 set x [expr {$hoverx + 2 * $linespc}]
7982 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7983 set x0 [expr {$x - 2 * $lthickness}]
7984 set y0 [expr {$y - 2 * $lthickness}]
7985 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7986 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7987 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7988 -fill \#ffff80 -outline black -width 1 -tags hover]
7989 $canv raise $t
7990 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7991 -font mainfont]
7992 $canv raise $t
7995 proc clickisonarrow {id y} {
7996 global lthickness
7998 set ranges [rowranges $id]
7999 set thresh [expr {2 * $lthickness + 6}]
8000 set n [expr {[llength $ranges] - 1}]
8001 for {set i 1} {$i < $n} {incr i} {
8002 set row [lindex $ranges $i]
8003 if {abs([yc $row] - $y) < $thresh} {
8004 return $i
8007 return {}
8010 proc arrowjump {id n y} {
8011 global canv
8013 # 1 <-> 2, 3 <-> 4, etc...
8014 set n [expr {(($n - 1) ^ 1) + 1}]
8015 set row [lindex [rowranges $id] $n]
8016 set yt [yc $row]
8017 set ymax [lindex [$canv cget -scrollregion] 3]
8018 if {$ymax eq {} || $ymax <= 0} return
8019 set view [$canv yview]
8020 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8021 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8022 if {$yfrac < 0} {
8023 set yfrac 0
8025 allcanvs yview moveto $yfrac
8028 proc lineclick {x y id isnew} {
8029 global ctext commitinfo children canv thickerline curview
8031 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8032 unmarkmatches
8033 unselectline
8034 normalline
8035 $canv delete hover
8036 # draw this line thicker than normal
8037 set thickerline $id
8038 drawlines $id
8039 if {$isnew} {
8040 set ymax [lindex [$canv cget -scrollregion] 3]
8041 if {$ymax eq {}} return
8042 set yfrac [lindex [$canv yview] 0]
8043 set y [expr {$y + $yfrac * $ymax}]
8045 set dirn [clickisonarrow $id $y]
8046 if {$dirn ne {}} {
8047 arrowjump $id $dirn $y
8048 return
8051 if {$isnew} {
8052 addtohistory [list lineclick $x $y $id 0]
8054 # fill the details pane with info about this line
8055 $ctext conf -state normal
8056 clear_ctext
8057 settabs 0
8058 $ctext insert end "[mc "Parent"]:\t"
8059 $ctext insert end $id link0
8060 setlink $id link0
8061 set info $commitinfo($id)
8062 $ctext insert end "\n\t[lindex $info 0]\n"
8063 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8064 set date [formatdate [lindex $info 2]]
8065 $ctext insert end "\t[mc "Date"]:\t$date\n"
8066 set kids $children($curview,$id)
8067 if {$kids ne {}} {
8068 $ctext insert end "\n[mc "Children"]:"
8069 set i 0
8070 foreach child $kids {
8071 incr i
8072 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8073 set info $commitinfo($child)
8074 $ctext insert end "\n\t"
8075 $ctext insert end $child link$i
8076 setlink $child link$i
8077 $ctext insert end "\n\t[lindex $info 0]"
8078 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8079 set date [formatdate [lindex $info 2]]
8080 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8083 $ctext conf -state disabled
8084 init_flist {}
8087 proc normalline {} {
8088 global thickerline
8089 if {[info exists thickerline]} {
8090 set id $thickerline
8091 unset thickerline
8092 drawlines $id
8096 proc selbyid {id} {
8097 global curview
8098 if {[commitinview $id $curview]} {
8099 selectline [rowofcommit $id] 1
8103 proc mstime {} {
8104 global startmstime
8105 if {![info exists startmstime]} {
8106 set startmstime [clock clicks -milliseconds]
8108 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8111 proc rowmenu {x y id} {
8112 global rowctxmenu selectedline rowmenuid curview
8113 global nullid nullid2 fakerowmenu mainhead markedid
8115 stopfinding
8116 set rowmenuid $id
8117 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8118 set state disabled
8119 } else {
8120 set state normal
8122 if {$id ne $nullid && $id ne $nullid2} {
8123 set menu $rowctxmenu
8124 if {$mainhead ne {}} {
8125 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8126 } else {
8127 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8129 if {[info exists markedid] && $markedid ne $id} {
8130 $menu entryconfigure 9 -state normal
8131 $menu entryconfigure 10 -state normal
8132 $menu entryconfigure 11 -state normal
8133 } else {
8134 $menu entryconfigure 9 -state disabled
8135 $menu entryconfigure 10 -state disabled
8136 $menu entryconfigure 11 -state disabled
8138 } else {
8139 set menu $fakerowmenu
8141 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8142 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8143 $menu entryconfigure [mca "Make patch"] -state $state
8144 tk_popup $menu $x $y
8147 proc markhere {} {
8148 global rowmenuid markedid canv
8150 set markedid $rowmenuid
8151 make_idmark $markedid
8154 proc gotomark {} {
8155 global markedid
8157 if {[info exists markedid]} {
8158 selbyid $markedid
8162 proc replace_by_kids {l r} {
8163 global curview children
8165 set id [commitonrow $r]
8166 set l [lreplace $l 0 0]
8167 foreach kid $children($curview,$id) {
8168 lappend l [rowofcommit $kid]
8170 return [lsort -integer -decreasing -unique $l]
8173 proc find_common_desc {} {
8174 global markedid rowmenuid curview children
8176 if {![info exists markedid]} return
8177 if {![commitinview $markedid $curview] ||
8178 ![commitinview $rowmenuid $curview]} return
8179 #set t1 [clock clicks -milliseconds]
8180 set l1 [list [rowofcommit $markedid]]
8181 set l2 [list [rowofcommit $rowmenuid]]
8182 while 1 {
8183 set r1 [lindex $l1 0]
8184 set r2 [lindex $l2 0]
8185 if {$r1 eq {} || $r2 eq {}} break
8186 if {$r1 == $r2} {
8187 selectline $r1 1
8188 break
8190 if {$r1 > $r2} {
8191 set l1 [replace_by_kids $l1 $r1]
8192 } else {
8193 set l2 [replace_by_kids $l2 $r2]
8196 #set t2 [clock clicks -milliseconds]
8197 #puts "took [expr {$t2-$t1}]ms"
8200 proc compare_commits {} {
8201 global markedid rowmenuid curview children
8203 if {![info exists markedid]} return
8204 if {![commitinview $markedid $curview]} return
8205 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8206 do_cmp_commits $markedid $rowmenuid
8209 proc getpatchid {id} {
8210 global patchids
8212 if {![info exists patchids($id)]} {
8213 set cmd [diffcmd [list $id] {-p --root}]
8214 # trim off the initial "|"
8215 set cmd [lrange $cmd 1 end]
8216 if {[catch {
8217 set x [eval exec $cmd | git patch-id]
8218 set patchids($id) [lindex $x 0]
8219 }]} {
8220 set patchids($id) "error"
8223 return $patchids($id)
8226 proc do_cmp_commits {a b} {
8227 global ctext curview parents children patchids commitinfo
8229 $ctext conf -state normal
8230 clear_ctext
8231 init_flist {}
8232 for {set i 0} {$i < 100} {incr i} {
8233 set skipa 0
8234 set skipb 0
8235 if {[llength $parents($curview,$a)] > 1} {
8236 appendshortlink $a [mc "Skipping merge commit "] "\n"
8237 set skipa 1
8238 } else {
8239 set patcha [getpatchid $a]
8241 if {[llength $parents($curview,$b)] > 1} {
8242 appendshortlink $b [mc "Skipping merge commit "] "\n"
8243 set skipb 1
8244 } else {
8245 set patchb [getpatchid $b]
8247 if {!$skipa && !$skipb} {
8248 set heada [lindex $commitinfo($a) 0]
8249 set headb [lindex $commitinfo($b) 0]
8250 if {$patcha eq "error"} {
8251 appendshortlink $a [mc "Error getting patch ID for "] \
8252 [mc " - stopping\n"]
8253 break
8255 if {$patchb eq "error"} {
8256 appendshortlink $b [mc "Error getting patch ID for "] \
8257 [mc " - stopping\n"]
8258 break
8260 if {$patcha eq $patchb} {
8261 if {$heada eq $headb} {
8262 appendshortlink $a [mc "Commit "]
8263 appendshortlink $b " == " " $heada\n"
8264 } else {
8265 appendshortlink $a [mc "Commit "] " $heada\n"
8266 appendshortlink $b [mc " is the same patch as\n "] \
8267 " $headb\n"
8269 set skipa 1
8270 set skipb 1
8271 } else {
8272 $ctext insert end "\n"
8273 appendshortlink $a [mc "Commit "] " $heada\n"
8274 appendshortlink $b [mc " differs from\n "] \
8275 " $headb\n"
8276 $ctext insert end [mc "- stopping\n"]
8277 break
8280 if {$skipa} {
8281 if {[llength $children($curview,$a)] != 1} {
8282 $ctext insert end "\n"
8283 appendshortlink $a [mc "Commit "] \
8284 [mc " has %s children - stopping\n" \
8285 [llength $children($curview,$a)]]
8286 break
8288 set a [lindex $children($curview,$a) 0]
8290 if {$skipb} {
8291 if {[llength $children($curview,$b)] != 1} {
8292 appendshortlink $b [mc "Commit "] \
8293 [mc " has %s children - stopping\n" \
8294 [llength $children($curview,$b)]]
8295 break
8297 set b [lindex $children($curview,$b) 0]
8300 $ctext conf -state disabled
8303 proc diffvssel {dirn} {
8304 global rowmenuid selectedline
8306 if {$selectedline eq {}} return
8307 if {$dirn} {
8308 set oldid [commitonrow $selectedline]
8309 set newid $rowmenuid
8310 } else {
8311 set oldid $rowmenuid
8312 set newid [commitonrow $selectedline]
8314 addtohistory [list doseldiff $oldid $newid]
8315 doseldiff $oldid $newid
8318 proc doseldiff {oldid newid} {
8319 global ctext
8320 global commitinfo
8322 $ctext conf -state normal
8323 clear_ctext
8324 init_flist [mc "Top"]
8325 $ctext insert end "[mc "From"] "
8326 $ctext insert end $oldid link0
8327 setlink $oldid link0
8328 $ctext insert end "\n "
8329 $ctext insert end [lindex $commitinfo($oldid) 0]
8330 $ctext insert end "\n\n[mc "To"] "
8331 $ctext insert end $newid link1
8332 setlink $newid link1
8333 $ctext insert end "\n "
8334 $ctext insert end [lindex $commitinfo($newid) 0]
8335 $ctext insert end "\n"
8336 $ctext conf -state disabled
8337 $ctext tag remove found 1.0 end
8338 startdiff [list $oldid $newid]
8341 proc mkpatch {} {
8342 global rowmenuid currentid commitinfo patchtop patchnum
8344 if {![info exists currentid]} return
8345 set oldid $currentid
8346 set oldhead [lindex $commitinfo($oldid) 0]
8347 set newid $rowmenuid
8348 set newhead [lindex $commitinfo($newid) 0]
8349 set top .patch
8350 set patchtop $top
8351 catch {destroy $top}
8352 toplevel $top
8353 make_transient $top .
8354 label $top.title -text [mc "Generate patch"]
8355 grid $top.title - -pady 10
8356 label $top.from -text [mc "From:"]
8357 entry $top.fromsha1 -width 40 -relief flat
8358 $top.fromsha1 insert 0 $oldid
8359 $top.fromsha1 conf -state readonly
8360 grid $top.from $top.fromsha1 -sticky w
8361 entry $top.fromhead -width 60 -relief flat
8362 $top.fromhead insert 0 $oldhead
8363 $top.fromhead conf -state readonly
8364 grid x $top.fromhead -sticky w
8365 label $top.to -text [mc "To:"]
8366 entry $top.tosha1 -width 40 -relief flat
8367 $top.tosha1 insert 0 $newid
8368 $top.tosha1 conf -state readonly
8369 grid $top.to $top.tosha1 -sticky w
8370 entry $top.tohead -width 60 -relief flat
8371 $top.tohead insert 0 $newhead
8372 $top.tohead conf -state readonly
8373 grid x $top.tohead -sticky w
8374 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8375 grid $top.rev x -pady 10
8376 label $top.flab -text [mc "Output file:"]
8377 entry $top.fname -width 60
8378 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8379 incr patchnum
8380 grid $top.flab $top.fname -sticky w
8381 frame $top.buts
8382 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8383 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8384 bind $top <Key-Return> mkpatchgo
8385 bind $top <Key-Escape> mkpatchcan
8386 grid $top.buts.gen $top.buts.can
8387 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8388 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8389 grid $top.buts - -pady 10 -sticky ew
8390 focus $top.fname
8393 proc mkpatchrev {} {
8394 global patchtop
8396 set oldid [$patchtop.fromsha1 get]
8397 set oldhead [$patchtop.fromhead get]
8398 set newid [$patchtop.tosha1 get]
8399 set newhead [$patchtop.tohead get]
8400 foreach e [list fromsha1 fromhead tosha1 tohead] \
8401 v [list $newid $newhead $oldid $oldhead] {
8402 $patchtop.$e conf -state normal
8403 $patchtop.$e delete 0 end
8404 $patchtop.$e insert 0 $v
8405 $patchtop.$e conf -state readonly
8409 proc mkpatchgo {} {
8410 global patchtop nullid nullid2
8412 set oldid [$patchtop.fromsha1 get]
8413 set newid [$patchtop.tosha1 get]
8414 set fname [$patchtop.fname get]
8415 set cmd [diffcmd [list $oldid $newid] -p]
8416 # trim off the initial "|"
8417 set cmd [lrange $cmd 1 end]
8418 lappend cmd >$fname &
8419 if {[catch {eval exec $cmd} err]} {
8420 error_popup "[mc "Error creating patch:"] $err" $patchtop
8422 catch {destroy $patchtop}
8423 unset patchtop
8426 proc mkpatchcan {} {
8427 global patchtop
8429 catch {destroy $patchtop}
8430 unset patchtop
8433 proc mktag {} {
8434 global rowmenuid mktagtop commitinfo
8436 set top .maketag
8437 set mktagtop $top
8438 catch {destroy $top}
8439 toplevel $top
8440 make_transient $top .
8441 label $top.title -text [mc "Create tag"]
8442 grid $top.title - -pady 10
8443 label $top.id -text [mc "ID:"]
8444 entry $top.sha1 -width 40 -relief flat
8445 $top.sha1 insert 0 $rowmenuid
8446 $top.sha1 conf -state readonly
8447 grid $top.id $top.sha1 -sticky w
8448 entry $top.head -width 60 -relief flat
8449 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8450 $top.head conf -state readonly
8451 grid x $top.head -sticky w
8452 label $top.tlab -text [mc "Tag name:"]
8453 entry $top.tag -width 60
8454 grid $top.tlab $top.tag -sticky w
8455 frame $top.buts
8456 button $top.buts.gen -text [mc "Create"] -command mktaggo
8457 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8458 bind $top <Key-Return> mktaggo
8459 bind $top <Key-Escape> mktagcan
8460 grid $top.buts.gen $top.buts.can
8461 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8462 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8463 grid $top.buts - -pady 10 -sticky ew
8464 focus $top.tag
8467 proc domktag {} {
8468 global mktagtop env tagids idtags
8470 set id [$mktagtop.sha1 get]
8471 set tag [$mktagtop.tag get]
8472 if {$tag == {}} {
8473 error_popup [mc "No tag name specified"] $mktagtop
8474 return 0
8476 if {[info exists tagids($tag)]} {
8477 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8478 return 0
8480 if {[catch {
8481 exec git tag $tag $id
8482 } err]} {
8483 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8484 return 0
8487 set tagids($tag) $id
8488 lappend idtags($id) $tag
8489 redrawtags $id
8490 addedtag $id
8491 dispneartags 0
8492 run refill_reflist
8493 return 1
8496 proc redrawtags {id} {
8497 global canv linehtag idpos currentid curview cmitlisted markedid
8498 global canvxmax iddrawn circleitem mainheadid circlecolors
8500 if {![commitinview $id $curview]} return
8501 if {![info exists iddrawn($id)]} return
8502 set row [rowofcommit $id]
8503 if {$id eq $mainheadid} {
8504 set ofill yellow
8505 } else {
8506 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8508 $canv itemconf $circleitem($row) -fill $ofill
8509 $canv delete tag.$id
8510 set xt [eval drawtags $id $idpos($id)]
8511 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8512 set text [$canv itemcget $linehtag($id) -text]
8513 set font [$canv itemcget $linehtag($id) -font]
8514 set xr [expr {$xt + [font measure $font $text]}]
8515 if {$xr > $canvxmax} {
8516 set canvxmax $xr
8517 setcanvscroll
8519 if {[info exists currentid] && $currentid == $id} {
8520 make_secsel $id
8522 if {[info exists markedid] && $markedid eq $id} {
8523 make_idmark $id
8527 proc mktagcan {} {
8528 global mktagtop
8530 catch {destroy $mktagtop}
8531 unset mktagtop
8534 proc mktaggo {} {
8535 if {![domktag]} return
8536 mktagcan
8539 proc writecommit {} {
8540 global rowmenuid wrcomtop commitinfo wrcomcmd
8542 set top .writecommit
8543 set wrcomtop $top
8544 catch {destroy $top}
8545 toplevel $top
8546 make_transient $top .
8547 label $top.title -text [mc "Write commit to file"]
8548 grid $top.title - -pady 10
8549 label $top.id -text [mc "ID:"]
8550 entry $top.sha1 -width 40 -relief flat
8551 $top.sha1 insert 0 $rowmenuid
8552 $top.sha1 conf -state readonly
8553 grid $top.id $top.sha1 -sticky w
8554 entry $top.head -width 60 -relief flat
8555 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8556 $top.head conf -state readonly
8557 grid x $top.head -sticky w
8558 label $top.clab -text [mc "Command:"]
8559 entry $top.cmd -width 60 -textvariable wrcomcmd
8560 grid $top.clab $top.cmd -sticky w -pady 10
8561 label $top.flab -text [mc "Output file:"]
8562 entry $top.fname -width 60
8563 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8564 grid $top.flab $top.fname -sticky w
8565 frame $top.buts
8566 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8567 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8568 bind $top <Key-Return> wrcomgo
8569 bind $top <Key-Escape> wrcomcan
8570 grid $top.buts.gen $top.buts.can
8571 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8572 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8573 grid $top.buts - -pady 10 -sticky ew
8574 focus $top.fname
8577 proc wrcomgo {} {
8578 global wrcomtop
8580 set id [$wrcomtop.sha1 get]
8581 set cmd "echo $id | [$wrcomtop.cmd get]"
8582 set fname [$wrcomtop.fname get]
8583 if {[catch {exec sh -c $cmd >$fname &} err]} {
8584 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8586 catch {destroy $wrcomtop}
8587 unset wrcomtop
8590 proc wrcomcan {} {
8591 global wrcomtop
8593 catch {destroy $wrcomtop}
8594 unset wrcomtop
8597 proc mkbranch {} {
8598 global rowmenuid mkbrtop
8600 set top .makebranch
8601 catch {destroy $top}
8602 toplevel $top
8603 make_transient $top .
8604 label $top.title -text [mc "Create new branch"]
8605 grid $top.title - -pady 10
8606 label $top.id -text [mc "ID:"]
8607 entry $top.sha1 -width 40 -relief flat
8608 $top.sha1 insert 0 $rowmenuid
8609 $top.sha1 conf -state readonly
8610 grid $top.id $top.sha1 -sticky w
8611 label $top.nlab -text [mc "Name:"]
8612 entry $top.name -width 40
8613 grid $top.nlab $top.name -sticky w
8614 frame $top.buts
8615 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8616 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8617 bind $top <Key-Return> [list mkbrgo $top]
8618 bind $top <Key-Escape> "catch {destroy $top}"
8619 grid $top.buts.go $top.buts.can
8620 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8621 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8622 grid $top.buts - -pady 10 -sticky ew
8623 focus $top.name
8626 proc mkbrgo {top} {
8627 global headids idheads
8629 set name [$top.name get]
8630 set id [$top.sha1 get]
8631 set cmdargs {}
8632 set old_id {}
8633 if {$name eq {}} {
8634 error_popup [mc "Please specify a name for the new branch"] $top
8635 return
8637 if {[info exists headids($name)]} {
8638 if {![confirm_popup [mc \
8639 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8640 return
8642 set old_id $headids($name)
8643 lappend cmdargs -f
8645 catch {destroy $top}
8646 lappend cmdargs $name $id
8647 nowbusy newbranch
8648 update
8649 if {[catch {
8650 eval exec git branch $cmdargs
8651 } err]} {
8652 notbusy newbranch
8653 error_popup $err
8654 } else {
8655 notbusy newbranch
8656 if {$old_id ne {}} {
8657 movehead $id $name
8658 movedhead $id $name
8659 redrawtags $old_id
8660 redrawtags $id
8661 } else {
8662 set headids($name) $id
8663 lappend idheads($id) $name
8664 addedhead $id $name
8665 redrawtags $id
8667 dispneartags 0
8668 run refill_reflist
8672 proc exec_citool {tool_args {baseid {}}} {
8673 global commitinfo env
8675 set save_env [array get env GIT_AUTHOR_*]
8677 if {$baseid ne {}} {
8678 if {![info exists commitinfo($baseid)]} {
8679 getcommit $baseid
8681 set author [lindex $commitinfo($baseid) 1]
8682 set date [lindex $commitinfo($baseid) 2]
8683 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8684 $author author name email]
8685 && $date ne {}} {
8686 set env(GIT_AUTHOR_NAME) $name
8687 set env(GIT_AUTHOR_EMAIL) $email
8688 set env(GIT_AUTHOR_DATE) $date
8692 eval exec git citool $tool_args &
8694 array unset env GIT_AUTHOR_*
8695 array set env $save_env
8698 proc cherrypick {} {
8699 global rowmenuid curview
8700 global mainhead mainheadid
8702 set oldhead [exec git rev-parse HEAD]
8703 set dheads [descheads $rowmenuid]
8704 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8705 set ok [confirm_popup [mc "Commit %s is already\
8706 included in branch %s -- really re-apply it?" \
8707 [string range $rowmenuid 0 7] $mainhead]]
8708 if {!$ok} return
8710 nowbusy cherrypick [mc "Cherry-picking"]
8711 update
8712 # Unfortunately git-cherry-pick writes stuff to stderr even when
8713 # no error occurs, and exec takes that as an indication of error...
8714 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8715 notbusy cherrypick
8716 if {[regexp -line \
8717 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8718 $err msg fname]} {
8719 error_popup [mc "Cherry-pick failed because of local changes\
8720 to file '%s'.\nPlease commit, reset or stash\
8721 your changes and try again." $fname]
8722 } elseif {[regexp -line \
8723 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8724 $err]} {
8725 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8726 conflict.\nDo you wish to run git citool to\
8727 resolve it?"]]} {
8728 # Force citool to read MERGE_MSG
8729 file delete [file join [gitdir] "GITGUI_MSG"]
8730 exec_citool {} $rowmenuid
8732 } else {
8733 error_popup $err
8735 run updatecommits
8736 return
8738 set newhead [exec git rev-parse HEAD]
8739 if {$newhead eq $oldhead} {
8740 notbusy cherrypick
8741 error_popup [mc "No changes committed"]
8742 return
8744 addnewchild $newhead $oldhead
8745 if {[commitinview $oldhead $curview]} {
8746 # XXX this isn't right if we have a path limit...
8747 insertrow $newhead $oldhead $curview
8748 if {$mainhead ne {}} {
8749 movehead $newhead $mainhead
8750 movedhead $newhead $mainhead
8752 set mainheadid $newhead
8753 redrawtags $oldhead
8754 redrawtags $newhead
8755 selbyid $newhead
8757 notbusy cherrypick
8760 proc resethead {} {
8761 global mainhead rowmenuid confirm_ok resettype
8763 set confirm_ok 0
8764 set w ".confirmreset"
8765 toplevel $w
8766 make_transient $w .
8767 wm title $w [mc "Confirm reset"]
8768 message $w.m -text \
8769 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8770 -justify center -aspect 1000
8771 pack $w.m -side top -fill x -padx 20 -pady 20
8772 frame $w.f -relief sunken -border 2
8773 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8774 grid $w.f.rt -sticky w
8775 set resettype mixed
8776 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8777 -text [mc "Soft: Leave working tree and index untouched"]
8778 grid $w.f.soft -sticky w
8779 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8780 -text [mc "Mixed: Leave working tree untouched, reset index"]
8781 grid $w.f.mixed -sticky w
8782 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8783 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8784 grid $w.f.hard -sticky w
8785 pack $w.f -side top -fill x
8786 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8787 pack $w.ok -side left -fill x -padx 20 -pady 20
8788 button $w.cancel -text [mc Cancel] -command "destroy $w"
8789 bind $w <Key-Escape> [list destroy $w]
8790 pack $w.cancel -side right -fill x -padx 20 -pady 20
8791 bind $w <Visibility> "grab $w; focus $w"
8792 tkwait window $w
8793 if {!$confirm_ok} return
8794 if {[catch {set fd [open \
8795 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8796 error_popup $err
8797 } else {
8798 dohidelocalchanges
8799 filerun $fd [list readresetstat $fd]
8800 nowbusy reset [mc "Resetting"]
8801 selbyid $rowmenuid
8805 proc readresetstat {fd} {
8806 global mainhead mainheadid showlocalchanges rprogcoord
8808 if {[gets $fd line] >= 0} {
8809 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8810 set rprogcoord [expr {1.0 * $m / $n}]
8811 adjustprogress
8813 return 1
8815 set rprogcoord 0
8816 adjustprogress
8817 notbusy reset
8818 if {[catch {close $fd} err]} {
8819 error_popup $err
8821 set oldhead $mainheadid
8822 set newhead [exec git rev-parse HEAD]
8823 if {$newhead ne $oldhead} {
8824 movehead $newhead $mainhead
8825 movedhead $newhead $mainhead
8826 set mainheadid $newhead
8827 redrawtags $oldhead
8828 redrawtags $newhead
8830 if {$showlocalchanges} {
8831 doshowlocalchanges
8833 return 0
8836 # context menu for a head
8837 proc headmenu {x y id head} {
8838 global headmenuid headmenuhead headctxmenu mainhead
8840 stopfinding
8841 set headmenuid $id
8842 set headmenuhead $head
8843 set state normal
8844 if {$head eq $mainhead} {
8845 set state disabled
8847 $headctxmenu entryconfigure 0 -state $state
8848 $headctxmenu entryconfigure 1 -state $state
8849 tk_popup $headctxmenu $x $y
8852 proc cobranch {} {
8853 global headmenuid headmenuhead headids
8854 global showlocalchanges
8856 # check the tree is clean first??
8857 nowbusy checkout [mc "Checking out"]
8858 update
8859 dohidelocalchanges
8860 if {[catch {
8861 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8862 } err]} {
8863 notbusy checkout
8864 error_popup $err
8865 if {$showlocalchanges} {
8866 dodiffindex
8868 } else {
8869 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8873 proc readcheckoutstat {fd newhead newheadid} {
8874 global mainhead mainheadid headids showlocalchanges progresscoords
8875 global viewmainheadid curview
8877 if {[gets $fd line] >= 0} {
8878 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8879 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8880 adjustprogress
8882 return 1
8884 set progresscoords {0 0}
8885 adjustprogress
8886 notbusy checkout
8887 if {[catch {close $fd} err]} {
8888 error_popup $err
8890 set oldmainid $mainheadid
8891 set mainhead $newhead
8892 set mainheadid $newheadid
8893 set viewmainheadid($curview) $newheadid
8894 redrawtags $oldmainid
8895 redrawtags $newheadid
8896 selbyid $newheadid
8897 if {$showlocalchanges} {
8898 dodiffindex
8902 proc rmbranch {} {
8903 global headmenuid headmenuhead mainhead
8904 global idheads
8906 set head $headmenuhead
8907 set id $headmenuid
8908 # this check shouldn't be needed any more...
8909 if {$head eq $mainhead} {
8910 error_popup [mc "Cannot delete the currently checked-out branch"]
8911 return
8913 set dheads [descheads $id]
8914 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8915 # the stuff on this branch isn't on any other branch
8916 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8917 branch.\nReally delete branch %s?" $head $head]]} return
8919 nowbusy rmbranch
8920 update
8921 if {[catch {exec git branch -D $head} err]} {
8922 notbusy rmbranch
8923 error_popup $err
8924 return
8926 removehead $id $head
8927 removedhead $id $head
8928 redrawtags $id
8929 notbusy rmbranch
8930 dispneartags 0
8931 run refill_reflist
8934 # Display a list of tags and heads
8935 proc showrefs {} {
8936 global showrefstop bgcolor fgcolor selectbgcolor
8937 global bglist fglist reflistfilter reflist maincursor
8939 set top .showrefs
8940 set showrefstop $top
8941 if {[winfo exists $top]} {
8942 raise $top
8943 refill_reflist
8944 return
8946 toplevel $top
8947 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8948 make_transient $top .
8949 text $top.list -background $bgcolor -foreground $fgcolor \
8950 -selectbackground $selectbgcolor -font mainfont \
8951 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8952 -width 30 -height 20 -cursor $maincursor \
8953 -spacing1 1 -spacing3 1 -state disabled
8954 $top.list tag configure highlight -background $selectbgcolor
8955 lappend bglist $top.list
8956 lappend fglist $top.list
8957 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8958 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8959 grid $top.list $top.ysb -sticky nsew
8960 grid $top.xsb x -sticky ew
8961 frame $top.f
8962 label $top.f.l -text "[mc "Filter"]: "
8963 entry $top.f.e -width 20 -textvariable reflistfilter
8964 set reflistfilter "*"
8965 trace add variable reflistfilter write reflistfilter_change
8966 pack $top.f.e -side right -fill x -expand 1
8967 pack $top.f.l -side left
8968 grid $top.f - -sticky ew -pady 2
8969 button $top.close -command [list destroy $top] -text [mc "Close"]
8970 bind $top <Key-Escape> [list destroy $top]
8971 grid $top.close -
8972 grid columnconfigure $top 0 -weight 1
8973 grid rowconfigure $top 0 -weight 1
8974 bind $top.list <1> {break}
8975 bind $top.list <B1-Motion> {break}
8976 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8977 set reflist {}
8978 refill_reflist
8981 proc sel_reflist {w x y} {
8982 global showrefstop reflist headids tagids otherrefids
8984 if {![winfo exists $showrefstop]} return
8985 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8986 set ref [lindex $reflist [expr {$l-1}]]
8987 set n [lindex $ref 0]
8988 switch -- [lindex $ref 1] {
8989 "H" {selbyid $headids($n)}
8990 "T" {selbyid $tagids($n)}
8991 "o" {selbyid $otherrefids($n)}
8993 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8996 proc unsel_reflist {} {
8997 global showrefstop
8999 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9000 $showrefstop.list tag remove highlight 0.0 end
9003 proc reflistfilter_change {n1 n2 op} {
9004 global reflistfilter
9006 after cancel refill_reflist
9007 after 200 refill_reflist
9010 proc refill_reflist {} {
9011 global reflist reflistfilter showrefstop headids tagids otherrefids
9012 global curview
9014 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9015 set refs {}
9016 foreach n [array names headids] {
9017 if {[string match $reflistfilter $n]} {
9018 if {[commitinview $headids($n) $curview]} {
9019 lappend refs [list $n H]
9020 } else {
9021 interestedin $headids($n) {run refill_reflist}
9025 foreach n [array names tagids] {
9026 if {[string match $reflistfilter $n]} {
9027 if {[commitinview $tagids($n) $curview]} {
9028 lappend refs [list $n T]
9029 } else {
9030 interestedin $tagids($n) {run refill_reflist}
9034 foreach n [array names otherrefids] {
9035 if {[string match $reflistfilter $n]} {
9036 if {[commitinview $otherrefids($n) $curview]} {
9037 lappend refs [list $n o]
9038 } else {
9039 interestedin $otherrefids($n) {run refill_reflist}
9043 set refs [lsort -index 0 $refs]
9044 if {$refs eq $reflist} return
9046 # Update the contents of $showrefstop.list according to the
9047 # differences between $reflist (old) and $refs (new)
9048 $showrefstop.list conf -state normal
9049 $showrefstop.list insert end "\n"
9050 set i 0
9051 set j 0
9052 while {$i < [llength $reflist] || $j < [llength $refs]} {
9053 if {$i < [llength $reflist]} {
9054 if {$j < [llength $refs]} {
9055 set cmp [string compare [lindex $reflist $i 0] \
9056 [lindex $refs $j 0]]
9057 if {$cmp == 0} {
9058 set cmp [string compare [lindex $reflist $i 1] \
9059 [lindex $refs $j 1]]
9061 } else {
9062 set cmp -1
9064 } else {
9065 set cmp 1
9067 switch -- $cmp {
9068 -1 {
9069 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9070 incr i
9073 incr i
9074 incr j
9077 set l [expr {$j + 1}]
9078 $showrefstop.list image create $l.0 -align baseline \
9079 -image reficon-[lindex $refs $j 1] -padx 2
9080 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9081 incr j
9085 set reflist $refs
9086 # delete last newline
9087 $showrefstop.list delete end-2c end-1c
9088 $showrefstop.list conf -state disabled
9091 # Stuff for finding nearby tags
9092 proc getallcommits {} {
9093 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9094 global idheads idtags idotherrefs allparents tagobjid
9096 if {![info exists allcommits]} {
9097 set nextarc 0
9098 set allcommits 0
9099 set seeds {}
9100 set allcwait 0
9101 set cachedarcs 0
9102 set allccache [file join [gitdir] "gitk.cache"]
9103 if {![catch {
9104 set f [open $allccache r]
9105 set allcwait 1
9106 getcache $f
9107 }]} return
9110 if {$allcwait} {
9111 return
9113 set cmd [list | git rev-list --parents]
9114 set allcupdate [expr {$seeds ne {}}]
9115 if {!$allcupdate} {
9116 set ids "--all"
9117 } else {
9118 set refs [concat [array names idheads] [array names idtags] \
9119 [array names idotherrefs]]
9120 set ids {}
9121 set tagobjs {}
9122 foreach name [array names tagobjid] {
9123 lappend tagobjs $tagobjid($name)
9125 foreach id [lsort -unique $refs] {
9126 if {![info exists allparents($id)] &&
9127 [lsearch -exact $tagobjs $id] < 0} {
9128 lappend ids $id
9131 if {$ids ne {}} {
9132 foreach id $seeds {
9133 lappend ids "^$id"
9137 if {$ids ne {}} {
9138 set fd [open [concat $cmd $ids] r]
9139 fconfigure $fd -blocking 0
9140 incr allcommits
9141 nowbusy allcommits
9142 filerun $fd [list getallclines $fd]
9143 } else {
9144 dispneartags 0
9148 # Since most commits have 1 parent and 1 child, we group strings of
9149 # such commits into "arcs" joining branch/merge points (BMPs), which
9150 # are commits that either don't have 1 parent or don't have 1 child.
9152 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9153 # arcout(id) - outgoing arcs for BMP
9154 # arcids(a) - list of IDs on arc including end but not start
9155 # arcstart(a) - BMP ID at start of arc
9156 # arcend(a) - BMP ID at end of arc
9157 # growing(a) - arc a is still growing
9158 # arctags(a) - IDs out of arcids (excluding end) that have tags
9159 # archeads(a) - IDs out of arcids (excluding end) that have heads
9160 # The start of an arc is at the descendent end, so "incoming" means
9161 # coming from descendents, and "outgoing" means going towards ancestors.
9163 proc getallclines {fd} {
9164 global allparents allchildren idtags idheads nextarc
9165 global arcnos arcids arctags arcout arcend arcstart archeads growing
9166 global seeds allcommits cachedarcs allcupdate
9168 set nid 0
9169 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9170 set id [lindex $line 0]
9171 if {[info exists allparents($id)]} {
9172 # seen it already
9173 continue
9175 set cachedarcs 0
9176 set olds [lrange $line 1 end]
9177 set allparents($id) $olds
9178 if {![info exists allchildren($id)]} {
9179 set allchildren($id) {}
9180 set arcnos($id) {}
9181 lappend seeds $id
9182 } else {
9183 set a $arcnos($id)
9184 if {[llength $olds] == 1 && [llength $a] == 1} {
9185 lappend arcids($a) $id
9186 if {[info exists idtags($id)]} {
9187 lappend arctags($a) $id
9189 if {[info exists idheads($id)]} {
9190 lappend archeads($a) $id
9192 if {[info exists allparents($olds)]} {
9193 # seen parent already
9194 if {![info exists arcout($olds)]} {
9195 splitarc $olds
9197 lappend arcids($a) $olds
9198 set arcend($a) $olds
9199 unset growing($a)
9201 lappend allchildren($olds) $id
9202 lappend arcnos($olds) $a
9203 continue
9206 foreach a $arcnos($id) {
9207 lappend arcids($a) $id
9208 set arcend($a) $id
9209 unset growing($a)
9212 set ao {}
9213 foreach p $olds {
9214 lappend allchildren($p) $id
9215 set a [incr nextarc]
9216 set arcstart($a) $id
9217 set archeads($a) {}
9218 set arctags($a) {}
9219 set archeads($a) {}
9220 set arcids($a) {}
9221 lappend ao $a
9222 set growing($a) 1
9223 if {[info exists allparents($p)]} {
9224 # seen it already, may need to make a new branch
9225 if {![info exists arcout($p)]} {
9226 splitarc $p
9228 lappend arcids($a) $p
9229 set arcend($a) $p
9230 unset growing($a)
9232 lappend arcnos($p) $a
9234 set arcout($id) $ao
9236 if {$nid > 0} {
9237 global cached_dheads cached_dtags cached_atags
9238 catch {unset cached_dheads}
9239 catch {unset cached_dtags}
9240 catch {unset cached_atags}
9242 if {![eof $fd]} {
9243 return [expr {$nid >= 1000? 2: 1}]
9245 set cacheok 1
9246 if {[catch {
9247 fconfigure $fd -blocking 1
9248 close $fd
9249 } err]} {
9250 # got an error reading the list of commits
9251 # if we were updating, try rereading the whole thing again
9252 if {$allcupdate} {
9253 incr allcommits -1
9254 dropcache $err
9255 return
9257 error_popup "[mc "Error reading commit topology information;\
9258 branch and preceding/following tag information\
9259 will be incomplete."]\n($err)"
9260 set cacheok 0
9262 if {[incr allcommits -1] == 0} {
9263 notbusy allcommits
9264 if {$cacheok} {
9265 run savecache
9268 dispneartags 0
9269 return 0
9272 proc recalcarc {a} {
9273 global arctags archeads arcids idtags idheads
9275 set at {}
9276 set ah {}
9277 foreach id [lrange $arcids($a) 0 end-1] {
9278 if {[info exists idtags($id)]} {
9279 lappend at $id
9281 if {[info exists idheads($id)]} {
9282 lappend ah $id
9285 set arctags($a) $at
9286 set archeads($a) $ah
9289 proc splitarc {p} {
9290 global arcnos arcids nextarc arctags archeads idtags idheads
9291 global arcstart arcend arcout allparents growing
9293 set a $arcnos($p)
9294 if {[llength $a] != 1} {
9295 puts "oops splitarc called but [llength $a] arcs already"
9296 return
9298 set a [lindex $a 0]
9299 set i [lsearch -exact $arcids($a) $p]
9300 if {$i < 0} {
9301 puts "oops splitarc $p not in arc $a"
9302 return
9304 set na [incr nextarc]
9305 if {[info exists arcend($a)]} {
9306 set arcend($na) $arcend($a)
9307 } else {
9308 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9309 set j [lsearch -exact $arcnos($l) $a]
9310 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9312 set tail [lrange $arcids($a) [expr {$i+1}] end]
9313 set arcids($a) [lrange $arcids($a) 0 $i]
9314 set arcend($a) $p
9315 set arcstart($na) $p
9316 set arcout($p) $na
9317 set arcids($na) $tail
9318 if {[info exists growing($a)]} {
9319 set growing($na) 1
9320 unset growing($a)
9323 foreach id $tail {
9324 if {[llength $arcnos($id)] == 1} {
9325 set arcnos($id) $na
9326 } else {
9327 set j [lsearch -exact $arcnos($id) $a]
9328 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9332 # reconstruct tags and heads lists
9333 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9334 recalcarc $a
9335 recalcarc $na
9336 } else {
9337 set arctags($na) {}
9338 set archeads($na) {}
9342 # Update things for a new commit added that is a child of one
9343 # existing commit. Used when cherry-picking.
9344 proc addnewchild {id p} {
9345 global allparents allchildren idtags nextarc
9346 global arcnos arcids arctags arcout arcend arcstart archeads growing
9347 global seeds allcommits
9349 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9350 set allparents($id) [list $p]
9351 set allchildren($id) {}
9352 set arcnos($id) {}
9353 lappend seeds $id
9354 lappend allchildren($p) $id
9355 set a [incr nextarc]
9356 set arcstart($a) $id
9357 set archeads($a) {}
9358 set arctags($a) {}
9359 set arcids($a) [list $p]
9360 set arcend($a) $p
9361 if {![info exists arcout($p)]} {
9362 splitarc $p
9364 lappend arcnos($p) $a
9365 set arcout($id) [list $a]
9368 # This implements a cache for the topology information.
9369 # The cache saves, for each arc, the start and end of the arc,
9370 # the ids on the arc, and the outgoing arcs from the end.
9371 proc readcache {f} {
9372 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9373 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9374 global allcwait
9376 set a $nextarc
9377 set lim $cachedarcs
9378 if {$lim - $a > 500} {
9379 set lim [expr {$a + 500}]
9381 if {[catch {
9382 if {$a == $lim} {
9383 # finish reading the cache and setting up arctags, etc.
9384 set line [gets $f]
9385 if {$line ne "1"} {error "bad final version"}
9386 close $f
9387 foreach id [array names idtags] {
9388 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9389 [llength $allparents($id)] == 1} {
9390 set a [lindex $arcnos($id) 0]
9391 if {$arctags($a) eq {}} {
9392 recalcarc $a
9396 foreach id [array names idheads] {
9397 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9398 [llength $allparents($id)] == 1} {
9399 set a [lindex $arcnos($id) 0]
9400 if {$archeads($a) eq {}} {
9401 recalcarc $a
9405 foreach id [lsort -unique $possible_seeds] {
9406 if {$arcnos($id) eq {}} {
9407 lappend seeds $id
9410 set allcwait 0
9411 } else {
9412 while {[incr a] <= $lim} {
9413 set line [gets $f]
9414 if {[llength $line] != 3} {error "bad line"}
9415 set s [lindex $line 0]
9416 set arcstart($a) $s
9417 lappend arcout($s) $a
9418 if {![info exists arcnos($s)]} {
9419 lappend possible_seeds $s
9420 set arcnos($s) {}
9422 set e [lindex $line 1]
9423 if {$e eq {}} {
9424 set growing($a) 1
9425 } else {
9426 set arcend($a) $e
9427 if {![info exists arcout($e)]} {
9428 set arcout($e) {}
9431 set arcids($a) [lindex $line 2]
9432 foreach id $arcids($a) {
9433 lappend allparents($s) $id
9434 set s $id
9435 lappend arcnos($id) $a
9437 if {![info exists allparents($s)]} {
9438 set allparents($s) {}
9440 set arctags($a) {}
9441 set archeads($a) {}
9443 set nextarc [expr {$a - 1}]
9445 } err]} {
9446 dropcache $err
9447 return 0
9449 if {!$allcwait} {
9450 getallcommits
9452 return $allcwait
9455 proc getcache {f} {
9456 global nextarc cachedarcs possible_seeds
9458 if {[catch {
9459 set line [gets $f]
9460 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9461 # make sure it's an integer
9462 set cachedarcs [expr {int([lindex $line 1])}]
9463 if {$cachedarcs < 0} {error "bad number of arcs"}
9464 set nextarc 0
9465 set possible_seeds {}
9466 run readcache $f
9467 } err]} {
9468 dropcache $err
9470 return 0
9473 proc dropcache {err} {
9474 global allcwait nextarc cachedarcs seeds
9476 #puts "dropping cache ($err)"
9477 foreach v {arcnos arcout arcids arcstart arcend growing \
9478 arctags archeads allparents allchildren} {
9479 global $v
9480 catch {unset $v}
9482 set allcwait 0
9483 set nextarc 0
9484 set cachedarcs 0
9485 set seeds {}
9486 getallcommits
9489 proc writecache {f} {
9490 global cachearc cachedarcs allccache
9491 global arcstart arcend arcnos arcids arcout
9493 set a $cachearc
9494 set lim $cachedarcs
9495 if {$lim - $a > 1000} {
9496 set lim [expr {$a + 1000}]
9498 if {[catch {
9499 while {[incr a] <= $lim} {
9500 if {[info exists arcend($a)]} {
9501 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9502 } else {
9503 puts $f [list $arcstart($a) {} $arcids($a)]
9506 } err]} {
9507 catch {close $f}
9508 catch {file delete $allccache}
9509 #puts "writing cache failed ($err)"
9510 return 0
9512 set cachearc [expr {$a - 1}]
9513 if {$a > $cachedarcs} {
9514 puts $f "1"
9515 close $f
9516 return 0
9518 return 1
9521 proc savecache {} {
9522 global nextarc cachedarcs cachearc allccache
9524 if {$nextarc == $cachedarcs} return
9525 set cachearc 0
9526 set cachedarcs $nextarc
9527 catch {
9528 set f [open $allccache w]
9529 puts $f [list 1 $cachedarcs]
9530 run writecache $f
9534 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9535 # or 0 if neither is true.
9536 proc anc_or_desc {a b} {
9537 global arcout arcstart arcend arcnos cached_isanc
9539 if {$arcnos($a) eq $arcnos($b)} {
9540 # Both are on the same arc(s); either both are the same BMP,
9541 # or if one is not a BMP, the other is also not a BMP or is
9542 # the BMP at end of the arc (and it only has 1 incoming arc).
9543 # Or both can be BMPs with no incoming arcs.
9544 if {$a eq $b || $arcnos($a) eq {}} {
9545 return 0
9547 # assert {[llength $arcnos($a)] == 1}
9548 set arc [lindex $arcnos($a) 0]
9549 set i [lsearch -exact $arcids($arc) $a]
9550 set j [lsearch -exact $arcids($arc) $b]
9551 if {$i < 0 || $i > $j} {
9552 return 1
9553 } else {
9554 return -1
9558 if {![info exists arcout($a)]} {
9559 set arc [lindex $arcnos($a) 0]
9560 if {[info exists arcend($arc)]} {
9561 set aend $arcend($arc)
9562 } else {
9563 set aend {}
9565 set a $arcstart($arc)
9566 } else {
9567 set aend $a
9569 if {![info exists arcout($b)]} {
9570 set arc [lindex $arcnos($b) 0]
9571 if {[info exists arcend($arc)]} {
9572 set bend $arcend($arc)
9573 } else {
9574 set bend {}
9576 set b $arcstart($arc)
9577 } else {
9578 set bend $b
9580 if {$a eq $bend} {
9581 return 1
9583 if {$b eq $aend} {
9584 return -1
9586 if {[info exists cached_isanc($a,$bend)]} {
9587 if {$cached_isanc($a,$bend)} {
9588 return 1
9591 if {[info exists cached_isanc($b,$aend)]} {
9592 if {$cached_isanc($b,$aend)} {
9593 return -1
9595 if {[info exists cached_isanc($a,$bend)]} {
9596 return 0
9600 set todo [list $a $b]
9601 set anc($a) a
9602 set anc($b) b
9603 for {set i 0} {$i < [llength $todo]} {incr i} {
9604 set x [lindex $todo $i]
9605 if {$anc($x) eq {}} {
9606 continue
9608 foreach arc $arcnos($x) {
9609 set xd $arcstart($arc)
9610 if {$xd eq $bend} {
9611 set cached_isanc($a,$bend) 1
9612 set cached_isanc($b,$aend) 0
9613 return 1
9614 } elseif {$xd eq $aend} {
9615 set cached_isanc($b,$aend) 1
9616 set cached_isanc($a,$bend) 0
9617 return -1
9619 if {![info exists anc($xd)]} {
9620 set anc($xd) $anc($x)
9621 lappend todo $xd
9622 } elseif {$anc($xd) ne $anc($x)} {
9623 set anc($xd) {}
9627 set cached_isanc($a,$bend) 0
9628 set cached_isanc($b,$aend) 0
9629 return 0
9632 # This identifies whether $desc has an ancestor that is
9633 # a growing tip of the graph and which is not an ancestor of $anc
9634 # and returns 0 if so and 1 if not.
9635 # If we subsequently discover a tag on such a growing tip, and that
9636 # turns out to be a descendent of $anc (which it could, since we
9637 # don't necessarily see children before parents), then $desc
9638 # isn't a good choice to display as a descendent tag of
9639 # $anc (since it is the descendent of another tag which is
9640 # a descendent of $anc). Similarly, $anc isn't a good choice to
9641 # display as a ancestor tag of $desc.
9643 proc is_certain {desc anc} {
9644 global arcnos arcout arcstart arcend growing problems
9646 set certain {}
9647 if {[llength $arcnos($anc)] == 1} {
9648 # tags on the same arc are certain
9649 if {$arcnos($desc) eq $arcnos($anc)} {
9650 return 1
9652 if {![info exists arcout($anc)]} {
9653 # if $anc is partway along an arc, use the start of the arc instead
9654 set a [lindex $arcnos($anc) 0]
9655 set anc $arcstart($a)
9658 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9659 set x $desc
9660 } else {
9661 set a [lindex $arcnos($desc) 0]
9662 set x $arcend($a)
9664 if {$x == $anc} {
9665 return 1
9667 set anclist [list $x]
9668 set dl($x) 1
9669 set nnh 1
9670 set ngrowanc 0
9671 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9672 set x [lindex $anclist $i]
9673 if {$dl($x)} {
9674 incr nnh -1
9676 set done($x) 1
9677 foreach a $arcout($x) {
9678 if {[info exists growing($a)]} {
9679 if {![info exists growanc($x)] && $dl($x)} {
9680 set growanc($x) 1
9681 incr ngrowanc
9683 } else {
9684 set y $arcend($a)
9685 if {[info exists dl($y)]} {
9686 if {$dl($y)} {
9687 if {!$dl($x)} {
9688 set dl($y) 0
9689 if {![info exists done($y)]} {
9690 incr nnh -1
9692 if {[info exists growanc($x)]} {
9693 incr ngrowanc -1
9695 set xl [list $y]
9696 for {set k 0} {$k < [llength $xl]} {incr k} {
9697 set z [lindex $xl $k]
9698 foreach c $arcout($z) {
9699 if {[info exists arcend($c)]} {
9700 set v $arcend($c)
9701 if {[info exists dl($v)] && $dl($v)} {
9702 set dl($v) 0
9703 if {![info exists done($v)]} {
9704 incr nnh -1
9706 if {[info exists growanc($v)]} {
9707 incr ngrowanc -1
9709 lappend xl $v
9716 } elseif {$y eq $anc || !$dl($x)} {
9717 set dl($y) 0
9718 lappend anclist $y
9719 } else {
9720 set dl($y) 1
9721 lappend anclist $y
9722 incr nnh
9727 foreach x [array names growanc] {
9728 if {$dl($x)} {
9729 return 0
9731 return 0
9733 return 1
9736 proc validate_arctags {a} {
9737 global arctags idtags
9739 set i -1
9740 set na $arctags($a)
9741 foreach id $arctags($a) {
9742 incr i
9743 if {![info exists idtags($id)]} {
9744 set na [lreplace $na $i $i]
9745 incr i -1
9748 set arctags($a) $na
9751 proc validate_archeads {a} {
9752 global archeads idheads
9754 set i -1
9755 set na $archeads($a)
9756 foreach id $archeads($a) {
9757 incr i
9758 if {![info exists idheads($id)]} {
9759 set na [lreplace $na $i $i]
9760 incr i -1
9763 set archeads($a) $na
9766 # Return the list of IDs that have tags that are descendents of id,
9767 # ignoring IDs that are descendents of IDs already reported.
9768 proc desctags {id} {
9769 global arcnos arcstart arcids arctags idtags allparents
9770 global growing cached_dtags
9772 if {![info exists allparents($id)]} {
9773 return {}
9775 set t1 [clock clicks -milliseconds]
9776 set argid $id
9777 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9778 # part-way along an arc; check that arc first
9779 set a [lindex $arcnos($id) 0]
9780 if {$arctags($a) ne {}} {
9781 validate_arctags $a
9782 set i [lsearch -exact $arcids($a) $id]
9783 set tid {}
9784 foreach t $arctags($a) {
9785 set j [lsearch -exact $arcids($a) $t]
9786 if {$j >= $i} break
9787 set tid $t
9789 if {$tid ne {}} {
9790 return $tid
9793 set id $arcstart($a)
9794 if {[info exists idtags($id)]} {
9795 return $id
9798 if {[info exists cached_dtags($id)]} {
9799 return $cached_dtags($id)
9802 set origid $id
9803 set todo [list $id]
9804 set queued($id) 1
9805 set nc 1
9806 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9807 set id [lindex $todo $i]
9808 set done($id) 1
9809 set ta [info exists hastaggedancestor($id)]
9810 if {!$ta} {
9811 incr nc -1
9813 # ignore tags on starting node
9814 if {!$ta && $i > 0} {
9815 if {[info exists idtags($id)]} {
9816 set tagloc($id) $id
9817 set ta 1
9818 } elseif {[info exists cached_dtags($id)]} {
9819 set tagloc($id) $cached_dtags($id)
9820 set ta 1
9823 foreach a $arcnos($id) {
9824 set d $arcstart($a)
9825 if {!$ta && $arctags($a) ne {}} {
9826 validate_arctags $a
9827 if {$arctags($a) ne {}} {
9828 lappend tagloc($id) [lindex $arctags($a) end]
9831 if {$ta || $arctags($a) ne {}} {
9832 set tomark [list $d]
9833 for {set j 0} {$j < [llength $tomark]} {incr j} {
9834 set dd [lindex $tomark $j]
9835 if {![info exists hastaggedancestor($dd)]} {
9836 if {[info exists done($dd)]} {
9837 foreach b $arcnos($dd) {
9838 lappend tomark $arcstart($b)
9840 if {[info exists tagloc($dd)]} {
9841 unset tagloc($dd)
9843 } elseif {[info exists queued($dd)]} {
9844 incr nc -1
9846 set hastaggedancestor($dd) 1
9850 if {![info exists queued($d)]} {
9851 lappend todo $d
9852 set queued($d) 1
9853 if {![info exists hastaggedancestor($d)]} {
9854 incr nc
9859 set tags {}
9860 foreach id [array names tagloc] {
9861 if {![info exists hastaggedancestor($id)]} {
9862 foreach t $tagloc($id) {
9863 if {[lsearch -exact $tags $t] < 0} {
9864 lappend tags $t
9869 set t2 [clock clicks -milliseconds]
9870 set loopix $i
9872 # remove tags that are descendents of other tags
9873 for {set i 0} {$i < [llength $tags]} {incr i} {
9874 set a [lindex $tags $i]
9875 for {set j 0} {$j < $i} {incr j} {
9876 set b [lindex $tags $j]
9877 set r [anc_or_desc $a $b]
9878 if {$r == 1} {
9879 set tags [lreplace $tags $j $j]
9880 incr j -1
9881 incr i -1
9882 } elseif {$r == -1} {
9883 set tags [lreplace $tags $i $i]
9884 incr i -1
9885 break
9890 if {[array names growing] ne {}} {
9891 # graph isn't finished, need to check if any tag could get
9892 # eclipsed by another tag coming later. Simply ignore any
9893 # tags that could later get eclipsed.
9894 set ctags {}
9895 foreach t $tags {
9896 if {[is_certain $t $origid]} {
9897 lappend ctags $t
9900 if {$tags eq $ctags} {
9901 set cached_dtags($origid) $tags
9902 } else {
9903 set tags $ctags
9905 } else {
9906 set cached_dtags($origid) $tags
9908 set t3 [clock clicks -milliseconds]
9909 if {0 && $t3 - $t1 >= 100} {
9910 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9911 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9913 return $tags
9916 proc anctags {id} {
9917 global arcnos arcids arcout arcend arctags idtags allparents
9918 global growing cached_atags
9920 if {![info exists allparents($id)]} {
9921 return {}
9923 set t1 [clock clicks -milliseconds]
9924 set argid $id
9925 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9926 # part-way along an arc; check that arc first
9927 set a [lindex $arcnos($id) 0]
9928 if {$arctags($a) ne {}} {
9929 validate_arctags $a
9930 set i [lsearch -exact $arcids($a) $id]
9931 foreach t $arctags($a) {
9932 set j [lsearch -exact $arcids($a) $t]
9933 if {$j > $i} {
9934 return $t
9938 if {![info exists arcend($a)]} {
9939 return {}
9941 set id $arcend($a)
9942 if {[info exists idtags($id)]} {
9943 return $id
9946 if {[info exists cached_atags($id)]} {
9947 return $cached_atags($id)
9950 set origid $id
9951 set todo [list $id]
9952 set queued($id) 1
9953 set taglist {}
9954 set nc 1
9955 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9956 set id [lindex $todo $i]
9957 set done($id) 1
9958 set td [info exists hastaggeddescendent($id)]
9959 if {!$td} {
9960 incr nc -1
9962 # ignore tags on starting node
9963 if {!$td && $i > 0} {
9964 if {[info exists idtags($id)]} {
9965 set tagloc($id) $id
9966 set td 1
9967 } elseif {[info exists cached_atags($id)]} {
9968 set tagloc($id) $cached_atags($id)
9969 set td 1
9972 foreach a $arcout($id) {
9973 if {!$td && $arctags($a) ne {}} {
9974 validate_arctags $a
9975 if {$arctags($a) ne {}} {
9976 lappend tagloc($id) [lindex $arctags($a) 0]
9979 if {![info exists arcend($a)]} continue
9980 set d $arcend($a)
9981 if {$td || $arctags($a) ne {}} {
9982 set tomark [list $d]
9983 for {set j 0} {$j < [llength $tomark]} {incr j} {
9984 set dd [lindex $tomark $j]
9985 if {![info exists hastaggeddescendent($dd)]} {
9986 if {[info exists done($dd)]} {
9987 foreach b $arcout($dd) {
9988 if {[info exists arcend($b)]} {
9989 lappend tomark $arcend($b)
9992 if {[info exists tagloc($dd)]} {
9993 unset tagloc($dd)
9995 } elseif {[info exists queued($dd)]} {
9996 incr nc -1
9998 set hastaggeddescendent($dd) 1
10002 if {![info exists queued($d)]} {
10003 lappend todo $d
10004 set queued($d) 1
10005 if {![info exists hastaggeddescendent($d)]} {
10006 incr nc
10011 set t2 [clock clicks -milliseconds]
10012 set loopix $i
10013 set tags {}
10014 foreach id [array names tagloc] {
10015 if {![info exists hastaggeddescendent($id)]} {
10016 foreach t $tagloc($id) {
10017 if {[lsearch -exact $tags $t] < 0} {
10018 lappend tags $t
10024 # remove tags that are ancestors of other tags
10025 for {set i 0} {$i < [llength $tags]} {incr i} {
10026 set a [lindex $tags $i]
10027 for {set j 0} {$j < $i} {incr j} {
10028 set b [lindex $tags $j]
10029 set r [anc_or_desc $a $b]
10030 if {$r == -1} {
10031 set tags [lreplace $tags $j $j]
10032 incr j -1
10033 incr i -1
10034 } elseif {$r == 1} {
10035 set tags [lreplace $tags $i $i]
10036 incr i -1
10037 break
10042 if {[array names growing] ne {}} {
10043 # graph isn't finished, need to check if any tag could get
10044 # eclipsed by another tag coming later. Simply ignore any
10045 # tags that could later get eclipsed.
10046 set ctags {}
10047 foreach t $tags {
10048 if {[is_certain $origid $t]} {
10049 lappend ctags $t
10052 if {$tags eq $ctags} {
10053 set cached_atags($origid) $tags
10054 } else {
10055 set tags $ctags
10057 } else {
10058 set cached_atags($origid) $tags
10060 set t3 [clock clicks -milliseconds]
10061 if {0 && $t3 - $t1 >= 100} {
10062 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10063 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10065 return $tags
10068 # Return the list of IDs that have heads that are descendents of id,
10069 # including id itself if it has a head.
10070 proc descheads {id} {
10071 global arcnos arcstart arcids archeads idheads cached_dheads
10072 global allparents
10074 if {![info exists allparents($id)]} {
10075 return {}
10077 set aret {}
10078 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10079 # part-way along an arc; check it first
10080 set a [lindex $arcnos($id) 0]
10081 if {$archeads($a) ne {}} {
10082 validate_archeads $a
10083 set i [lsearch -exact $arcids($a) $id]
10084 foreach t $archeads($a) {
10085 set j [lsearch -exact $arcids($a) $t]
10086 if {$j > $i} break
10087 lappend aret $t
10090 set id $arcstart($a)
10092 set origid $id
10093 set todo [list $id]
10094 set seen($id) 1
10095 set ret {}
10096 for {set i 0} {$i < [llength $todo]} {incr i} {
10097 set id [lindex $todo $i]
10098 if {[info exists cached_dheads($id)]} {
10099 set ret [concat $ret $cached_dheads($id)]
10100 } else {
10101 if {[info exists idheads($id)]} {
10102 lappend ret $id
10104 foreach a $arcnos($id) {
10105 if {$archeads($a) ne {}} {
10106 validate_archeads $a
10107 if {$archeads($a) ne {}} {
10108 set ret [concat $ret $archeads($a)]
10111 set d $arcstart($a)
10112 if {![info exists seen($d)]} {
10113 lappend todo $d
10114 set seen($d) 1
10119 set ret [lsort -unique $ret]
10120 set cached_dheads($origid) $ret
10121 return [concat $ret $aret]
10124 proc addedtag {id} {
10125 global arcnos arcout cached_dtags cached_atags
10127 if {![info exists arcnos($id)]} return
10128 if {![info exists arcout($id)]} {
10129 recalcarc [lindex $arcnos($id) 0]
10131 catch {unset cached_dtags}
10132 catch {unset cached_atags}
10135 proc addedhead {hid head} {
10136 global arcnos arcout cached_dheads
10138 if {![info exists arcnos($hid)]} return
10139 if {![info exists arcout($hid)]} {
10140 recalcarc [lindex $arcnos($hid) 0]
10142 catch {unset cached_dheads}
10145 proc removedhead {hid head} {
10146 global cached_dheads
10148 catch {unset cached_dheads}
10151 proc movedhead {hid head} {
10152 global arcnos arcout cached_dheads
10154 if {![info exists arcnos($hid)]} return
10155 if {![info exists arcout($hid)]} {
10156 recalcarc [lindex $arcnos($hid) 0]
10158 catch {unset cached_dheads}
10161 proc changedrefs {} {
10162 global cached_dheads cached_dtags cached_atags
10163 global arctags archeads arcnos arcout idheads idtags
10165 foreach id [concat [array names idheads] [array names idtags]] {
10166 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10167 set a [lindex $arcnos($id) 0]
10168 if {![info exists donearc($a)]} {
10169 recalcarc $a
10170 set donearc($a) 1
10174 catch {unset cached_dtags}
10175 catch {unset cached_atags}
10176 catch {unset cached_dheads}
10179 proc rereadrefs {} {
10180 global idtags idheads idotherrefs mainheadid
10182 set refids [concat [array names idtags] \
10183 [array names idheads] [array names idotherrefs]]
10184 foreach id $refids {
10185 if {![info exists ref($id)]} {
10186 set ref($id) [listrefs $id]
10189 set oldmainhead $mainheadid
10190 readrefs
10191 changedrefs
10192 set refids [lsort -unique [concat $refids [array names idtags] \
10193 [array names idheads] [array names idotherrefs]]]
10194 foreach id $refids {
10195 set v [listrefs $id]
10196 if {![info exists ref($id)] || $ref($id) != $v} {
10197 redrawtags $id
10200 if {$oldmainhead ne $mainheadid} {
10201 redrawtags $oldmainhead
10202 redrawtags $mainheadid
10204 run refill_reflist
10207 proc listrefs {id} {
10208 global idtags idheads idotherrefs
10210 set x {}
10211 if {[info exists idtags($id)]} {
10212 set x $idtags($id)
10214 set y {}
10215 if {[info exists idheads($id)]} {
10216 set y $idheads($id)
10218 set z {}
10219 if {[info exists idotherrefs($id)]} {
10220 set z $idotherrefs($id)
10222 return [list $x $y $z]
10225 proc showtag {tag isnew} {
10226 global ctext tagcontents tagids linknum tagobjid
10228 if {$isnew} {
10229 addtohistory [list showtag $tag 0]
10231 $ctext conf -state normal
10232 clear_ctext
10233 settabs 0
10234 set linknum 0
10235 if {![info exists tagcontents($tag)]} {
10236 catch {
10237 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10240 if {[info exists tagcontents($tag)]} {
10241 set text $tagcontents($tag)
10242 } else {
10243 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10245 appendwithlinks $text {}
10246 $ctext conf -state disabled
10247 init_flist {}
10250 proc doquit {} {
10251 global stopped
10252 global gitktmpdir
10254 set stopped 100
10255 savestuff .
10256 destroy .
10258 if {[info exists gitktmpdir]} {
10259 catch {file delete -force $gitktmpdir}
10263 proc mkfontdisp {font top which} {
10264 global fontattr fontpref $font
10266 set fontpref($font) [set $font]
10267 button $top.${font}but -text $which -font optionfont \
10268 -command [list choosefont $font $which]
10269 label $top.$font -relief flat -font $font \
10270 -text $fontattr($font,family) -justify left
10271 grid x $top.${font}but $top.$font -sticky w
10274 proc choosefont {font which} {
10275 global fontparam fontlist fonttop fontattr
10276 global prefstop
10278 set fontparam(which) $which
10279 set fontparam(font) $font
10280 set fontparam(family) [font actual $font -family]
10281 set fontparam(size) $fontattr($font,size)
10282 set fontparam(weight) $fontattr($font,weight)
10283 set fontparam(slant) $fontattr($font,slant)
10284 set top .gitkfont
10285 set fonttop $top
10286 if {![winfo exists $top]} {
10287 font create sample
10288 eval font config sample [font actual $font]
10289 toplevel $top
10290 make_transient $top $prefstop
10291 wm title $top [mc "Gitk font chooser"]
10292 label $top.l -textvariable fontparam(which)
10293 pack $top.l -side top
10294 set fontlist [lsort [font families]]
10295 frame $top.f
10296 listbox $top.f.fam -listvariable fontlist \
10297 -yscrollcommand [list $top.f.sb set]
10298 bind $top.f.fam <<ListboxSelect>> selfontfam
10299 scrollbar $top.f.sb -command [list $top.f.fam yview]
10300 pack $top.f.sb -side right -fill y
10301 pack $top.f.fam -side left -fill both -expand 1
10302 pack $top.f -side top -fill both -expand 1
10303 frame $top.g
10304 spinbox $top.g.size -from 4 -to 40 -width 4 \
10305 -textvariable fontparam(size) \
10306 -validatecommand {string is integer -strict %s}
10307 checkbutton $top.g.bold -padx 5 \
10308 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10309 -variable fontparam(weight) -onvalue bold -offvalue normal
10310 checkbutton $top.g.ital -padx 5 \
10311 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10312 -variable fontparam(slant) -onvalue italic -offvalue roman
10313 pack $top.g.size $top.g.bold $top.g.ital -side left
10314 pack $top.g -side top
10315 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10316 -background white
10317 $top.c create text 100 25 -anchor center -text $which -font sample \
10318 -fill black -tags text
10319 bind $top.c <Configure> [list centertext $top.c]
10320 pack $top.c -side top -fill x
10321 frame $top.buts
10322 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10323 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10324 bind $top <Key-Return> fontok
10325 bind $top <Key-Escape> fontcan
10326 grid $top.buts.ok $top.buts.can
10327 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10328 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10329 pack $top.buts -side bottom -fill x
10330 trace add variable fontparam write chg_fontparam
10331 } else {
10332 raise $top
10333 $top.c itemconf text -text $which
10335 set i [lsearch -exact $fontlist $fontparam(family)]
10336 if {$i >= 0} {
10337 $top.f.fam selection set $i
10338 $top.f.fam see $i
10342 proc centertext {w} {
10343 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10346 proc fontok {} {
10347 global fontparam fontpref prefstop
10349 set f $fontparam(font)
10350 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10351 if {$fontparam(weight) eq "bold"} {
10352 lappend fontpref($f) "bold"
10354 if {$fontparam(slant) eq "italic"} {
10355 lappend fontpref($f) "italic"
10357 set w $prefstop.$f
10358 $w conf -text $fontparam(family) -font $fontpref($f)
10360 fontcan
10363 proc fontcan {} {
10364 global fonttop fontparam
10366 if {[info exists fonttop]} {
10367 catch {destroy $fonttop}
10368 catch {font delete sample}
10369 unset fonttop
10370 unset fontparam
10374 proc selfontfam {} {
10375 global fonttop fontparam
10377 set i [$fonttop.f.fam curselection]
10378 if {$i ne {}} {
10379 set fontparam(family) [$fonttop.f.fam get $i]
10383 proc chg_fontparam {v sub op} {
10384 global fontparam
10386 font config sample -$sub $fontparam($sub)
10389 proc doprefs {} {
10390 global maxwidth maxgraphpct
10391 global oldprefs prefstop showneartags showlocalchanges
10392 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10393 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10394 global hideremotes
10396 set top .gitkprefs
10397 set prefstop $top
10398 if {[winfo exists $top]} {
10399 raise $top
10400 return
10402 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10403 limitdiffs tabstop perfile_attrs hideremotes} {
10404 set oldprefs($v) [set $v]
10406 toplevel $top
10407 wm title $top [mc "Gitk preferences"]
10408 make_transient $top .
10409 label $top.ldisp -text [mc "Commit list display options"]
10410 grid $top.ldisp - -sticky w -pady 10
10411 label $top.spacer -text " "
10412 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10413 -font optionfont
10414 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10415 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10416 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10417 -font optionfont
10418 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10419 grid x $top.maxpctl $top.maxpct -sticky w
10420 checkbutton $top.showlocal -text [mc "Show local changes"] \
10421 -font optionfont -variable showlocalchanges
10422 grid x $top.showlocal -sticky w
10423 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10424 -font optionfont -variable autoselect
10425 grid x $top.autoselect -sticky w
10427 label $top.ddisp -text [mc "Diff display options"]
10428 grid $top.ddisp - -sticky w -pady 10
10429 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10430 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10431 grid x $top.tabstopl $top.tabstop -sticky w
10432 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10433 -font optionfont -variable showneartags
10434 grid x $top.ntag -sticky w
10435 checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10436 -font optionfont -variable hideremotes
10437 grid x $top.hideremotes -sticky w
10438 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10439 -font optionfont -variable limitdiffs
10440 grid x $top.ldiff -sticky w
10441 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10442 -font optionfont -variable perfile_attrs
10443 grid x $top.lattr -sticky w
10445 entry $top.extdifft -textvariable extdifftool
10446 frame $top.extdifff
10447 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10448 -padx 10
10449 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10450 -command choose_extdiff
10451 pack $top.extdifff.l $top.extdifff.b -side left
10452 grid x $top.extdifff $top.extdifft -sticky w
10454 label $top.cdisp -text [mc "Colors: press to choose"]
10455 grid $top.cdisp - -sticky w -pady 10
10456 label $top.bg -padx 40 -relief sunk -background $bgcolor
10457 button $top.bgbut -text [mc "Background"] -font optionfont \
10458 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10459 grid x $top.bgbut $top.bg -sticky w
10460 label $top.fg -padx 40 -relief sunk -background $fgcolor
10461 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10462 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10463 grid x $top.fgbut $top.fg -sticky w
10464 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10465 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10466 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10467 [list $ctext tag conf d0 -foreground]]
10468 grid x $top.diffoldbut $top.diffold -sticky w
10469 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10470 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10471 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10472 [list $ctext tag conf dresult -foreground]]
10473 grid x $top.diffnewbut $top.diffnew -sticky w
10474 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10475 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10476 -command [list choosecolor diffcolors 2 $top.hunksep \
10477 [mc "diff hunk header"] \
10478 [list $ctext tag conf hunksep -foreground]]
10479 grid x $top.hunksepbut $top.hunksep -sticky w
10480 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10481 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10482 -command [list choosecolor markbgcolor {} $top.markbgsep \
10483 [mc "marked line background"] \
10484 [list $ctext tag conf omark -background]]
10485 grid x $top.markbgbut $top.markbgsep -sticky w
10486 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10487 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10488 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10489 grid x $top.selbgbut $top.selbgsep -sticky w
10491 label $top.cfont -text [mc "Fonts: press to choose"]
10492 grid $top.cfont - -sticky w -pady 10
10493 mkfontdisp mainfont $top [mc "Main font"]
10494 mkfontdisp textfont $top [mc "Diff display font"]
10495 mkfontdisp uifont $top [mc "User interface font"]
10497 frame $top.buts
10498 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10499 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10500 bind $top <Key-Return> prefsok
10501 bind $top <Key-Escape> prefscan
10502 grid $top.buts.ok $top.buts.can
10503 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10504 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10505 grid $top.buts - - -pady 10 -sticky ew
10506 bind $top <Visibility> "focus $top.buts.ok"
10509 proc choose_extdiff {} {
10510 global extdifftool
10512 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10513 if {$prog ne {}} {
10514 set extdifftool $prog
10518 proc choosecolor {v vi w x cmd} {
10519 global $v
10521 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10522 -title [mc "Gitk: choose color for %s" $x]]
10523 if {$c eq {}} return
10524 $w conf -background $c
10525 lset $v $vi $c
10526 eval $cmd $c
10529 proc setselbg {c} {
10530 global bglist cflist
10531 foreach w $bglist {
10532 $w configure -selectbackground $c
10534 $cflist tag configure highlight \
10535 -background [$cflist cget -selectbackground]
10536 allcanvs itemconf secsel -fill $c
10539 proc setbg {c} {
10540 global bglist
10542 foreach w $bglist {
10543 $w conf -background $c
10547 proc setfg {c} {
10548 global fglist canv
10550 foreach w $fglist {
10551 $w conf -foreground $c
10553 allcanvs itemconf text -fill $c
10554 $canv itemconf circle -outline $c
10555 $canv itemconf markid -outline $c
10558 proc prefscan {} {
10559 global oldprefs prefstop
10561 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10562 limitdiffs tabstop perfile_attrs hideremotes} {
10563 global $v
10564 set $v $oldprefs($v)
10566 catch {destroy $prefstop}
10567 unset prefstop
10568 fontcan
10571 proc prefsok {} {
10572 global maxwidth maxgraphpct
10573 global oldprefs prefstop showneartags showlocalchanges
10574 global fontpref mainfont textfont uifont
10575 global limitdiffs treediffs perfile_attrs
10576 global hideremotes
10578 catch {destroy $prefstop}
10579 unset prefstop
10580 fontcan
10581 set fontchanged 0
10582 if {$mainfont ne $fontpref(mainfont)} {
10583 set mainfont $fontpref(mainfont)
10584 parsefont mainfont $mainfont
10585 eval font configure mainfont [fontflags mainfont]
10586 eval font configure mainfontbold [fontflags mainfont 1]
10587 setcoords
10588 set fontchanged 1
10590 if {$textfont ne $fontpref(textfont)} {
10591 set textfont $fontpref(textfont)
10592 parsefont textfont $textfont
10593 eval font configure textfont [fontflags textfont]
10594 eval font configure textfontbold [fontflags textfont 1]
10596 if {$uifont ne $fontpref(uifont)} {
10597 set uifont $fontpref(uifont)
10598 parsefont uifont $uifont
10599 eval font configure uifont [fontflags uifont]
10601 settabs
10602 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10603 if {$showlocalchanges} {
10604 doshowlocalchanges
10605 } else {
10606 dohidelocalchanges
10609 if {$limitdiffs != $oldprefs(limitdiffs) ||
10610 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10611 # treediffs elements are limited by path;
10612 # won't have encodings cached if perfile_attrs was just turned on
10613 catch {unset treediffs}
10615 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10616 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10617 redisplay
10618 } elseif {$showneartags != $oldprefs(showneartags) ||
10619 $limitdiffs != $oldprefs(limitdiffs)} {
10620 reselectline
10622 if {$hideremotes != $oldprefs(hideremotes)} {
10623 rereadrefs
10627 proc formatdate {d} {
10628 global datetimeformat
10629 if {$d ne {}} {
10630 set d [clock format $d -format $datetimeformat]
10632 return $d
10635 # This list of encoding names and aliases is distilled from
10636 # http://www.iana.org/assignments/character-sets.
10637 # Not all of them are supported by Tcl.
10638 set encoding_aliases {
10639 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10640 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10641 { ISO-10646-UTF-1 csISO10646UTF1 }
10642 { ISO_646.basic:1983 ref csISO646basic1983 }
10643 { INVARIANT csINVARIANT }
10644 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10645 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10646 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10647 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10648 { NATS-DANO iso-ir-9-1 csNATSDANO }
10649 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10650 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10651 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10652 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10653 { ISO-2022-KR csISO2022KR }
10654 { EUC-KR csEUCKR }
10655 { ISO-2022-JP csISO2022JP }
10656 { ISO-2022-JP-2 csISO2022JP2 }
10657 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10658 csISO13JISC6220jp }
10659 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10660 { IT iso-ir-15 ISO646-IT csISO15Italian }
10661 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10662 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10663 { greek7-old iso-ir-18 csISO18Greek7Old }
10664 { latin-greek iso-ir-19 csISO19LatinGreek }
10665 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10666 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10667 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10668 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10669 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10670 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10671 { INIS iso-ir-49 csISO49INIS }
10672 { INIS-8 iso-ir-50 csISO50INIS8 }
10673 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10674 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10675 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10676 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10677 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10678 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10679 csISO60Norwegian1 }
10680 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10681 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10682 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10683 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10684 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10685 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10686 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10687 { greek7 iso-ir-88 csISO88Greek7 }
10688 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10689 { iso-ir-90 csISO90 }
10690 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10691 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10692 csISO92JISC62991984b }
10693 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10694 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10695 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10696 csISO95JIS62291984handadd }
10697 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10698 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10699 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10700 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10701 CP819 csISOLatin1 }
10702 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10703 { T.61-7bit iso-ir-102 csISO102T617bit }
10704 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10705 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10706 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10707 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10708 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10709 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10710 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10711 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10712 arabic csISOLatinArabic }
10713 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10714 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10715 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10716 greek greek8 csISOLatinGreek }
10717 { T.101-G2 iso-ir-128 csISO128T101G2 }
10718 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10719 csISOLatinHebrew }
10720 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10721 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10722 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10723 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10724 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10725 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10726 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10727 csISOLatinCyrillic }
10728 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10729 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10730 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10731 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10732 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10733 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10734 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10735 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10736 { ISO_10367-box iso-ir-155 csISO10367Box }
10737 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10738 { latin-lap lap iso-ir-158 csISO158Lap }
10739 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10740 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10741 { us-dk csUSDK }
10742 { dk-us csDKUS }
10743 { JIS_X0201 X0201 csHalfWidthKatakana }
10744 { KSC5636 ISO646-KR csKSC5636 }
10745 { ISO-10646-UCS-2 csUnicode }
10746 { ISO-10646-UCS-4 csUCS4 }
10747 { DEC-MCS dec csDECMCS }
10748 { hp-roman8 roman8 r8 csHPRoman8 }
10749 { macintosh mac csMacintosh }
10750 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10751 csIBM037 }
10752 { IBM038 EBCDIC-INT cp038 csIBM038 }
10753 { IBM273 CP273 csIBM273 }
10754 { IBM274 EBCDIC-BE CP274 csIBM274 }
10755 { IBM275 EBCDIC-BR cp275 csIBM275 }
10756 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10757 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10758 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10759 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10760 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10761 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10762 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10763 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10764 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10765 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10766 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10767 { IBM437 cp437 437 csPC8CodePage437 }
10768 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10769 { IBM775 cp775 csPC775Baltic }
10770 { IBM850 cp850 850 csPC850Multilingual }
10771 { IBM851 cp851 851 csIBM851 }
10772 { IBM852 cp852 852 csPCp852 }
10773 { IBM855 cp855 855 csIBM855 }
10774 { IBM857 cp857 857 csIBM857 }
10775 { IBM860 cp860 860 csIBM860 }
10776 { IBM861 cp861 861 cp-is csIBM861 }
10777 { IBM862 cp862 862 csPC862LatinHebrew }
10778 { IBM863 cp863 863 csIBM863 }
10779 { IBM864 cp864 csIBM864 }
10780 { IBM865 cp865 865 csIBM865 }
10781 { IBM866 cp866 866 csIBM866 }
10782 { IBM868 CP868 cp-ar csIBM868 }
10783 { IBM869 cp869 869 cp-gr csIBM869 }
10784 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10785 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10786 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10787 { IBM891 cp891 csIBM891 }
10788 { IBM903 cp903 csIBM903 }
10789 { IBM904 cp904 904 csIBBM904 }
10790 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10791 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10792 { IBM1026 CP1026 csIBM1026 }
10793 { EBCDIC-AT-DE csIBMEBCDICATDE }
10794 { EBCDIC-AT-DE-A csEBCDICATDEA }
10795 { EBCDIC-CA-FR csEBCDICCAFR }
10796 { EBCDIC-DK-NO csEBCDICDKNO }
10797 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10798 { EBCDIC-FI-SE csEBCDICFISE }
10799 { EBCDIC-FI-SE-A csEBCDICFISEA }
10800 { EBCDIC-FR csEBCDICFR }
10801 { EBCDIC-IT csEBCDICIT }
10802 { EBCDIC-PT csEBCDICPT }
10803 { EBCDIC-ES csEBCDICES }
10804 { EBCDIC-ES-A csEBCDICESA }
10805 { EBCDIC-ES-S csEBCDICESS }
10806 { EBCDIC-UK csEBCDICUK }
10807 { EBCDIC-US csEBCDICUS }
10808 { UNKNOWN-8BIT csUnknown8BiT }
10809 { MNEMONIC csMnemonic }
10810 { MNEM csMnem }
10811 { VISCII csVISCII }
10812 { VIQR csVIQR }
10813 { KOI8-R csKOI8R }
10814 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10815 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10816 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10817 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10818 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10819 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10820 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10821 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10822 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10823 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10824 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10825 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10826 { IBM1047 IBM-1047 }
10827 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10828 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10829 { UNICODE-1-1 csUnicode11 }
10830 { CESU-8 csCESU-8 }
10831 { BOCU-1 csBOCU-1 }
10832 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10833 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10834 l8 }
10835 { ISO-8859-15 ISO_8859-15 Latin-9 }
10836 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10837 { GBK CP936 MS936 windows-936 }
10838 { JIS_Encoding csJISEncoding }
10839 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10840 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10841 EUC-JP }
10842 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10843 { ISO-10646-UCS-Basic csUnicodeASCII }
10844 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10845 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10846 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10847 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10848 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10849 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10850 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10851 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10852 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10853 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10854 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10855 { Ventura-US csVenturaUS }
10856 { Ventura-International csVenturaInternational }
10857 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10858 { PC8-Turkish csPC8Turkish }
10859 { IBM-Symbols csIBMSymbols }
10860 { IBM-Thai csIBMThai }
10861 { HP-Legal csHPLegal }
10862 { HP-Pi-font csHPPiFont }
10863 { HP-Math8 csHPMath8 }
10864 { Adobe-Symbol-Encoding csHPPSMath }
10865 { HP-DeskTop csHPDesktop }
10866 { Ventura-Math csVenturaMath }
10867 { Microsoft-Publishing csMicrosoftPublishing }
10868 { Windows-31J csWindows31J }
10869 { GB2312 csGB2312 }
10870 { Big5 csBig5 }
10873 proc tcl_encoding {enc} {
10874 global encoding_aliases tcl_encoding_cache
10875 if {[info exists tcl_encoding_cache($enc)]} {
10876 return $tcl_encoding_cache($enc)
10878 set names [encoding names]
10879 set lcnames [string tolower $names]
10880 set enc [string tolower $enc]
10881 set i [lsearch -exact $lcnames $enc]
10882 if {$i < 0} {
10883 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10884 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10885 set i [lsearch -exact $lcnames $encx]
10888 if {$i < 0} {
10889 foreach l $encoding_aliases {
10890 set ll [string tolower $l]
10891 if {[lsearch -exact $ll $enc] < 0} continue
10892 # look through the aliases for one that tcl knows about
10893 foreach e $ll {
10894 set i [lsearch -exact $lcnames $e]
10895 if {$i < 0} {
10896 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10897 set i [lsearch -exact $lcnames $ex]
10900 if {$i >= 0} break
10902 break
10905 set tclenc {}
10906 if {$i >= 0} {
10907 set tclenc [lindex $names $i]
10909 set tcl_encoding_cache($enc) $tclenc
10910 return $tclenc
10913 proc gitattr {path attr default} {
10914 global path_attr_cache
10915 if {[info exists path_attr_cache($attr,$path)]} {
10916 set r $path_attr_cache($attr,$path)
10917 } else {
10918 set r "unspecified"
10919 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10920 regexp "(.*): $attr: (.*)" $line m f r
10922 set path_attr_cache($attr,$path) $r
10924 if {$r eq "unspecified"} {
10925 return $default
10927 return $r
10930 proc cache_gitattr {attr pathlist} {
10931 global path_attr_cache
10932 set newlist {}
10933 foreach path $pathlist {
10934 if {![info exists path_attr_cache($attr,$path)]} {
10935 lappend newlist $path
10938 set lim 1000
10939 if {[tk windowingsystem] == "win32"} {
10940 # windows has a 32k limit on the arguments to a command...
10941 set lim 30
10943 while {$newlist ne {}} {
10944 set head [lrange $newlist 0 [expr {$lim - 1}]]
10945 set newlist [lrange $newlist $lim end]
10946 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10947 foreach row [split $rlist "\n"] {
10948 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
10949 if {[string index $path 0] eq "\""} {
10950 set path [encoding convertfrom [lindex $path 0]]
10952 set path_attr_cache($attr,$path) $value
10959 proc get_path_encoding {path} {
10960 global gui_encoding perfile_attrs
10961 set tcl_enc $gui_encoding
10962 if {$path ne {} && $perfile_attrs} {
10963 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10964 if {$enc2 ne {}} {
10965 set tcl_enc $enc2
10968 return $tcl_enc
10971 # First check that Tcl/Tk is recent enough
10972 if {[catch {package require Tk 8.4} err]} {
10973 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10974 Gitk requires at least Tcl/Tk 8.4."]
10975 exit 1
10978 # defaults...
10979 set wrcomcmd "git diff-tree --stdin -p --pretty"
10981 set gitencoding {}
10982 catch {
10983 set gitencoding [exec git config --get i18n.commitencoding]
10985 catch {
10986 set gitencoding [exec git config --get i18n.logoutputencoding]
10988 if {$gitencoding == ""} {
10989 set gitencoding "utf-8"
10991 set tclencoding [tcl_encoding $gitencoding]
10992 if {$tclencoding == {}} {
10993 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10996 set gui_encoding [encoding system]
10997 catch {
10998 set enc [exec git config --get gui.encoding]
10999 if {$enc ne {}} {
11000 set tclenc [tcl_encoding $enc]
11001 if {$tclenc ne {}} {
11002 set gui_encoding $tclenc
11003 } else {
11004 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11009 if {[tk windowingsystem] eq "aqua"} {
11010 set mainfont {{Lucida Grande} 9}
11011 set textfont {Monaco 9}
11012 set uifont {{Lucida Grande} 9 bold}
11013 } else {
11014 set mainfont {Helvetica 9}
11015 set textfont {Courier 9}
11016 set uifont {Helvetica 9 bold}
11018 set tabstop 8
11019 set findmergefiles 0
11020 set maxgraphpct 50
11021 set maxwidth 16
11022 set revlistorder 0
11023 set fastdate 0
11024 set uparrowlen 5
11025 set downarrowlen 5
11026 set mingaplen 100
11027 set cmitmode "patch"
11028 set wrapcomment "none"
11029 set showneartags 1
11030 set hideremotes 0
11031 set maxrefs 20
11032 set maxlinelen 200
11033 set showlocalchanges 1
11034 set limitdiffs 1
11035 set datetimeformat "%Y-%m-%d %H:%M:%S"
11036 set autoselect 1
11037 set perfile_attrs 0
11039 if {[tk windowingsystem] eq "aqua"} {
11040 set extdifftool "opendiff"
11041 } else {
11042 set extdifftool "meld"
11045 set colors {green red blue magenta darkgrey brown orange}
11046 set bgcolor white
11047 set fgcolor black
11048 set diffcolors {red "#00a000" blue}
11049 set diffcontext 3
11050 set ignorespace 0
11051 set selectbgcolor gray85
11052 set markbgcolor "#e0e0ff"
11054 set circlecolors {white blue gray blue blue}
11056 # button for popping up context menus
11057 if {[tk windowingsystem] eq "aqua"} {
11058 set ctxbut <Button-2>
11059 } else {
11060 set ctxbut <Button-3>
11063 ## For msgcat loading, first locate the installation location.
11064 if { [info exists ::env(GITK_MSGSDIR)] } {
11065 ## Msgsdir was manually set in the environment.
11066 set gitk_msgsdir $::env(GITK_MSGSDIR)
11067 } else {
11068 ## Let's guess the prefix from argv0.
11069 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11070 set gitk_libdir [file join $gitk_prefix share gitk lib]
11071 set gitk_msgsdir [file join $gitk_libdir msgs]
11072 unset gitk_prefix
11075 ## Internationalization (i18n) through msgcat and gettext. See
11076 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11077 package require msgcat
11078 namespace import ::msgcat::mc
11079 ## And eventually load the actual message catalog
11080 ::msgcat::mcload $gitk_msgsdir
11082 catch {source ~/.gitk}
11084 font create optionfont -family sans-serif -size -12
11086 parsefont mainfont $mainfont
11087 eval font create mainfont [fontflags mainfont]
11088 eval font create mainfontbold [fontflags mainfont 1]
11090 parsefont textfont $textfont
11091 eval font create textfont [fontflags textfont]
11092 eval font create textfontbold [fontflags textfont 1]
11094 parsefont uifont $uifont
11095 eval font create uifont [fontflags uifont]
11097 setoptions
11099 # check that we can find a .git directory somewhere...
11100 if {[catch {set gitdir [gitdir]}]} {
11101 show_error {} . [mc "Cannot find a git repository here."]
11102 exit 1
11104 if {![file isdirectory $gitdir]} {
11105 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11106 exit 1
11109 set selecthead {}
11110 set selectheadid {}
11112 set revtreeargs {}
11113 set cmdline_files {}
11114 set i 0
11115 set revtreeargscmd {}
11116 foreach arg $argv {
11117 switch -glob -- $arg {
11118 "" { }
11119 "--" {
11120 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11121 break
11123 "--select-commit=*" {
11124 set selecthead [string range $arg 16 end]
11126 "--argscmd=*" {
11127 set revtreeargscmd [string range $arg 10 end]
11129 default {
11130 lappend revtreeargs $arg
11133 incr i
11136 if {$selecthead eq "HEAD"} {
11137 set selecthead {}
11140 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11141 # no -- on command line, but some arguments (other than --argscmd)
11142 if {[catch {
11143 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11144 set cmdline_files [split $f "\n"]
11145 set n [llength $cmdline_files]
11146 set revtreeargs [lrange $revtreeargs 0 end-$n]
11147 # Unfortunately git rev-parse doesn't produce an error when
11148 # something is both a revision and a filename. To be consistent
11149 # with git log and git rev-list, check revtreeargs for filenames.
11150 foreach arg $revtreeargs {
11151 if {[file exists $arg]} {
11152 show_error {} . [mc "Ambiguous argument '%s': both revision\
11153 and filename" $arg]
11154 exit 1
11157 } err]} {
11158 # unfortunately we get both stdout and stderr in $err,
11159 # so look for "fatal:".
11160 set i [string first "fatal:" $err]
11161 if {$i > 0} {
11162 set err [string range $err [expr {$i + 6}] end]
11164 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11165 exit 1
11169 set nullid "0000000000000000000000000000000000000000"
11170 set nullid2 "0000000000000000000000000000000000000001"
11171 set nullfile "/dev/null"
11173 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11174 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11176 set runq {}
11177 set history {}
11178 set historyindex 0
11179 set fh_serial 0
11180 set nhl_names {}
11181 set highlight_paths {}
11182 set findpattern {}
11183 set searchdirn -forwards
11184 set boldids {}
11185 set boldnameids {}
11186 set diffelide {0 0}
11187 set markingmatches 0
11188 set linkentercount 0
11189 set need_redisplay 0
11190 set nrows_drawn 0
11191 set firsttabstop 0
11193 set nextviewnum 1
11194 set curview 0
11195 set selectedview 0
11196 set selectedhlview [mc "None"]
11197 set highlight_related [mc "None"]
11198 set highlight_files {}
11199 set viewfiles(0) {}
11200 set viewperm(0) 0
11201 set viewargs(0) {}
11202 set viewargscmd(0) {}
11204 set selectedline {}
11205 set numcommits 0
11206 set loginstance 0
11207 set cmdlineok 0
11208 set stopped 0
11209 set stuffsaved 0
11210 set patchnum 0
11211 set lserial 0
11212 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11213 setcoords
11214 makewindow
11215 catch {
11216 image create photo gitlogo -width 16 -height 16
11218 image create photo gitlogominus -width 4 -height 2
11219 gitlogominus put #C00000 -to 0 0 4 2
11220 gitlogo copy gitlogominus -to 1 5
11221 gitlogo copy gitlogominus -to 6 5
11222 gitlogo copy gitlogominus -to 11 5
11223 image delete gitlogominus
11225 image create photo gitlogoplus -width 4 -height 4
11226 gitlogoplus put #008000 -to 1 0 3 4
11227 gitlogoplus put #008000 -to 0 1 4 3
11228 gitlogo copy gitlogoplus -to 1 9
11229 gitlogo copy gitlogoplus -to 6 9
11230 gitlogo copy gitlogoplus -to 11 9
11231 image delete gitlogoplus
11233 image create photo gitlogo32 -width 32 -height 32
11234 gitlogo32 copy gitlogo -zoom 2 2
11236 wm iconphoto . -default gitlogo gitlogo32
11238 # wait for the window to become visible
11239 tkwait visibility .
11240 wm title . "[file tail $argv0]: [file tail [pwd]]"
11241 update
11242 readrefs
11244 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11245 # create a view for the files/dirs specified on the command line
11246 set curview 1
11247 set selectedview 1
11248 set nextviewnum 2
11249 set viewname(1) [mc "Command line"]
11250 set viewfiles(1) $cmdline_files
11251 set viewargs(1) $revtreeargs
11252 set viewargscmd(1) $revtreeargscmd
11253 set viewperm(1) 0
11254 set vdatemode(1) 0
11255 addviewmenu 1
11256 .bar.view entryconf [mca "Edit view..."] -state normal
11257 .bar.view entryconf [mca "Delete view"] -state normal
11260 if {[info exists permviews]} {
11261 foreach v $permviews {
11262 set n $nextviewnum
11263 incr nextviewnum
11264 set viewname($n) [lindex $v 0]
11265 set viewfiles($n) [lindex $v 1]
11266 set viewargs($n) [lindex $v 2]
11267 set viewargscmd($n) [lindex $v 3]
11268 set viewperm($n) 1
11269 addviewmenu $n
11273 if {[tk windowingsystem] eq "win32"} {
11274 focus -force .
11277 getcommits {}