gitk: Make cherry-pick call git-citool on conflicts
[git/gitweb.git] / gitk
blob4168648b520967a9bf9aff2a5926736fc1694eb1
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 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
160 "-[puabwcrRBMC]" -
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 lappend diffargs $arg
168 # These cause our parsing of git log's output to fail, or else
169 # they're options we want to set ourselves, so ignore them.
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
178 # These are harmless, and some are even useful
179 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181 "--full-history" - "--dense" - "--sparse" -
182 "--follow" - "--left-right" - "--encoding=*" {
183 lappend glflags $arg
185 # These mean that we get a subset of the commits
186 "--diff-filter=*" - "--no-merges" - "--unpacked" -
187 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190 "--remove-empty" - "--first-parent" - "--cherry-pick" -
191 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
192 set filtered 1
193 lappend glflags $arg
195 # This appears to be the only one that has a value as a
196 # separate word following it
197 "-n" {
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" {
203 set notflag [expr {!$notflag}]
204 lappend revargs $arg
206 "--all" {
207 lappend revargs $arg
209 "--merge" {
210 set vmergeonly($n) 1
211 # git rev-parse doesn't understand --merge
212 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 "-*" {
216 if {[string is digit -strict [string range $arg 1 end]]} {
217 set filtered 1
218 } else {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
221 set allknown 0
223 lappend glflags $arg
225 # Non-flag arguments specify commits or ranges of commits
226 default {
227 if {[string match "*...*" $arg]} {
228 lappend revargs --gitk-symmetric-diff-marker
230 lappend revargs $arg
234 set vdflags($n) $diffargs
235 set vflags($n) $glflags
236 set vrevs($n) $revargs
237 set vfiltered($n) $filtered
238 set vorigargs($n) $origargs
239 return $allknown
242 proc parseviewrevs {view revs} {
243 global vposids vnegids
245 if {$revs eq {}} {
246 set revs HEAD
248 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines [split $err "\n"]
252 set badrev {}
253 for {set l 0} {$l < [llength $errlines]} {incr l} {
254 set line [lindex $errlines $l]
255 if {!([string length $line] == 40 && [string is xdigit $line])} {
256 if {[string match "fatal:*" $line]} {
257 if {[string match "fatal: ambiguous argument*" $line]
258 && $badrev ne {}} {
259 if {[llength $badrev] == 1} {
260 set err "unknown revision $badrev"
261 } else {
262 set err "unknown revisions: [join $badrev ", "]"
264 } else {
265 set err [join [lrange $errlines $l end] "\n"]
267 break
269 lappend badrev $line
272 error_popup "[mc "Error parsing revisions:"] $err"
273 return {}
275 set ret {}
276 set pos {}
277 set neg {}
278 set sdm 0
279 foreach id [split $ids "\n"] {
280 if {$id eq "--gitk-symmetric-diff-marker"} {
281 set sdm 4
282 } elseif {[string match "^*" $id]} {
283 if {$sdm != 1} {
284 lappend ret $id
285 if {$sdm == 3} {
286 set sdm 0
289 lappend neg [string range $id 1 end]
290 } else {
291 if {$sdm != 2} {
292 lappend ret $id
293 } else {
294 lset ret end [lindex $ret end]...$id
296 lappend pos $id
298 incr sdm -1
300 set vposids($view) $pos
301 set vnegids($view) $neg
302 return $ret
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list {view} {
307 global startmsecs commitidx viewcomplete curview
308 global tclencoding
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges
311 global viewactive viewinstances vmergeonly
312 global mainheadid
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs [clock clicks -milliseconds]
316 set commitidx($view) 0
317 # these are set this way for the error exits
318 set viewcomplete($view) 1
319 set viewactive($view) 0
320 varcinit $view
322 set args $viewargs($view)
323 if {$viewargscmd($view) ne {}} {
324 if {[catch {
325 set str [exec sh -c $viewargscmd($view)]
326 } err]} {
327 error_popup "[mc "Error executing --argscmd command:"] $err"
328 return 0
330 set args [concat $args [split $str "\n"]]
332 set vcanopt($view) [parseviewargs $view $args]
334 set files $viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files [unmerged_files $files]
337 if {$files eq {}} {
338 global nr_unmerged
339 if {$nr_unmerged == 0} {
340 error_popup [mc "No files selected: --merge specified but\
341 no files are unmerged."]
342 } else {
343 error_popup [mc "No files selected: --merge specified but\
344 no unmerged files are within file limit."]
346 return 0
349 set vfilelimit($view) $files
351 if {$vcanopt($view)} {
352 set revs [parseviewrevs $view $vrevs($view)]
353 if {$revs eq {}} {
354 return 0
356 set args [concat $vflags($view) $revs]
357 } else {
358 set args $vorigargs($view)
361 if {[catch {
362 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
363 --boundary $args "--" $files] r]
364 } err]} {
365 error_popup "[mc "Error executing git log:"] $err"
366 return 0
368 set i [reg_instance $fd]
369 set viewinstances($view) [list $i]
370 if {$showlocalchanges && $mainheadid ne {}} {
371 interestedin $mainheadid dodiffindex
373 fconfigure $fd -blocking 0 -translation lf -eofchar {}
374 if {$tclencoding != {}} {
375 fconfigure $fd -encoding $tclencoding
377 filerun $fd [list getcommitlines $fd $i $view 0]
378 nowbusy $view [mc "Reading"]
379 set viewcomplete($view) 0
380 set viewactive($view) 1
381 return 1
384 proc stop_instance {inst} {
385 global commfd leftover
387 set fd $commfd($inst)
388 catch {
389 set pid [pid $fd]
391 if {$::tcl_platform(platform) eq {windows}} {
392 exec kill -f $pid
393 } else {
394 exec kill $pid
397 catch {close $fd}
398 nukefile $fd
399 unset commfd($inst)
400 unset leftover($inst)
403 proc stop_backends {} {
404 global commfd
406 foreach inst [array names commfd] {
407 stop_instance $inst
411 proc stop_rev_list {view} {
412 global viewinstances
414 foreach inst $viewinstances($view) {
415 stop_instance $inst
417 set viewinstances($view) {}
420 proc reset_pending_select {selid} {
421 global pending_select mainheadid selectheadid
423 if {$selid ne {}} {
424 set pending_select $selid
425 } elseif {$selectheadid ne {}} {
426 set pending_select $selectheadid
427 } else {
428 set pending_select $mainheadid
432 proc getcommits {selid} {
433 global canv curview need_redisplay viewactive
435 initlayout
436 if {[start_rev_list $curview]} {
437 reset_pending_select $selid
438 show_status [mc "Reading commits..."]
439 set need_redisplay 1
440 } else {
441 show_status [mc "No commits selected"]
445 proc updatecommits {} {
446 global curview vcanopt vorigargs vfilelimit viewinstances
447 global viewactive viewcomplete tclencoding
448 global startmsecs showneartags showlocalchanges
449 global mainheadid pending_select
450 global isworktree
451 global varcid vposids vnegids vflags vrevs
453 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
454 set oldmainid $mainheadid
455 rereadrefs
456 if {$showlocalchanges} {
457 if {$mainheadid ne $oldmainid} {
458 dohidelocalchanges
460 if {[commitinview $mainheadid $curview]} {
461 dodiffindex
464 set view $curview
465 if {$vcanopt($view)} {
466 set oldpos $vposids($view)
467 set oldneg $vnegids($view)
468 set revs [parseviewrevs $view $vrevs($view)]
469 if {$revs eq {}} {
470 return
472 # note: getting the delta when negative refs change is hard,
473 # and could require multiple git log invocations, so in that
474 # case we ask git log for all the commits (not just the delta)
475 if {$oldneg eq $vnegids($view)} {
476 set newrevs {}
477 set npos 0
478 # take out positive refs that we asked for before or
479 # that we have already seen
480 foreach rev $revs {
481 if {[string length $rev] == 40} {
482 if {[lsearch -exact $oldpos $rev] < 0
483 && ![info exists varcid($view,$rev)]} {
484 lappend newrevs $rev
485 incr npos
487 } else {
488 lappend $newrevs $rev
491 if {$npos == 0} return
492 set revs $newrevs
493 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
495 set args [concat $vflags($view) $revs --not $oldpos]
496 } else {
497 set args $vorigargs($view)
499 if {[catch {
500 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
501 --boundary $args "--" $vfilelimit($view)] r]
502 } err]} {
503 error_popup "[mc "Error executing git log:"] $err"
504 return
506 if {$viewactive($view) == 0} {
507 set startmsecs [clock clicks -milliseconds]
509 set i [reg_instance $fd]
510 lappend viewinstances($view) $i
511 fconfigure $fd -blocking 0 -translation lf -eofchar {}
512 if {$tclencoding != {}} {
513 fconfigure $fd -encoding $tclencoding
515 filerun $fd [list getcommitlines $fd $i $view 1]
516 incr viewactive($view)
517 set viewcomplete($view) 0
518 reset_pending_select {}
519 nowbusy $view "Reading"
520 if {$showneartags} {
521 getallcommits
525 proc reloadcommits {} {
526 global curview viewcomplete selectedline currentid thickerline
527 global showneartags treediffs commitinterest cached_commitrow
528 global targetid
530 set selid {}
531 if {$selectedline ne {}} {
532 set selid $currentid
535 if {!$viewcomplete($curview)} {
536 stop_rev_list $curview
538 resetvarcs $curview
539 set selectedline {}
540 catch {unset currentid}
541 catch {unset thickerline}
542 catch {unset treediffs}
543 readrefs
544 changedrefs
545 if {$showneartags} {
546 getallcommits
548 clear_display
549 catch {unset commitinterest}
550 catch {unset cached_commitrow}
551 catch {unset targetid}
552 setcanvscroll
553 getcommits $selid
554 return 0
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
559 proc strrep {n} {
560 if {$n < 16} {
561 return [format "%x" $n]
562 } elseif {$n < 256} {
563 return [format "x%.2x" $n]
564 } elseif {$n < 65536} {
565 return [format "y%.4x" $n]
567 return [format "z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit {view} {
574 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575 global vtokmod varcmod vrowmod varcix vlastins
577 set varcstart($view) {{}}
578 set vupptr($view) {0}
579 set vdownptr($view) {0}
580 set vleftptr($view) {0}
581 set vbackptr($view) {0}
582 set varctok($view) {{}}
583 set varcrow($view) {{}}
584 set vtokmod($view) {}
585 set varcmod($view) 0
586 set vrowmod($view) 0
587 set varcix($view) {{}}
588 set vlastins($view) {0}
591 proc resetvarcs {view} {
592 global varcid varccommits parents children vseedcount ordertok
594 foreach vid [array names varcid $view,*] {
595 unset varcid($vid)
596 unset children($vid)
597 unset parents($vid)
599 # some commits might have children but haven't been seen yet
600 foreach vid [array names children $view,*] {
601 unset children($vid)
603 foreach va [array names varccommits $view,*] {
604 unset varccommits($va)
606 foreach vd [array names vseedcount $view,*] {
607 unset vseedcount($vd)
609 catch {unset ordertok}
612 # returns a list of the commits with no children
613 proc seeds {v} {
614 global vdownptr vleftptr varcstart
616 set ret {}
617 set a [lindex $vdownptr($v) 0]
618 while {$a != 0} {
619 lappend ret [lindex $varcstart($v) $a]
620 set a [lindex $vleftptr($v) $a]
622 return $ret
625 proc newvarc {view id} {
626 global varcid varctok parents children vdatemode
627 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628 global commitdata commitinfo vseedcount varccommits vlastins
630 set a [llength $varctok($view)]
631 set vid $view,$id
632 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
633 if {![info exists commitinfo($id)]} {
634 parsecommit $id $commitdata($id) 1
636 set cdate [lindex $commitinfo($id) 4]
637 if {![string is integer -strict $cdate]} {
638 set cdate 0
640 if {![info exists vseedcount($view,$cdate)]} {
641 set vseedcount($view,$cdate) -1
643 set c [incr vseedcount($view,$cdate)]
644 set cdate [expr {$cdate ^ 0xffffffff}]
645 set tok "s[strrep $cdate][strrep $c]"
646 } else {
647 set tok {}
649 set ka 0
650 if {[llength $children($vid)] > 0} {
651 set kid [lindex $children($vid) end]
652 set k $varcid($view,$kid)
653 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
654 set ki $kid
655 set ka $k
656 set tok [lindex $varctok($view) $k]
659 if {$ka != 0} {
660 set i [lsearch -exact $parents($view,$ki) $id]
661 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
662 append tok [strrep $j]
664 set c [lindex $vlastins($view) $ka]
665 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
666 set c $ka
667 set b [lindex $vdownptr($view) $ka]
668 } else {
669 set b [lindex $vleftptr($view) $c]
671 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
672 set c $b
673 set b [lindex $vleftptr($view) $c]
675 if {$c == $ka} {
676 lset vdownptr($view) $ka $a
677 lappend vbackptr($view) 0
678 } else {
679 lset vleftptr($view) $c $a
680 lappend vbackptr($view) $c
682 lset vlastins($view) $ka $a
683 lappend vupptr($view) $ka
684 lappend vleftptr($view) $b
685 if {$b != 0} {
686 lset vbackptr($view) $b $a
688 lappend varctok($view) $tok
689 lappend varcstart($view) $id
690 lappend vdownptr($view) 0
691 lappend varcrow($view) {}
692 lappend varcix($view) {}
693 set varccommits($view,$a) {}
694 lappend vlastins($view) 0
695 return $a
698 proc splitvarc {p v} {
699 global varcid varcstart varccommits varctok
700 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702 set oa $varcid($v,$p)
703 set ac $varccommits($v,$oa)
704 set i [lsearch -exact $varccommits($v,$oa) $p]
705 if {$i <= 0} return
706 set na [llength $varctok($v)]
707 # "%" sorts before "0"...
708 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
709 lappend varctok($v) $tok
710 lappend varcrow($v) {}
711 lappend varcix($v) {}
712 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
713 set varccommits($v,$na) [lrange $ac $i end]
714 lappend varcstart($v) $p
715 foreach id $varccommits($v,$na) {
716 set varcid($v,$id) $na
718 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
719 lappend vlastins($v) [lindex $vlastins($v) $oa]
720 lset vdownptr($v) $oa $na
721 lset vlastins($v) $oa 0
722 lappend vupptr($v) $oa
723 lappend vleftptr($v) 0
724 lappend vbackptr($v) 0
725 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
726 lset vupptr($v) $b $na
730 proc renumbervarc {a v} {
731 global parents children varctok varcstart varccommits
732 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734 set t1 [clock clicks -milliseconds]
735 set todo {}
736 set isrelated($a) 1
737 set kidchanged($a) 1
738 set ntot 0
739 while {$a != 0} {
740 if {[info exists isrelated($a)]} {
741 lappend todo $a
742 set id [lindex $varccommits($v,$a) end]
743 foreach p $parents($v,$id) {
744 if {[info exists varcid($v,$p)]} {
745 set isrelated($varcid($v,$p)) 1
749 incr ntot
750 set b [lindex $vdownptr($v) $a]
751 if {$b == 0} {
752 while {$a != 0} {
753 set b [lindex $vleftptr($v) $a]
754 if {$b != 0} break
755 set a [lindex $vupptr($v) $a]
758 set a $b
760 foreach a $todo {
761 if {![info exists kidchanged($a)]} continue
762 set id [lindex $varcstart($v) $a]
763 if {[llength $children($v,$id)] > 1} {
764 set children($v,$id) [lsort -command [list vtokcmp $v] \
765 $children($v,$id)]
767 set oldtok [lindex $varctok($v) $a]
768 if {!$vdatemode($v)} {
769 set tok {}
770 } else {
771 set tok $oldtok
773 set ka 0
774 set kid [last_real_child $v,$id]
775 if {$kid ne {}} {
776 set k $varcid($v,$kid)
777 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
778 set ki $kid
779 set ka $k
780 set tok [lindex $varctok($v) $k]
783 if {$ka != 0} {
784 set i [lsearch -exact $parents($v,$ki) $id]
785 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
786 append tok [strrep $j]
788 if {$tok eq $oldtok} {
789 continue
791 set id [lindex $varccommits($v,$a) end]
792 foreach p $parents($v,$id) {
793 if {[info exists varcid($v,$p)]} {
794 set kidchanged($varcid($v,$p)) 1
795 } else {
796 set sortkids($p) 1
799 lset varctok($v) $a $tok
800 set b [lindex $vupptr($v) $a]
801 if {$b != $ka} {
802 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
803 modify_arc $v $ka
805 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
806 modify_arc $v $b
808 set c [lindex $vbackptr($v) $a]
809 set d [lindex $vleftptr($v) $a]
810 if {$c == 0} {
811 lset vdownptr($v) $b $d
812 } else {
813 lset vleftptr($v) $c $d
815 if {$d != 0} {
816 lset vbackptr($v) $d $c
818 if {[lindex $vlastins($v) $b] == $a} {
819 lset vlastins($v) $b $c
821 lset vupptr($v) $a $ka
822 set c [lindex $vlastins($v) $ka]
823 if {$c == 0 || \
824 [string compare $tok [lindex $varctok($v) $c]] < 0} {
825 set c $ka
826 set b [lindex $vdownptr($v) $ka]
827 } else {
828 set b [lindex $vleftptr($v) $c]
830 while {$b != 0 && \
831 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
832 set c $b
833 set b [lindex $vleftptr($v) $c]
835 if {$c == $ka} {
836 lset vdownptr($v) $ka $a
837 lset vbackptr($v) $a 0
838 } else {
839 lset vleftptr($v) $c $a
840 lset vbackptr($v) $a $c
842 lset vleftptr($v) $a $b
843 if {$b != 0} {
844 lset vbackptr($v) $b $a
846 lset vlastins($v) $ka $a
849 foreach id [array names sortkids] {
850 if {[llength $children($v,$id)] > 1} {
851 set children($v,$id) [lsort -command [list vtokcmp $v] \
852 $children($v,$id)]
855 set t2 [clock clicks -milliseconds]
856 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal {p a v} {
863 global varcid varcstart varctok vupptr
865 set pa $varcid($v,$p)
866 if {$p ne [lindex $varcstart($v) $pa]} {
867 splitvarc $p $v
868 set pa $varcid($v,$p)
870 # seeds always need to be renumbered
871 if {[lindex $vupptr($v) $pa] == 0 ||
872 [string compare [lindex $varctok($v) $a] \
873 [lindex $varctok($v) $pa]] > 0} {
874 renumbervarc $pa $v
878 proc insertrow {id p v} {
879 global cmitlisted children parents varcid varctok vtokmod
880 global varccommits ordertok commitidx numcommits curview
881 global targetid targetrow
883 readcommit $id
884 set vid $v,$id
885 set cmitlisted($vid) 1
886 set children($vid) {}
887 set parents($vid) [list $p]
888 set a [newvarc $v $id]
889 set varcid($vid) $a
890 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
891 modify_arc $v $a
893 lappend varccommits($v,$a) $id
894 set vp $v,$p
895 if {[llength [lappend children($vp) $id]] > 1} {
896 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
897 catch {unset ordertok}
899 fix_reversal $p $a $v
900 incr commitidx($v)
901 if {$v == $curview} {
902 set numcommits $commitidx($v)
903 setcanvscroll
904 if {[info exists targetid]} {
905 if {![comes_before $targetid $p]} {
906 incr targetrow
912 proc insertfakerow {id p} {
913 global varcid varccommits parents children cmitlisted
914 global commitidx varctok vtokmod targetid targetrow curview numcommits
916 set v $curview
917 set a $varcid($v,$p)
918 set i [lsearch -exact $varccommits($v,$a) $p]
919 if {$i < 0} {
920 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
921 return
923 set children($v,$id) {}
924 set parents($v,$id) [list $p]
925 set varcid($v,$id) $a
926 lappend children($v,$p) $id
927 set cmitlisted($v,$id) 1
928 set numcommits [incr commitidx($v)]
929 # note we deliberately don't update varcstart($v) even if $i == 0
930 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
931 modify_arc $v $a $i
932 if {[info exists targetid]} {
933 if {![comes_before $targetid $p]} {
934 incr targetrow
937 setcanvscroll
938 drawvisible
941 proc removefakerow {id} {
942 global varcid varccommits parents children commitidx
943 global varctok vtokmod cmitlisted currentid selectedline
944 global targetid curview numcommits
946 set v $curview
947 if {[llength $parents($v,$id)] != 1} {
948 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
949 return
951 set p [lindex $parents($v,$id) 0]
952 set a $varcid($v,$id)
953 set i [lsearch -exact $varccommits($v,$a) $id]
954 if {$i < 0} {
955 puts "oops: removefakerow can't find [shortids $id] on arc $a"
956 return
958 unset varcid($v,$id)
959 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
960 unset parents($v,$id)
961 unset children($v,$id)
962 unset cmitlisted($v,$id)
963 set numcommits [incr commitidx($v) -1]
964 set j [lsearch -exact $children($v,$p) $id]
965 if {$j >= 0} {
966 set children($v,$p) [lreplace $children($v,$p) $j $j]
968 modify_arc $v $a $i
969 if {[info exist currentid] && $id eq $currentid} {
970 unset currentid
971 set selectedline {}
973 if {[info exists targetid] && $targetid eq $id} {
974 set targetid $p
976 setcanvscroll
977 drawvisible
980 proc first_real_child {vp} {
981 global children nullid nullid2
983 foreach id $children($vp) {
984 if {$id ne $nullid && $id ne $nullid2} {
985 return $id
988 return {}
991 proc last_real_child {vp} {
992 global children nullid nullid2
994 set kids $children($vp)
995 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
996 set id [lindex $kids $i]
997 if {$id ne $nullid && $id ne $nullid2} {
998 return $id
1001 return {}
1004 proc vtokcmp {v a b} {
1005 global varctok varcid
1007 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1008 [lindex $varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc {v a {lim {}}} {
1014 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1016 if {$lim ne {}} {
1017 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1018 if {$c > 0} return
1019 if {$c == 0} {
1020 set r [lindex $varcrow($v) $a]
1021 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1024 set vtokmod($v) [lindex $varctok($v) $a]
1025 set varcmod($v) $a
1026 if {$v == $curview} {
1027 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1028 set a [lindex $vupptr($v) $a]
1029 set lim {}
1031 set r 0
1032 if {$a != 0} {
1033 if {$lim eq {}} {
1034 set lim [llength $varccommits($v,$a)]
1036 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1038 set vrowmod($v) $r
1039 undolayout $r
1043 proc update_arcrows {v} {
1044 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045 global varcid vrownum varcorder varcix varccommits
1046 global vupptr vdownptr vleftptr varctok
1047 global displayorder parentlist curview cached_commitrow
1049 if {$vrowmod($v) == $commitidx($v)} return
1050 if {$v == $curview} {
1051 if {[llength $displayorder] > $vrowmod($v)} {
1052 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1053 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1055 catch {unset cached_commitrow}
1057 set narctot [expr {[llength $varctok($v)] - 1}]
1058 set a $varcmod($v)
1059 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1060 # go up the tree until we find something that has a row number,
1061 # or we get to a seed
1062 set a [lindex $vupptr($v) $a]
1064 if {$a == 0} {
1065 set a [lindex $vdownptr($v) 0]
1066 if {$a == 0} return
1067 set vrownum($v) {0}
1068 set varcorder($v) [list $a]
1069 lset varcix($v) $a 0
1070 lset varcrow($v) $a 0
1071 set arcn 0
1072 set row 0
1073 } else {
1074 set arcn [lindex $varcix($v) $a]
1075 if {[llength $vrownum($v)] > $arcn + 1} {
1076 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1077 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1079 set row [lindex $varcrow($v) $a]
1081 while {1} {
1082 set p $a
1083 incr row [llength $varccommits($v,$a)]
1084 # go down if possible
1085 set b [lindex $vdownptr($v) $a]
1086 if {$b == 0} {
1087 # if not, go left, or go up until we can go left
1088 while {$a != 0} {
1089 set b [lindex $vleftptr($v) $a]
1090 if {$b != 0} break
1091 set a [lindex $vupptr($v) $a]
1093 if {$a == 0} break
1095 set a $b
1096 incr arcn
1097 lappend vrownum($v) $row
1098 lappend varcorder($v) $a
1099 lset varcix($v) $a $arcn
1100 lset varcrow($v) $a $row
1102 set vtokmod($v) [lindex $varctok($v) $p]
1103 set varcmod($v) $p
1104 set vrowmod($v) $row
1105 if {[info exists currentid]} {
1106 set selectedline [rowofcommit $currentid]
1110 # Test whether view $v contains commit $id
1111 proc commitinview {id v} {
1112 global varcid
1114 return [info exists varcid($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit {id} {
1119 global varcid varccommits varcrow curview cached_commitrow
1120 global varctok vtokmod
1122 set v $curview
1123 if {![info exists varcid($v,$id)]} {
1124 puts "oops rowofcommit no arc for [shortids $id]"
1125 return {}
1127 set a $varcid($v,$id)
1128 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1129 update_arcrows $v
1131 if {[info exists cached_commitrow($id)]} {
1132 return $cached_commitrow($id)
1134 set i [lsearch -exact $varccommits($v,$a) $id]
1135 if {$i < 0} {
1136 puts "oops didn't find commit [shortids $id] in arc $a"
1137 return {}
1139 incr i [lindex $varcrow($v) $a]
1140 set cached_commitrow($id) $i
1141 return $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before {a b} {
1146 global varcid varctok curview
1148 set v $curview
1149 if {$a eq $b || ![info exists varcid($v,$a)] || \
1150 ![info exists varcid($v,$b)]} {
1151 return 0
1153 if {$varcid($v,$a) != $varcid($v,$b)} {
1154 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1155 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1157 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1160 proc bsearch {l elt} {
1161 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1162 return 0
1164 set lo 0
1165 set hi [llength $l]
1166 while {$hi - $lo > 1} {
1167 set mid [expr {int(($lo + $hi) / 2)}]
1168 set t [lindex $l $mid]
1169 if {$elt < $t} {
1170 set hi $mid
1171 } elseif {$elt > $t} {
1172 set lo $mid
1173 } else {
1174 return $mid
1177 return $lo
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder {start end} {
1182 global vrownum curview commitidx displayorder parentlist
1183 global varccommits varcorder parents vrowmod varcrow
1184 global d_valid_start d_valid_end
1186 if {$end > $vrowmod($curview)} {
1187 update_arcrows $curview
1189 set ai [bsearch $vrownum($curview) $start]
1190 set start [lindex $vrownum($curview) $ai]
1191 set narc [llength $vrownum($curview)]
1192 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1193 set a [lindex $varcorder($curview) $ai]
1194 set l [llength $displayorder]
1195 set al [llength $varccommits($curview,$a)]
1196 if {$l < $r + $al} {
1197 if {$l < $r} {
1198 set pad [ntimes [expr {$r - $l}] {}]
1199 set displayorder [concat $displayorder $pad]
1200 set parentlist [concat $parentlist $pad]
1201 } elseif {$l > $r} {
1202 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1203 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1205 foreach id $varccommits($curview,$a) {
1206 lappend displayorder $id
1207 lappend parentlist $parents($curview,$id)
1209 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1210 set i $r
1211 foreach id $varccommits($curview,$a) {
1212 lset displayorder $i $id
1213 lset parentlist $i $parents($curview,$id)
1214 incr i
1217 incr r $al
1221 proc commitonrow {row} {
1222 global displayorder
1224 set id [lindex $displayorder $row]
1225 if {$id eq {}} {
1226 make_disporder $row [expr {$row + 1}]
1227 set id [lindex $displayorder $row]
1229 return $id
1232 proc closevarcs {v} {
1233 global varctok varccommits varcid parents children
1234 global cmitlisted commitidx vtokmod
1236 set missing_parents 0
1237 set scripts {}
1238 set narcs [llength $varctok($v)]
1239 for {set a 1} {$a < $narcs} {incr a} {
1240 set id [lindex $varccommits($v,$a) end]
1241 foreach p $parents($v,$id) {
1242 if {[info exists varcid($v,$p)]} continue
1243 # add p as a new commit
1244 incr missing_parents
1245 set cmitlisted($v,$p) 0
1246 set parents($v,$p) {}
1247 if {[llength $children($v,$p)] == 1 &&
1248 [llength $parents($v,$id)] == 1} {
1249 set b $a
1250 } else {
1251 set b [newvarc $v $p]
1253 set varcid($v,$p) $b
1254 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1255 modify_arc $v $b
1257 lappend varccommits($v,$b) $p
1258 incr commitidx($v)
1259 set scripts [check_interest $p $scripts]
1262 if {$missing_parents > 0} {
1263 foreach s $scripts {
1264 eval $s
1269 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1270 # Assumes we already have an arc for $rwid.
1271 proc rewrite_commit {v id rwid} {
1272 global children parents varcid varctok vtokmod varccommits
1274 foreach ch $children($v,$id) {
1275 # make $rwid be $ch's parent in place of $id
1276 set i [lsearch -exact $parents($v,$ch) $id]
1277 if {$i < 0} {
1278 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1280 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1281 # add $ch to $rwid's children and sort the list if necessary
1282 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1283 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1284 $children($v,$rwid)]
1286 # fix the graph after joining $id to $rwid
1287 set a $varcid($v,$ch)
1288 fix_reversal $rwid $a $v
1289 # parentlist is wrong for the last element of arc $a
1290 # even if displayorder is right, hence the 3rd arg here
1291 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1295 # Mechanism for registering a command to be executed when we come
1296 # across a particular commit. To handle the case when only the
1297 # prefix of the commit is known, the commitinterest array is now
1298 # indexed by the first 4 characters of the ID. Each element is a
1299 # list of id, cmd pairs.
1300 proc interestedin {id cmd} {
1301 global commitinterest
1303 lappend commitinterest([string range $id 0 3]) $id $cmd
1306 proc check_interest {id scripts} {
1307 global commitinterest
1309 set prefix [string range $id 0 3]
1310 if {[info exists commitinterest($prefix)]} {
1311 set newlist {}
1312 foreach {i script} $commitinterest($prefix) {
1313 if {[string match "$i*" $id]} {
1314 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1315 } else {
1316 lappend newlist $i $script
1319 if {$newlist ne {}} {
1320 set commitinterest($prefix) $newlist
1321 } else {
1322 unset commitinterest($prefix)
1325 return $scripts
1328 proc getcommitlines {fd inst view updating} {
1329 global cmitlisted leftover
1330 global commitidx commitdata vdatemode
1331 global parents children curview hlview
1332 global idpending ordertok
1333 global varccommits varcid varctok vtokmod vfilelimit
1335 set stuff [read $fd 500000]
1336 # git log doesn't terminate the last commit with a null...
1337 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1338 set stuff "\0"
1340 if {$stuff == {}} {
1341 if {![eof $fd]} {
1342 return 1
1344 global commfd viewcomplete viewactive viewname
1345 global viewinstances
1346 unset commfd($inst)
1347 set i [lsearch -exact $viewinstances($view) $inst]
1348 if {$i >= 0} {
1349 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1351 # set it blocking so we wait for the process to terminate
1352 fconfigure $fd -blocking 1
1353 if {[catch {close $fd} err]} {
1354 set fv {}
1355 if {$view != $curview} {
1356 set fv " for the \"$viewname($view)\" view"
1358 if {[string range $err 0 4] == "usage"} {
1359 set err "Gitk: error reading commits$fv:\
1360 bad arguments to git log."
1361 if {$viewname($view) eq "Command line"} {
1362 append err \
1363 " (Note: arguments to gitk are passed to git log\
1364 to allow selection of commits to be displayed.)"
1366 } else {
1367 set err "Error reading commits$fv: $err"
1369 error_popup $err
1371 if {[incr viewactive($view) -1] <= 0} {
1372 set viewcomplete($view) 1
1373 # Check if we have seen any ids listed as parents that haven't
1374 # appeared in the list
1375 closevarcs $view
1376 notbusy $view
1378 if {$view == $curview} {
1379 run chewcommits
1381 return 0
1383 set start 0
1384 set gotsome 0
1385 set scripts {}
1386 while 1 {
1387 set i [string first "\0" $stuff $start]
1388 if {$i < 0} {
1389 append leftover($inst) [string range $stuff $start end]
1390 break
1392 if {$start == 0} {
1393 set cmit $leftover($inst)
1394 append cmit [string range $stuff 0 [expr {$i - 1}]]
1395 set leftover($inst) {}
1396 } else {
1397 set cmit [string range $stuff $start [expr {$i - 1}]]
1399 set start [expr {$i + 1}]
1400 set j [string first "\n" $cmit]
1401 set ok 0
1402 set listed 1
1403 if {$j >= 0 && [string match "commit *" $cmit]} {
1404 set ids [string range $cmit 7 [expr {$j - 1}]]
1405 if {[string match {[-^<>]*} $ids]} {
1406 switch -- [string index $ids 0] {
1407 "-" {set listed 0}
1408 "^" {set listed 2}
1409 "<" {set listed 3}
1410 ">" {set listed 4}
1412 set ids [string range $ids 1 end]
1414 set ok 1
1415 foreach id $ids {
1416 if {[string length $id] != 40} {
1417 set ok 0
1418 break
1422 if {!$ok} {
1423 set shortcmit $cmit
1424 if {[string length $shortcmit] > 80} {
1425 set shortcmit "[string range $shortcmit 0 80]..."
1427 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1428 exit 1
1430 set id [lindex $ids 0]
1431 set vid $view,$id
1433 if {!$listed && $updating && ![info exists varcid($vid)] &&
1434 $vfilelimit($view) ne {}} {
1435 # git log doesn't rewrite parents for unlisted commits
1436 # when doing path limiting, so work around that here
1437 # by working out the rewritten parent with git rev-list
1438 # and if we already know about it, using the rewritten
1439 # parent as a substitute parent for $id's children.
1440 if {![catch {
1441 set rwid [exec git rev-list --first-parent --max-count=1 \
1442 $id -- $vfilelimit($view)]
1443 }]} {
1444 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1445 # use $rwid in place of $id
1446 rewrite_commit $view $id $rwid
1447 continue
1452 set a 0
1453 if {[info exists varcid($vid)]} {
1454 if {$cmitlisted($vid) || !$listed} continue
1455 set a $varcid($vid)
1457 if {$listed} {
1458 set olds [lrange $ids 1 end]
1459 } else {
1460 set olds {}
1462 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1463 set cmitlisted($vid) $listed
1464 set parents($vid) $olds
1465 if {![info exists children($vid)]} {
1466 set children($vid) {}
1467 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1468 set k [lindex $children($vid) 0]
1469 if {[llength $parents($view,$k)] == 1 &&
1470 (!$vdatemode($view) ||
1471 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1472 set a $varcid($view,$k)
1475 if {$a == 0} {
1476 # new arc
1477 set a [newvarc $view $id]
1479 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1480 modify_arc $view $a
1482 if {![info exists varcid($vid)]} {
1483 set varcid($vid) $a
1484 lappend varccommits($view,$a) $id
1485 incr commitidx($view)
1488 set i 0
1489 foreach p $olds {
1490 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1491 set vp $view,$p
1492 if {[llength [lappend children($vp) $id]] > 1 &&
1493 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1494 set children($vp) [lsort -command [list vtokcmp $view] \
1495 $children($vp)]
1496 catch {unset ordertok}
1498 if {[info exists varcid($view,$p)]} {
1499 fix_reversal $p $a $view
1502 incr i
1505 set scripts [check_interest $id $scripts]
1506 set gotsome 1
1508 if {$gotsome} {
1509 global numcommits hlview
1511 if {$view == $curview} {
1512 set numcommits $commitidx($view)
1513 run chewcommits
1515 if {[info exists hlview] && $view == $hlview} {
1516 # we never actually get here...
1517 run vhighlightmore
1519 foreach s $scripts {
1520 eval $s
1523 return 2
1526 proc chewcommits {} {
1527 global curview hlview viewcomplete
1528 global pending_select
1530 layoutmore
1531 if {$viewcomplete($curview)} {
1532 global commitidx varctok
1533 global numcommits startmsecs
1535 if {[info exists pending_select]} {
1536 update
1537 reset_pending_select {}
1539 if {[commitinview $pending_select $curview]} {
1540 selectline [rowofcommit $pending_select] 1
1541 } else {
1542 set row [first_real_row]
1543 selectline $row 1
1546 if {$commitidx($curview) > 0} {
1547 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1548 #puts "overall $ms ms for $numcommits commits"
1549 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1550 } else {
1551 show_status [mc "No commits selected"]
1553 notbusy layout
1555 return 0
1558 proc readcommit {id} {
1559 if {[catch {set contents [exec git cat-file commit $id]}]} return
1560 parsecommit $id $contents 0
1563 proc parsecommit {id contents listed} {
1564 global commitinfo cdate
1566 set inhdr 1
1567 set comment {}
1568 set headline {}
1569 set auname {}
1570 set audate {}
1571 set comname {}
1572 set comdate {}
1573 set hdrend [string first "\n\n" $contents]
1574 if {$hdrend < 0} {
1575 # should never happen...
1576 set hdrend [string length $contents]
1578 set header [string range $contents 0 [expr {$hdrend - 1}]]
1579 set comment [string range $contents [expr {$hdrend + 2}] end]
1580 foreach line [split $header "\n"] {
1581 set tag [lindex $line 0]
1582 if {$tag == "author"} {
1583 set audate [lindex $line end-1]
1584 set auname [lrange $line 1 end-2]
1585 } elseif {$tag == "committer"} {
1586 set comdate [lindex $line end-1]
1587 set comname [lrange $line 1 end-2]
1590 set headline {}
1591 # take the first non-blank line of the comment as the headline
1592 set headline [string trimleft $comment]
1593 set i [string first "\n" $headline]
1594 if {$i >= 0} {
1595 set headline [string range $headline 0 $i]
1597 set headline [string trimright $headline]
1598 set i [string first "\r" $headline]
1599 if {$i >= 0} {
1600 set headline [string trimright [string range $headline 0 $i]]
1602 if {!$listed} {
1603 # git log indents the comment by 4 spaces;
1604 # if we got this via git cat-file, add the indentation
1605 set newcomment {}
1606 foreach line [split $comment "\n"] {
1607 append newcomment " "
1608 append newcomment $line
1609 append newcomment "\n"
1611 set comment $newcomment
1613 if {$comdate != {}} {
1614 set cdate($id) $comdate
1616 set commitinfo($id) [list $headline $auname $audate \
1617 $comname $comdate $comment]
1620 proc getcommit {id} {
1621 global commitdata commitinfo
1623 if {[info exists commitdata($id)]} {
1624 parsecommit $id $commitdata($id) 1
1625 } else {
1626 readcommit $id
1627 if {![info exists commitinfo($id)]} {
1628 set commitinfo($id) [list [mc "No commit information available"]]
1631 return 1
1634 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1635 # and are present in the current view.
1636 # This is fairly slow...
1637 proc longid {prefix} {
1638 global varcid curview
1640 set ids {}
1641 foreach match [array names varcid "$curview,$prefix*"] {
1642 lappend ids [lindex [split $match ","] 1]
1644 return $ids
1647 proc readrefs {} {
1648 global tagids idtags headids idheads tagobjid
1649 global otherrefids idotherrefs mainhead mainheadid
1650 global selecthead selectheadid
1652 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1653 catch {unset $v}
1655 set refd [open [list | git show-ref -d] r]
1656 while {[gets $refd line] >= 0} {
1657 if {[string index $line 40] ne " "} continue
1658 set id [string range $line 0 39]
1659 set ref [string range $line 41 end]
1660 if {![string match "refs/*" $ref]} continue
1661 set name [string range $ref 5 end]
1662 if {[string match "remotes/*" $name]} {
1663 if {![string match "*/HEAD" $name]} {
1664 set headids($name) $id
1665 lappend idheads($id) $name
1667 } elseif {[string match "heads/*" $name]} {
1668 set name [string range $name 6 end]
1669 set headids($name) $id
1670 lappend idheads($id) $name
1671 } elseif {[string match "tags/*" $name]} {
1672 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1673 # which is what we want since the former is the commit ID
1674 set name [string range $name 5 end]
1675 if {[string match "*^{}" $name]} {
1676 set name [string range $name 0 end-3]
1677 } else {
1678 set tagobjid($name) $id
1680 set tagids($name) $id
1681 lappend idtags($id) $name
1682 } else {
1683 set otherrefids($name) $id
1684 lappend idotherrefs($id) $name
1687 catch {close $refd}
1688 set mainhead {}
1689 set mainheadid {}
1690 catch {
1691 set mainheadid [exec git rev-parse HEAD]
1692 set thehead [exec git symbolic-ref HEAD]
1693 if {[string match "refs/heads/*" $thehead]} {
1694 set mainhead [string range $thehead 11 end]
1697 set selectheadid {}
1698 if {$selecthead ne {}} {
1699 catch {
1700 set selectheadid [exec git rev-parse --verify $selecthead]
1705 # skip over fake commits
1706 proc first_real_row {} {
1707 global nullid nullid2 numcommits
1709 for {set row 0} {$row < $numcommits} {incr row} {
1710 set id [commitonrow $row]
1711 if {$id ne $nullid && $id ne $nullid2} {
1712 break
1715 return $row
1718 # update things for a head moved to a child of its previous location
1719 proc movehead {id name} {
1720 global headids idheads
1722 removehead $headids($name) $name
1723 set headids($name) $id
1724 lappend idheads($id) $name
1727 # update things when a head has been removed
1728 proc removehead {id name} {
1729 global headids idheads
1731 if {$idheads($id) eq $name} {
1732 unset idheads($id)
1733 } else {
1734 set i [lsearch -exact $idheads($id) $name]
1735 if {$i >= 0} {
1736 set idheads($id) [lreplace $idheads($id) $i $i]
1739 unset headids($name)
1742 proc show_error {w top msg} {
1743 message $w.m -text $msg -justify center -aspect 400
1744 pack $w.m -side top -fill x -padx 20 -pady 20
1745 button $w.ok -text [mc OK] -command "destroy $top"
1746 pack $w.ok -side bottom -fill x
1747 bind $top <Visibility> "grab $top; focus $top"
1748 bind $top <Key-Return> "destroy $top"
1749 bind $top <Key-space> "destroy $top"
1750 bind $top <Key-Escape> "destroy $top"
1751 tkwait window $top
1754 proc error_popup {msg {owner .}} {
1755 set w .error
1756 toplevel $w
1757 wm transient $w $owner
1758 show_error $w $w $msg
1761 proc confirm_popup {msg {owner .}} {
1762 global confirm_ok
1763 set confirm_ok 0
1764 set w .confirm
1765 toplevel $w
1766 wm transient $w $owner
1767 message $w.m -text $msg -justify center -aspect 400
1768 pack $w.m -side top -fill x -padx 20 -pady 20
1769 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1770 pack $w.ok -side left -fill x
1771 button $w.cancel -text [mc Cancel] -command "destroy $w"
1772 pack $w.cancel -side right -fill x
1773 bind $w <Visibility> "grab $w; focus $w"
1774 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1775 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1776 bind $w <Key-Escape> "destroy $w"
1777 tkwait window $w
1778 return $confirm_ok
1781 proc setoptions {} {
1782 option add *Panedwindow.showHandle 1 startupFile
1783 option add *Panedwindow.sashRelief raised startupFile
1784 option add *Button.font uifont startupFile
1785 option add *Checkbutton.font uifont startupFile
1786 option add *Radiobutton.font uifont startupFile
1787 option add *Menu.font uifont startupFile
1788 option add *Menubutton.font uifont startupFile
1789 option add *Label.font uifont startupFile
1790 option add *Message.font uifont startupFile
1791 option add *Entry.font uifont startupFile
1794 # Make a menu and submenus.
1795 # m is the window name for the menu, items is the list of menu items to add.
1796 # Each item is a list {mc label type description options...}
1797 # mc is ignored; it's so we can put mc there to alert xgettext
1798 # label is the string that appears in the menu
1799 # type is cascade, command or radiobutton (should add checkbutton)
1800 # description depends on type; it's the sublist for cascade, the
1801 # command to invoke for command, or {variable value} for radiobutton
1802 proc makemenu {m items} {
1803 menu $m
1804 foreach i $items {
1805 set name [mc [lindex $i 1]]
1806 set type [lindex $i 2]
1807 set thing [lindex $i 3]
1808 set params [list $type]
1809 if {$name ne {}} {
1810 set u [string first "&" [string map {&& x} $name]]
1811 lappend params -label [string map {&& & & {}} $name]
1812 if {$u >= 0} {
1813 lappend params -underline $u
1816 switch -- $type {
1817 "cascade" {
1818 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1819 lappend params -menu $m.$submenu
1821 "command" {
1822 lappend params -command $thing
1824 "radiobutton" {
1825 lappend params -variable [lindex $thing 0] \
1826 -value [lindex $thing 1]
1829 eval $m add $params [lrange $i 4 end]
1830 if {$type eq "cascade"} {
1831 makemenu $m.$submenu $thing
1836 # translate string and remove ampersands
1837 proc mca {str} {
1838 return [string map {&& & & {}} [mc $str]]
1841 proc makewindow {} {
1842 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1843 global tabstop
1844 global findtype findtypemenu findloc findstring fstring geometry
1845 global entries sha1entry sha1string sha1but
1846 global diffcontextstring diffcontext
1847 global ignorespace
1848 global maincursor textcursor curtextcursor
1849 global rowctxmenu fakerowmenu mergemax wrapcomment
1850 global highlight_files gdttype
1851 global searchstring sstring
1852 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1853 global headctxmenu progresscanv progressitem progresscoords statusw
1854 global fprogitem fprogcoord lastprogupdate progupdatepending
1855 global rprogitem rprogcoord rownumsel numcommits
1856 global have_tk85
1858 # The "mc" arguments here are purely so that xgettext
1859 # sees the following string as needing to be translated
1860 makemenu .bar {
1861 {mc "File" cascade {
1862 {mc "Update" command updatecommits -accelerator F5}
1863 {mc "Reload" command reloadcommits}
1864 {mc "Reread references" command rereadrefs}
1865 {mc "List references" command showrefs}
1866 {mc "Quit" command doquit}
1868 {mc "Edit" cascade {
1869 {mc "Preferences" command doprefs}
1871 {mc "View" cascade {
1872 {mc "New view..." command {newview 0}}
1873 {mc "Edit view..." command editview -state disabled}
1874 {mc "Delete view" command delview -state disabled}
1875 {xx "" separator}
1876 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1878 {mc "Help" cascade {
1879 {mc "About gitk" command about}
1880 {mc "Key bindings" command keys}
1883 . configure -menu .bar
1885 # the gui has upper and lower half, parts of a paned window.
1886 panedwindow .ctop -orient vertical
1888 # possibly use assumed geometry
1889 if {![info exists geometry(pwsash0)]} {
1890 set geometry(topheight) [expr {15 * $linespc}]
1891 set geometry(topwidth) [expr {80 * $charspc}]
1892 set geometry(botheight) [expr {15 * $linespc}]
1893 set geometry(botwidth) [expr {50 * $charspc}]
1894 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1895 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1898 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1899 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1900 frame .tf.histframe
1901 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1903 # create three canvases
1904 set cscroll .tf.histframe.csb
1905 set canv .tf.histframe.pwclist.canv
1906 canvas $canv \
1907 -selectbackground $selectbgcolor \
1908 -background $bgcolor -bd 0 \
1909 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1910 .tf.histframe.pwclist add $canv
1911 set canv2 .tf.histframe.pwclist.canv2
1912 canvas $canv2 \
1913 -selectbackground $selectbgcolor \
1914 -background $bgcolor -bd 0 -yscrollincr $linespc
1915 .tf.histframe.pwclist add $canv2
1916 set canv3 .tf.histframe.pwclist.canv3
1917 canvas $canv3 \
1918 -selectbackground $selectbgcolor \
1919 -background $bgcolor -bd 0 -yscrollincr $linespc
1920 .tf.histframe.pwclist add $canv3
1921 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1922 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1924 # a scroll bar to rule them
1925 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1926 pack $cscroll -side right -fill y
1927 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1928 lappend bglist $canv $canv2 $canv3
1929 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1931 # we have two button bars at bottom of top frame. Bar 1
1932 frame .tf.bar
1933 frame .tf.lbar -height 15
1935 set sha1entry .tf.bar.sha1
1936 set entries $sha1entry
1937 set sha1but .tf.bar.sha1label
1938 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1939 -command gotocommit -width 8
1940 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1941 pack .tf.bar.sha1label -side left
1942 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1943 trace add variable sha1string write sha1change
1944 pack $sha1entry -side left -pady 2
1946 image create bitmap bm-left -data {
1947 #define left_width 16
1948 #define left_height 16
1949 static unsigned char left_bits[] = {
1950 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1951 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1952 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1954 image create bitmap bm-right -data {
1955 #define right_width 16
1956 #define right_height 16
1957 static unsigned char right_bits[] = {
1958 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1959 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1960 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1962 button .tf.bar.leftbut -image bm-left -command goback \
1963 -state disabled -width 26
1964 pack .tf.bar.leftbut -side left -fill y
1965 button .tf.bar.rightbut -image bm-right -command goforw \
1966 -state disabled -width 26
1967 pack .tf.bar.rightbut -side left -fill y
1969 label .tf.bar.rowlabel -text [mc "Row"]
1970 set rownumsel {}
1971 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1972 -relief sunken -anchor e
1973 label .tf.bar.rowlabel2 -text "/"
1974 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1975 -relief sunken -anchor e
1976 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1977 -side left
1978 global selectedline
1979 trace add variable selectedline write selectedline_change
1981 # Status label and progress bar
1982 set statusw .tf.bar.status
1983 label $statusw -width 15 -relief sunken
1984 pack $statusw -side left -padx 5
1985 set h [expr {[font metrics uifont -linespace] + 2}]
1986 set progresscanv .tf.bar.progress
1987 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1988 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1989 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1990 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1991 pack $progresscanv -side right -expand 1 -fill x
1992 set progresscoords {0 0}
1993 set fprogcoord 0
1994 set rprogcoord 0
1995 bind $progresscanv <Configure> adjustprogress
1996 set lastprogupdate [clock clicks -milliseconds]
1997 set progupdatepending 0
1999 # build up the bottom bar of upper window
2000 label .tf.lbar.flabel -text "[mc "Find"] "
2001 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2002 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2003 label .tf.lbar.flab2 -text " [mc "commit"] "
2004 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2005 -side left -fill y
2006 set gdttype [mc "containing:"]
2007 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2008 [mc "containing:"] \
2009 [mc "touching paths:"] \
2010 [mc "adding/removing string:"]]
2011 trace add variable gdttype write gdttype_change
2012 pack .tf.lbar.gdttype -side left -fill y
2014 set findstring {}
2015 set fstring .tf.lbar.findstring
2016 lappend entries $fstring
2017 entry $fstring -width 30 -font textfont -textvariable findstring
2018 trace add variable findstring write find_change
2019 set findtype [mc "Exact"]
2020 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2021 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2022 trace add variable findtype write findcom_change
2023 set findloc [mc "All fields"]
2024 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2025 [mc "Comments"] [mc "Author"] [mc "Committer"]
2026 trace add variable findloc write find_change
2027 pack .tf.lbar.findloc -side right
2028 pack .tf.lbar.findtype -side right
2029 pack $fstring -side left -expand 1 -fill x
2031 # Finish putting the upper half of the viewer together
2032 pack .tf.lbar -in .tf -side bottom -fill x
2033 pack .tf.bar -in .tf -side bottom -fill x
2034 pack .tf.histframe -fill both -side top -expand 1
2035 .ctop add .tf
2036 .ctop paneconfigure .tf -height $geometry(topheight)
2037 .ctop paneconfigure .tf -width $geometry(topwidth)
2039 # now build up the bottom
2040 panedwindow .pwbottom -orient horizontal
2042 # lower left, a text box over search bar, scroll bar to the right
2043 # if we know window height, then that will set the lower text height, otherwise
2044 # we set lower text height which will drive window height
2045 if {[info exists geometry(main)]} {
2046 frame .bleft -width $geometry(botwidth)
2047 } else {
2048 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2050 frame .bleft.top
2051 frame .bleft.mid
2052 frame .bleft.bottom
2054 button .bleft.top.search -text [mc "Search"] -command dosearch
2055 pack .bleft.top.search -side left -padx 5
2056 set sstring .bleft.top.sstring
2057 entry $sstring -width 20 -font textfont -textvariable searchstring
2058 lappend entries $sstring
2059 trace add variable searchstring write incrsearch
2060 pack $sstring -side left -expand 1 -fill x
2061 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2062 -command changediffdisp -variable diffelide -value {0 0}
2063 radiobutton .bleft.mid.old -text [mc "Old version"] \
2064 -command changediffdisp -variable diffelide -value {0 1}
2065 radiobutton .bleft.mid.new -text [mc "New version"] \
2066 -command changediffdisp -variable diffelide -value {1 0}
2067 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2068 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2069 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2070 -from 1 -increment 1 -to 10000000 \
2071 -validate all -validatecommand "diffcontextvalidate %P" \
2072 -textvariable diffcontextstring
2073 .bleft.mid.diffcontext set $diffcontext
2074 trace add variable diffcontextstring write diffcontextchange
2075 lappend entries .bleft.mid.diffcontext
2076 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2077 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2078 -command changeignorespace -variable ignorespace
2079 pack .bleft.mid.ignspace -side left -padx 5
2080 set ctext .bleft.bottom.ctext
2081 text $ctext -background $bgcolor -foreground $fgcolor \
2082 -state disabled -font textfont \
2083 -yscrollcommand scrolltext -wrap none \
2084 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2085 if {$have_tk85} {
2086 $ctext conf -tabstyle wordprocessor
2088 scrollbar .bleft.bottom.sb -command "$ctext yview"
2089 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2090 -width 10
2091 pack .bleft.top -side top -fill x
2092 pack .bleft.mid -side top -fill x
2093 grid $ctext .bleft.bottom.sb -sticky nsew
2094 grid .bleft.bottom.sbhorizontal -sticky ew
2095 grid columnconfigure .bleft.bottom 0 -weight 1
2096 grid rowconfigure .bleft.bottom 0 -weight 1
2097 grid rowconfigure .bleft.bottom 1 -weight 0
2098 pack .bleft.bottom -side top -fill both -expand 1
2099 lappend bglist $ctext
2100 lappend fglist $ctext
2102 $ctext tag conf comment -wrap $wrapcomment
2103 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2104 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2105 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2106 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2107 $ctext tag conf m0 -fore red
2108 $ctext tag conf m1 -fore blue
2109 $ctext tag conf m2 -fore green
2110 $ctext tag conf m3 -fore purple
2111 $ctext tag conf m4 -fore brown
2112 $ctext tag conf m5 -fore "#009090"
2113 $ctext tag conf m6 -fore magenta
2114 $ctext tag conf m7 -fore "#808000"
2115 $ctext tag conf m8 -fore "#009000"
2116 $ctext tag conf m9 -fore "#ff0080"
2117 $ctext tag conf m10 -fore cyan
2118 $ctext tag conf m11 -fore "#b07070"
2119 $ctext tag conf m12 -fore "#70b0f0"
2120 $ctext tag conf m13 -fore "#70f0b0"
2121 $ctext tag conf m14 -fore "#f0b070"
2122 $ctext tag conf m15 -fore "#ff70b0"
2123 $ctext tag conf mmax -fore darkgrey
2124 set mergemax 16
2125 $ctext tag conf mresult -font textfontbold
2126 $ctext tag conf msep -font textfontbold
2127 $ctext tag conf found -back yellow
2129 .pwbottom add .bleft
2130 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2132 # lower right
2133 frame .bright
2134 frame .bright.mode
2135 radiobutton .bright.mode.patch -text [mc "Patch"] \
2136 -command reselectline -variable cmitmode -value "patch"
2137 radiobutton .bright.mode.tree -text [mc "Tree"] \
2138 -command reselectline -variable cmitmode -value "tree"
2139 grid .bright.mode.patch .bright.mode.tree -sticky ew
2140 pack .bright.mode -side top -fill x
2141 set cflist .bright.cfiles
2142 set indent [font measure mainfont "nn"]
2143 text $cflist \
2144 -selectbackground $selectbgcolor \
2145 -background $bgcolor -foreground $fgcolor \
2146 -font mainfont \
2147 -tabs [list $indent [expr {2 * $indent}]] \
2148 -yscrollcommand ".bright.sb set" \
2149 -cursor [. cget -cursor] \
2150 -spacing1 1 -spacing3 1
2151 lappend bglist $cflist
2152 lappend fglist $cflist
2153 scrollbar .bright.sb -command "$cflist yview"
2154 pack .bright.sb -side right -fill y
2155 pack $cflist -side left -fill both -expand 1
2156 $cflist tag configure highlight \
2157 -background [$cflist cget -selectbackground]
2158 $cflist tag configure bold -font mainfontbold
2160 .pwbottom add .bright
2161 .ctop add .pwbottom
2163 # restore window width & height if known
2164 if {[info exists geometry(main)]} {
2165 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2166 if {$w > [winfo screenwidth .]} {
2167 set w [winfo screenwidth .]
2169 if {$h > [winfo screenheight .]} {
2170 set h [winfo screenheight .]
2172 wm geometry . "${w}x$h"
2176 if {[tk windowingsystem] eq {aqua}} {
2177 set M1B M1
2178 } else {
2179 set M1B Control
2182 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2183 pack .ctop -fill both -expand 1
2184 bindall <1> {selcanvline %W %x %y}
2185 #bindall <B1-Motion> {selcanvline %W %x %y}
2186 if {[tk windowingsystem] == "win32"} {
2187 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2188 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2189 } else {
2190 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2191 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2192 if {[tk windowingsystem] eq "aqua"} {
2193 bindall <MouseWheel> {
2194 set delta [expr {- (%D)}]
2195 allcanvs yview scroll $delta units
2199 bindall <2> "canvscan mark %W %x %y"
2200 bindall <B2-Motion> "canvscan dragto %W %x %y"
2201 bindkey <Home> selfirstline
2202 bindkey <End> sellastline
2203 bind . <Key-Up> "selnextline -1"
2204 bind . <Key-Down> "selnextline 1"
2205 bind . <Shift-Key-Up> "dofind -1 0"
2206 bind . <Shift-Key-Down> "dofind 1 0"
2207 bindkey <Key-Right> "goforw"
2208 bindkey <Key-Left> "goback"
2209 bind . <Key-Prior> "selnextpage -1"
2210 bind . <Key-Next> "selnextpage 1"
2211 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2212 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2213 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2214 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2215 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2216 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2217 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2218 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2219 bindkey <Key-space> "$ctext yview scroll 1 pages"
2220 bindkey p "selnextline -1"
2221 bindkey n "selnextline 1"
2222 bindkey z "goback"
2223 bindkey x "goforw"
2224 bindkey i "selnextline -1"
2225 bindkey k "selnextline 1"
2226 bindkey j "goback"
2227 bindkey l "goforw"
2228 bindkey b prevfile
2229 bindkey d "$ctext yview scroll 18 units"
2230 bindkey u "$ctext yview scroll -18 units"
2231 bindkey / {dofind 1 1}
2232 bindkey <Key-Return> {dofind 1 1}
2233 bindkey ? {dofind -1 1}
2234 bindkey f nextfile
2235 bindkey <F5> updatecommits
2236 bind . <$M1B-q> doquit
2237 bind . <$M1B-f> {dofind 1 1}
2238 bind . <$M1B-g> {dofind 1 0}
2239 bind . <$M1B-r> dosearchback
2240 bind . <$M1B-s> dosearch
2241 bind . <$M1B-equal> {incrfont 1}
2242 bind . <$M1B-plus> {incrfont 1}
2243 bind . <$M1B-KP_Add> {incrfont 1}
2244 bind . <$M1B-minus> {incrfont -1}
2245 bind . <$M1B-KP_Subtract> {incrfont -1}
2246 wm protocol . WM_DELETE_WINDOW doquit
2247 bind . <Destroy> {stop_backends}
2248 bind . <Button-1> "click %W"
2249 bind $fstring <Key-Return> {dofind 1 1}
2250 bind $sha1entry <Key-Return> {gotocommit; break}
2251 bind $sha1entry <<PasteSelection>> clearsha1
2252 bind $cflist <1> {sel_flist %W %x %y; break}
2253 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2254 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2255 global ctxbut
2256 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2257 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2259 set maincursor [. cget -cursor]
2260 set textcursor [$ctext cget -cursor]
2261 set curtextcursor $textcursor
2263 set rowctxmenu .rowctxmenu
2264 makemenu $rowctxmenu {
2265 {mc "Diff this -> selected" command {diffvssel 0}}
2266 {mc "Diff selected -> this" command {diffvssel 1}}
2267 {mc "Make patch" command mkpatch}
2268 {mc "Create tag" command mktag}
2269 {mc "Write commit to file" command writecommit}
2270 {mc "Create new branch" command mkbranch}
2271 {mc "Cherry-pick this commit" command cherrypick}
2272 {mc "Reset HEAD branch to here" command resethead}
2274 $rowctxmenu configure -tearoff 0
2276 set fakerowmenu .fakerowmenu
2277 makemenu $fakerowmenu {
2278 {mc "Diff this -> selected" command {diffvssel 0}}
2279 {mc "Diff selected -> this" command {diffvssel 1}}
2280 {mc "Make patch" command mkpatch}
2282 $fakerowmenu configure -tearoff 0
2284 set headctxmenu .headctxmenu
2285 makemenu $headctxmenu {
2286 {mc "Check out this branch" command cobranch}
2287 {mc "Remove this branch" command rmbranch}
2289 $headctxmenu configure -tearoff 0
2291 global flist_menu
2292 set flist_menu .flistctxmenu
2293 makemenu $flist_menu {
2294 {mc "Highlight this too" command {flist_hl 0}}
2295 {mc "Highlight this only" command {flist_hl 1}}
2296 {mc "External diff" command {external_diff}}
2297 {mc "Blame parent commit" command {external_blame 1}}
2299 $flist_menu configure -tearoff 0
2301 global diff_menu
2302 set diff_menu .diffctxmenu
2303 makemenu $diff_menu {
2304 {mc "Show origin of this line" command show_line_source}
2305 {mc "Run git gui blame on this line" command {external_blame_diff}}
2307 $diff_menu configure -tearoff 0
2310 # Windows sends all mouse wheel events to the current focused window, not
2311 # the one where the mouse hovers, so bind those events here and redirect
2312 # to the correct window
2313 proc windows_mousewheel_redirector {W X Y D} {
2314 global canv canv2 canv3
2315 set w [winfo containing -displayof $W $X $Y]
2316 if {$w ne ""} {
2317 set u [expr {$D < 0 ? 5 : -5}]
2318 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2319 allcanvs yview scroll $u units
2320 } else {
2321 catch {
2322 $w yview scroll $u units
2328 # Update row number label when selectedline changes
2329 proc selectedline_change {n1 n2 op} {
2330 global selectedline rownumsel
2332 if {$selectedline eq {}} {
2333 set rownumsel {}
2334 } else {
2335 set rownumsel [expr {$selectedline + 1}]
2339 # mouse-2 makes all windows scan vertically, but only the one
2340 # the cursor is in scans horizontally
2341 proc canvscan {op w x y} {
2342 global canv canv2 canv3
2343 foreach c [list $canv $canv2 $canv3] {
2344 if {$c == $w} {
2345 $c scan $op $x $y
2346 } else {
2347 $c scan $op 0 $y
2352 proc scrollcanv {cscroll f0 f1} {
2353 $cscroll set $f0 $f1
2354 drawvisible
2355 flushhighlights
2358 # when we make a key binding for the toplevel, make sure
2359 # it doesn't get triggered when that key is pressed in the
2360 # find string entry widget.
2361 proc bindkey {ev script} {
2362 global entries
2363 bind . $ev $script
2364 set escript [bind Entry $ev]
2365 if {$escript == {}} {
2366 set escript [bind Entry <Key>]
2368 foreach e $entries {
2369 bind $e $ev "$escript; break"
2373 # set the focus back to the toplevel for any click outside
2374 # the entry widgets
2375 proc click {w} {
2376 global ctext entries
2377 foreach e [concat $entries $ctext] {
2378 if {$w == $e} return
2380 focus .
2383 # Adjust the progress bar for a change in requested extent or canvas size
2384 proc adjustprogress {} {
2385 global progresscanv progressitem progresscoords
2386 global fprogitem fprogcoord lastprogupdate progupdatepending
2387 global rprogitem rprogcoord
2389 set w [expr {[winfo width $progresscanv] - 4}]
2390 set x0 [expr {$w * [lindex $progresscoords 0]}]
2391 set x1 [expr {$w * [lindex $progresscoords 1]}]
2392 set h [winfo height $progresscanv]
2393 $progresscanv coords $progressitem $x0 0 $x1 $h
2394 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2395 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2396 set now [clock clicks -milliseconds]
2397 if {$now >= $lastprogupdate + 100} {
2398 set progupdatepending 0
2399 update
2400 } elseif {!$progupdatepending} {
2401 set progupdatepending 1
2402 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2406 proc doprogupdate {} {
2407 global lastprogupdate progupdatepending
2409 if {$progupdatepending} {
2410 set progupdatepending 0
2411 set lastprogupdate [clock clicks -milliseconds]
2412 update
2416 proc savestuff {w} {
2417 global canv canv2 canv3 mainfont textfont uifont tabstop
2418 global stuffsaved findmergefiles maxgraphpct
2419 global maxwidth showneartags showlocalchanges
2420 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2421 global cmitmode wrapcomment datetimeformat limitdiffs
2422 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2423 global autoselect extdifftool perfile_attrs markbgcolor
2425 if {$stuffsaved} return
2426 if {![winfo viewable .]} return
2427 catch {
2428 set f [open "~/.gitk-new" w]
2429 puts $f [list set mainfont $mainfont]
2430 puts $f [list set textfont $textfont]
2431 puts $f [list set uifont $uifont]
2432 puts $f [list set tabstop $tabstop]
2433 puts $f [list set findmergefiles $findmergefiles]
2434 puts $f [list set maxgraphpct $maxgraphpct]
2435 puts $f [list set maxwidth $maxwidth]
2436 puts $f [list set cmitmode $cmitmode]
2437 puts $f [list set wrapcomment $wrapcomment]
2438 puts $f [list set autoselect $autoselect]
2439 puts $f [list set showneartags $showneartags]
2440 puts $f [list set showlocalchanges $showlocalchanges]
2441 puts $f [list set datetimeformat $datetimeformat]
2442 puts $f [list set limitdiffs $limitdiffs]
2443 puts $f [list set bgcolor $bgcolor]
2444 puts $f [list set fgcolor $fgcolor]
2445 puts $f [list set colors $colors]
2446 puts $f [list set diffcolors $diffcolors]
2447 puts $f [list set markbgcolor $markbgcolor]
2448 puts $f [list set diffcontext $diffcontext]
2449 puts $f [list set selectbgcolor $selectbgcolor]
2450 puts $f [list set extdifftool $extdifftool]
2451 puts $f [list set perfile_attrs $perfile_attrs]
2453 puts $f "set geometry(main) [wm geometry .]"
2454 puts $f "set geometry(topwidth) [winfo width .tf]"
2455 puts $f "set geometry(topheight) [winfo height .tf]"
2456 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2457 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2458 puts $f "set geometry(botwidth) [winfo width .bleft]"
2459 puts $f "set geometry(botheight) [winfo height .bleft]"
2461 puts -nonewline $f "set permviews {"
2462 for {set v 0} {$v < $nextviewnum} {incr v} {
2463 if {$viewperm($v)} {
2464 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2467 puts $f "}"
2468 close $f
2469 file rename -force "~/.gitk-new" "~/.gitk"
2471 set stuffsaved 1
2474 proc resizeclistpanes {win w} {
2475 global oldwidth
2476 if {[info exists oldwidth($win)]} {
2477 set s0 [$win sash coord 0]
2478 set s1 [$win sash coord 1]
2479 if {$w < 60} {
2480 set sash0 [expr {int($w/2 - 2)}]
2481 set sash1 [expr {int($w*5/6 - 2)}]
2482 } else {
2483 set factor [expr {1.0 * $w / $oldwidth($win)}]
2484 set sash0 [expr {int($factor * [lindex $s0 0])}]
2485 set sash1 [expr {int($factor * [lindex $s1 0])}]
2486 if {$sash0 < 30} {
2487 set sash0 30
2489 if {$sash1 < $sash0 + 20} {
2490 set sash1 [expr {$sash0 + 20}]
2492 if {$sash1 > $w - 10} {
2493 set sash1 [expr {$w - 10}]
2494 if {$sash0 > $sash1 - 20} {
2495 set sash0 [expr {$sash1 - 20}]
2499 $win sash place 0 $sash0 [lindex $s0 1]
2500 $win sash place 1 $sash1 [lindex $s1 1]
2502 set oldwidth($win) $w
2505 proc resizecdetpanes {win w} {
2506 global oldwidth
2507 if {[info exists oldwidth($win)]} {
2508 set s0 [$win sash coord 0]
2509 if {$w < 60} {
2510 set sash0 [expr {int($w*3/4 - 2)}]
2511 } else {
2512 set factor [expr {1.0 * $w / $oldwidth($win)}]
2513 set sash0 [expr {int($factor * [lindex $s0 0])}]
2514 if {$sash0 < 45} {
2515 set sash0 45
2517 if {$sash0 > $w - 15} {
2518 set sash0 [expr {$w - 15}]
2521 $win sash place 0 $sash0 [lindex $s0 1]
2523 set oldwidth($win) $w
2526 proc allcanvs args {
2527 global canv canv2 canv3
2528 eval $canv $args
2529 eval $canv2 $args
2530 eval $canv3 $args
2533 proc bindall {event action} {
2534 global canv canv2 canv3
2535 bind $canv $event $action
2536 bind $canv2 $event $action
2537 bind $canv3 $event $action
2540 proc about {} {
2541 global uifont
2542 set w .about
2543 if {[winfo exists $w]} {
2544 raise $w
2545 return
2547 toplevel $w
2548 wm title $w [mc "About gitk"]
2549 wm transient $w .
2550 message $w.m -text [mc "
2551 Gitk - a commit viewer for git
2553 Copyright © 2005-2008 Paul Mackerras
2555 Use and redistribute under the terms of the GNU General Public License"] \
2556 -justify center -aspect 400 -border 2 -bg white -relief groove
2557 pack $w.m -side top -fill x -padx 2 -pady 2
2558 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2559 pack $w.ok -side bottom
2560 bind $w <Visibility> "focus $w.ok"
2561 bind $w <Key-Escape> "destroy $w"
2562 bind $w <Key-Return> "destroy $w"
2565 proc keys {} {
2566 set w .keys
2567 if {[winfo exists $w]} {
2568 raise $w
2569 return
2571 if {[tk windowingsystem] eq {aqua}} {
2572 set M1T Cmd
2573 } else {
2574 set M1T Ctrl
2576 toplevel $w
2577 wm title $w [mc "Gitk key bindings"]
2578 wm transient $w .
2579 message $w.m -text "
2580 [mc "Gitk key bindings:"]
2582 [mc "<%s-Q> Quit" $M1T]
2583 [mc "<Home> Move to first commit"]
2584 [mc "<End> Move to last commit"]
2585 [mc "<Up>, p, i Move up one commit"]
2586 [mc "<Down>, n, k Move down one commit"]
2587 [mc "<Left>, z, j Go back in history list"]
2588 [mc "<Right>, x, l Go forward in history list"]
2589 [mc "<PageUp> Move up one page in commit list"]
2590 [mc "<PageDown> Move down one page in commit list"]
2591 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2592 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2593 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2594 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2595 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2596 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2597 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2598 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2599 [mc "<Delete>, b Scroll diff view up one page"]
2600 [mc "<Backspace> Scroll diff view up one page"]
2601 [mc "<Space> Scroll diff view down one page"]
2602 [mc "u Scroll diff view up 18 lines"]
2603 [mc "d Scroll diff view down 18 lines"]
2604 [mc "<%s-F> Find" $M1T]
2605 [mc "<%s-G> Move to next find hit" $M1T]
2606 [mc "<Return> Move to next find hit"]
2607 [mc "/ Move to next find hit, or redo find"]
2608 [mc "? Move to previous find hit"]
2609 [mc "f Scroll diff view to next file"]
2610 [mc "<%s-S> Search for next hit in diff view" $M1T]
2611 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2612 [mc "<%s-KP+> Increase font size" $M1T]
2613 [mc "<%s-plus> Increase font size" $M1T]
2614 [mc "<%s-KP-> Decrease font size" $M1T]
2615 [mc "<%s-minus> Decrease font size" $M1T]
2616 [mc "<F5> Update"]
2618 -justify left -bg white -border 2 -relief groove
2619 pack $w.m -side top -fill both -padx 2 -pady 2
2620 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2621 bind $w <Key-Escape> [list destroy $w]
2622 pack $w.ok -side bottom
2623 bind $w <Visibility> "focus $w.ok"
2624 bind $w <Key-Escape> "destroy $w"
2625 bind $w <Key-Return> "destroy $w"
2628 # Procedures for manipulating the file list window at the
2629 # bottom right of the overall window.
2631 proc treeview {w l openlevs} {
2632 global treecontents treediropen treeheight treeparent treeindex
2634 set ix 0
2635 set treeindex() 0
2636 set lev 0
2637 set prefix {}
2638 set prefixend -1
2639 set prefendstack {}
2640 set htstack {}
2641 set ht 0
2642 set treecontents() {}
2643 $w conf -state normal
2644 foreach f $l {
2645 while {[string range $f 0 $prefixend] ne $prefix} {
2646 if {$lev <= $openlevs} {
2647 $w mark set e:$treeindex($prefix) "end -1c"
2648 $w mark gravity e:$treeindex($prefix) left
2650 set treeheight($prefix) $ht
2651 incr ht [lindex $htstack end]
2652 set htstack [lreplace $htstack end end]
2653 set prefixend [lindex $prefendstack end]
2654 set prefendstack [lreplace $prefendstack end end]
2655 set prefix [string range $prefix 0 $prefixend]
2656 incr lev -1
2658 set tail [string range $f [expr {$prefixend+1}] end]
2659 while {[set slash [string first "/" $tail]] >= 0} {
2660 lappend htstack $ht
2661 set ht 0
2662 lappend prefendstack $prefixend
2663 incr prefixend [expr {$slash + 1}]
2664 set d [string range $tail 0 $slash]
2665 lappend treecontents($prefix) $d
2666 set oldprefix $prefix
2667 append prefix $d
2668 set treecontents($prefix) {}
2669 set treeindex($prefix) [incr ix]
2670 set treeparent($prefix) $oldprefix
2671 set tail [string range $tail [expr {$slash+1}] end]
2672 if {$lev <= $openlevs} {
2673 set ht 1
2674 set treediropen($prefix) [expr {$lev < $openlevs}]
2675 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2676 $w mark set d:$ix "end -1c"
2677 $w mark gravity d:$ix left
2678 set str "\n"
2679 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2680 $w insert end $str
2681 $w image create end -align center -image $bm -padx 1 \
2682 -name a:$ix
2683 $w insert end $d [highlight_tag $prefix]
2684 $w mark set s:$ix "end -1c"
2685 $w mark gravity s:$ix left
2687 incr lev
2689 if {$tail ne {}} {
2690 if {$lev <= $openlevs} {
2691 incr ht
2692 set str "\n"
2693 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2694 $w insert end $str
2695 $w insert end $tail [highlight_tag $f]
2697 lappend treecontents($prefix) $tail
2700 while {$htstack ne {}} {
2701 set treeheight($prefix) $ht
2702 incr ht [lindex $htstack end]
2703 set htstack [lreplace $htstack end end]
2704 set prefixend [lindex $prefendstack end]
2705 set prefendstack [lreplace $prefendstack end end]
2706 set prefix [string range $prefix 0 $prefixend]
2708 $w conf -state disabled
2711 proc linetoelt {l} {
2712 global treeheight treecontents
2714 set y 2
2715 set prefix {}
2716 while {1} {
2717 foreach e $treecontents($prefix) {
2718 if {$y == $l} {
2719 return "$prefix$e"
2721 set n 1
2722 if {[string index $e end] eq "/"} {
2723 set n $treeheight($prefix$e)
2724 if {$y + $n > $l} {
2725 append prefix $e
2726 incr y
2727 break
2730 incr y $n
2735 proc highlight_tree {y prefix} {
2736 global treeheight treecontents cflist
2738 foreach e $treecontents($prefix) {
2739 set path $prefix$e
2740 if {[highlight_tag $path] ne {}} {
2741 $cflist tag add bold $y.0 "$y.0 lineend"
2743 incr y
2744 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2745 set y [highlight_tree $y $path]
2748 return $y
2751 proc treeclosedir {w dir} {
2752 global treediropen treeheight treeparent treeindex
2754 set ix $treeindex($dir)
2755 $w conf -state normal
2756 $w delete s:$ix e:$ix
2757 set treediropen($dir) 0
2758 $w image configure a:$ix -image tri-rt
2759 $w conf -state disabled
2760 set n [expr {1 - $treeheight($dir)}]
2761 while {$dir ne {}} {
2762 incr treeheight($dir) $n
2763 set dir $treeparent($dir)
2767 proc treeopendir {w dir} {
2768 global treediropen treeheight treeparent treecontents treeindex
2770 set ix $treeindex($dir)
2771 $w conf -state normal
2772 $w image configure a:$ix -image tri-dn
2773 $w mark set e:$ix s:$ix
2774 $w mark gravity e:$ix right
2775 set lev 0
2776 set str "\n"
2777 set n [llength $treecontents($dir)]
2778 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2779 incr lev
2780 append str "\t"
2781 incr treeheight($x) $n
2783 foreach e $treecontents($dir) {
2784 set de $dir$e
2785 if {[string index $e end] eq "/"} {
2786 set iy $treeindex($de)
2787 $w mark set d:$iy e:$ix
2788 $w mark gravity d:$iy left
2789 $w insert e:$ix $str
2790 set treediropen($de) 0
2791 $w image create e:$ix -align center -image tri-rt -padx 1 \
2792 -name a:$iy
2793 $w insert e:$ix $e [highlight_tag $de]
2794 $w mark set s:$iy e:$ix
2795 $w mark gravity s:$iy left
2796 set treeheight($de) 1
2797 } else {
2798 $w insert e:$ix $str
2799 $w insert e:$ix $e [highlight_tag $de]
2802 $w mark gravity e:$ix right
2803 $w conf -state disabled
2804 set treediropen($dir) 1
2805 set top [lindex [split [$w index @0,0] .] 0]
2806 set ht [$w cget -height]
2807 set l [lindex [split [$w index s:$ix] .] 0]
2808 if {$l < $top} {
2809 $w yview $l.0
2810 } elseif {$l + $n + 1 > $top + $ht} {
2811 set top [expr {$l + $n + 2 - $ht}]
2812 if {$l < $top} {
2813 set top $l
2815 $w yview $top.0
2819 proc treeclick {w x y} {
2820 global treediropen cmitmode ctext cflist cflist_top
2822 if {$cmitmode ne "tree"} return
2823 if {![info exists cflist_top]} return
2824 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2825 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2826 $cflist tag add highlight $l.0 "$l.0 lineend"
2827 set cflist_top $l
2828 if {$l == 1} {
2829 $ctext yview 1.0
2830 return
2832 set e [linetoelt $l]
2833 if {[string index $e end] ne "/"} {
2834 showfile $e
2835 } elseif {$treediropen($e)} {
2836 treeclosedir $w $e
2837 } else {
2838 treeopendir $w $e
2842 proc setfilelist {id} {
2843 global treefilelist cflist jump_to_here
2845 treeview $cflist $treefilelist($id) 0
2846 if {$jump_to_here ne {}} {
2847 set f [lindex $jump_to_here 0]
2848 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2849 showfile $f
2854 image create bitmap tri-rt -background black -foreground blue -data {
2855 #define tri-rt_width 13
2856 #define tri-rt_height 13
2857 static unsigned char tri-rt_bits[] = {
2858 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2859 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2860 0x00, 0x00};
2861 } -maskdata {
2862 #define tri-rt-mask_width 13
2863 #define tri-rt-mask_height 13
2864 static unsigned char tri-rt-mask_bits[] = {
2865 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2866 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2867 0x08, 0x00};
2869 image create bitmap tri-dn -background black -foreground blue -data {
2870 #define tri-dn_width 13
2871 #define tri-dn_height 13
2872 static unsigned char tri-dn_bits[] = {
2873 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2874 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2875 0x00, 0x00};
2876 } -maskdata {
2877 #define tri-dn-mask_width 13
2878 #define tri-dn-mask_height 13
2879 static unsigned char tri-dn-mask_bits[] = {
2880 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2881 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2882 0x00, 0x00};
2885 image create bitmap reficon-T -background black -foreground yellow -data {
2886 #define tagicon_width 13
2887 #define tagicon_height 9
2888 static unsigned char tagicon_bits[] = {
2889 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2890 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2891 } -maskdata {
2892 #define tagicon-mask_width 13
2893 #define tagicon-mask_height 9
2894 static unsigned char tagicon-mask_bits[] = {
2895 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2896 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2898 set rectdata {
2899 #define headicon_width 13
2900 #define headicon_height 9
2901 static unsigned char headicon_bits[] = {
2902 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2903 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2905 set rectmask {
2906 #define headicon-mask_width 13
2907 #define headicon-mask_height 9
2908 static unsigned char headicon-mask_bits[] = {
2909 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2910 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2912 image create bitmap reficon-H -background black -foreground green \
2913 -data $rectdata -maskdata $rectmask
2914 image create bitmap reficon-o -background black -foreground "#ddddff" \
2915 -data $rectdata -maskdata $rectmask
2917 proc init_flist {first} {
2918 global cflist cflist_top difffilestart
2920 $cflist conf -state normal
2921 $cflist delete 0.0 end
2922 if {$first ne {}} {
2923 $cflist insert end $first
2924 set cflist_top 1
2925 $cflist tag add highlight 1.0 "1.0 lineend"
2926 } else {
2927 catch {unset cflist_top}
2929 $cflist conf -state disabled
2930 set difffilestart {}
2933 proc highlight_tag {f} {
2934 global highlight_paths
2936 foreach p $highlight_paths {
2937 if {[string match $p $f]} {
2938 return "bold"
2941 return {}
2944 proc highlight_filelist {} {
2945 global cmitmode cflist
2947 $cflist conf -state normal
2948 if {$cmitmode ne "tree"} {
2949 set end [lindex [split [$cflist index end] .] 0]
2950 for {set l 2} {$l < $end} {incr l} {
2951 set line [$cflist get $l.0 "$l.0 lineend"]
2952 if {[highlight_tag $line] ne {}} {
2953 $cflist tag add bold $l.0 "$l.0 lineend"
2956 } else {
2957 highlight_tree 2 {}
2959 $cflist conf -state disabled
2962 proc unhighlight_filelist {} {
2963 global cflist
2965 $cflist conf -state normal
2966 $cflist tag remove bold 1.0 end
2967 $cflist conf -state disabled
2970 proc add_flist {fl} {
2971 global cflist
2973 $cflist conf -state normal
2974 foreach f $fl {
2975 $cflist insert end "\n"
2976 $cflist insert end $f [highlight_tag $f]
2978 $cflist conf -state disabled
2981 proc sel_flist {w x y} {
2982 global ctext difffilestart cflist cflist_top cmitmode
2984 if {$cmitmode eq "tree"} return
2985 if {![info exists cflist_top]} return
2986 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2987 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2988 $cflist tag add highlight $l.0 "$l.0 lineend"
2989 set cflist_top $l
2990 if {$l == 1} {
2991 $ctext yview 1.0
2992 } else {
2993 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2997 proc pop_flist_menu {w X Y x y} {
2998 global ctext cflist cmitmode flist_menu flist_menu_file
2999 global treediffs diffids
3001 stopfinding
3002 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3003 if {$l <= 1} return
3004 if {$cmitmode eq "tree"} {
3005 set e [linetoelt $l]
3006 if {[string index $e end] eq "/"} return
3007 } else {
3008 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3010 set flist_menu_file $e
3011 set xdiffstate "normal"
3012 if {$cmitmode eq "tree"} {
3013 set xdiffstate "disabled"
3015 # Disable "External diff" item in tree mode
3016 $flist_menu entryconf 2 -state $xdiffstate
3017 tk_popup $flist_menu $X $Y
3020 proc find_ctext_fileinfo {line} {
3021 global ctext_file_names ctext_file_lines
3023 set ok [bsearch $ctext_file_lines $line]
3024 set tline [lindex $ctext_file_lines $ok]
3026 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3027 return {}
3028 } else {
3029 return [list [lindex $ctext_file_names $ok] $tline]
3033 proc pop_diff_menu {w X Y x y} {
3034 global ctext diff_menu flist_menu_file
3035 global diff_menu_txtpos diff_menu_line
3036 global diff_menu_filebase
3038 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3039 set diff_menu_line [lindex $diff_menu_txtpos 0]
3040 # don't pop up the menu on hunk-separator or file-separator lines
3041 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3042 return
3044 stopfinding
3045 set f [find_ctext_fileinfo $diff_menu_line]
3046 if {$f eq {}} return
3047 set flist_menu_file [lindex $f 0]
3048 set diff_menu_filebase [lindex $f 1]
3049 tk_popup $diff_menu $X $Y
3052 proc flist_hl {only} {
3053 global flist_menu_file findstring gdttype
3055 set x [shellquote $flist_menu_file]
3056 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3057 set findstring $x
3058 } else {
3059 append findstring " " $x
3061 set gdttype [mc "touching paths:"]
3064 proc save_file_from_commit {filename output what} {
3065 global nullfile
3067 if {[catch {exec git show $filename -- > $output} err]} {
3068 if {[string match "fatal: bad revision *" $err]} {
3069 return $nullfile
3071 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3072 return {}
3074 return $output
3077 proc external_diff_get_one_file {diffid filename diffdir} {
3078 global nullid nullid2 nullfile
3079 global gitdir
3081 if {$diffid == $nullid} {
3082 set difffile [file join [file dirname $gitdir] $filename]
3083 if {[file exists $difffile]} {
3084 return $difffile
3086 return $nullfile
3088 if {$diffid == $nullid2} {
3089 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3090 return [save_file_from_commit :$filename $difffile index]
3092 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3093 return [save_file_from_commit $diffid:$filename $difffile \
3094 "revision $diffid"]
3097 proc external_diff {} {
3098 global gitktmpdir nullid nullid2
3099 global flist_menu_file
3100 global diffids
3101 global diffnum
3102 global gitdir extdifftool
3104 if {[llength $diffids] == 1} {
3105 # no reference commit given
3106 set diffidto [lindex $diffids 0]
3107 if {$diffidto eq $nullid} {
3108 # diffing working copy with index
3109 set diffidfrom $nullid2
3110 } elseif {$diffidto eq $nullid2} {
3111 # diffing index with HEAD
3112 set diffidfrom "HEAD"
3113 } else {
3114 # use first parent commit
3115 global parentlist selectedline
3116 set diffidfrom [lindex $parentlist $selectedline 0]
3118 } else {
3119 set diffidfrom [lindex $diffids 0]
3120 set diffidto [lindex $diffids 1]
3123 # make sure that several diffs wont collide
3124 if {![info exists gitktmpdir]} {
3125 set gitktmpdir [file join [file dirname $gitdir] \
3126 [format ".gitk-tmp.%s" [pid]]]
3127 if {[catch {file mkdir $gitktmpdir} err]} {
3128 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3129 unset gitktmpdir
3130 return
3132 set diffnum 0
3134 incr diffnum
3135 set diffdir [file join $gitktmpdir $diffnum]
3136 if {[catch {file mkdir $diffdir} err]} {
3137 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3138 return
3141 # gather files to diff
3142 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3143 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3145 if {$difffromfile ne {} && $difftofile ne {}} {
3146 set cmd [concat | [shellsplit $extdifftool] \
3147 [list $difffromfile $difftofile]]
3148 if {[catch {set fl [open $cmd r]} err]} {
3149 file delete -force $diffdir
3150 error_popup "$extdifftool: [mc "command failed:"] $err"
3151 } else {
3152 fconfigure $fl -blocking 0
3153 filerun $fl [list delete_at_eof $fl $diffdir]
3158 proc find_hunk_blamespec {base line} {
3159 global ctext
3161 # Find and parse the hunk header
3162 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3163 if {$s_lix eq {}} return
3165 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3166 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3167 s_line old_specs osz osz1 new_line nsz]} {
3168 return
3171 # base lines for the parents
3172 set base_lines [list $new_line]
3173 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3174 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3175 old_spec old_line osz]} {
3176 return
3178 lappend base_lines $old_line
3181 # Now scan the lines to determine offset within the hunk
3182 set max_parent [expr {[llength $base_lines]-2}]
3183 set dline 0
3184 set s_lno [lindex [split $s_lix "."] 0]
3186 # Determine if the line is removed
3187 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3188 if {[string match {[-+ ]*} $chunk]} {
3189 set removed_idx [string first "-" $chunk]
3190 # Choose a parent index
3191 if {$removed_idx >= 0} {
3192 set parent $removed_idx
3193 } else {
3194 set unchanged_idx [string first " " $chunk]
3195 if {$unchanged_idx >= 0} {
3196 set parent $unchanged_idx
3197 } else {
3198 # blame the current commit
3199 set parent -1
3202 # then count other lines that belong to it
3203 for {set i $line} {[incr i -1] > $s_lno} {} {
3204 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3205 # Determine if the line is removed
3206 set removed_idx [string first "-" $chunk]
3207 if {$parent >= 0} {
3208 set code [string index $chunk $parent]
3209 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3210 incr dline
3212 } else {
3213 if {$removed_idx < 0} {
3214 incr dline
3218 incr parent
3219 } else {
3220 set parent 0
3223 incr dline [lindex $base_lines $parent]
3224 return [list $parent $dline]
3227 proc external_blame_diff {} {
3228 global currentid diffmergeid cmitmode
3229 global diff_menu_txtpos diff_menu_line
3230 global diff_menu_filebase flist_menu_file
3232 if {$cmitmode eq "tree"} {
3233 set parent_idx 0
3234 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3235 } else {
3236 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3237 if {$hinfo ne {}} {
3238 set parent_idx [lindex $hinfo 0]
3239 set line [lindex $hinfo 1]
3240 } else {
3241 set parent_idx 0
3242 set line 0
3246 external_blame $parent_idx $line
3249 proc external_blame {parent_idx {line {}}} {
3250 global flist_menu_file
3251 global nullid nullid2
3252 global parentlist selectedline currentid
3254 if {$parent_idx > 0} {
3255 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3256 } else {
3257 set base_commit $currentid
3260 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3261 error_popup [mc "No such commit"]
3262 return
3265 set cmdline [list git gui blame]
3266 if {$line ne {} && $line > 1} {
3267 lappend cmdline "--line=$line"
3269 lappend cmdline $base_commit $flist_menu_file
3270 if {[catch {eval exec $cmdline &} err]} {
3271 error_popup "[mc "git gui blame: command failed:"] $err"
3275 proc show_line_source {} {
3276 global cmitmode currentid parents curview blamestuff blameinst
3277 global diff_menu_line diff_menu_filebase flist_menu_file
3279 if {$cmitmode eq "tree"} {
3280 set id $currentid
3281 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3282 } else {
3283 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3284 if {$h eq {}} return
3285 set pi [lindex $h 0]
3286 if {$pi == 0} {
3287 mark_ctext_line $diff_menu_line
3288 return
3290 set id [lindex $parents($curview,$currentid) [expr {$pi - 1}]]
3291 set line [lindex $h 1]
3293 if {[catch {
3294 set f [open [list | git blame -p -L$line,+1 $id -- $flist_menu_file] r]
3295 } err]} {
3296 error_popup [mc "Couldn't start git blame: %s" $err]
3297 return
3299 fconfigure $f -blocking 0
3300 set i [reg_instance $f]
3301 set blamestuff($i) {}
3302 set blameinst $i
3303 filerun $f [list read_line_source $f $i]
3306 proc stopblaming {} {
3307 global blameinst
3309 if {[info exists blameinst]} {
3310 stop_instance $blameinst
3311 unset blameinst
3315 proc read_line_source {fd inst} {
3316 global blamestuff curview commfd blameinst
3318 while {[gets $fd line] >= 0} {
3319 lappend blamestuff($inst) $line
3321 if {![eof $fd]} {
3322 return 1
3324 unset commfd($inst)
3325 unset blameinst
3326 fconfigure $fd -blocking 1
3327 if {[catch {close $fd} err]} {
3328 error_popup [mc "Error running git blame: %s" $err]
3329 return 0
3332 set fname {}
3333 set line [split [lindex $blamestuff($inst) 0] " "]
3334 set id [lindex $line 0]
3335 set lnum [lindex $line 1]
3336 if {[string length $id] == 40 && [string is xdigit $id] &&
3337 [string is digit -strict $lnum]} {
3338 # look for "filename" line
3339 foreach l $blamestuff($inst) {
3340 if {[string match "filename *" $l]} {
3341 set fname [string range $l 9 end]
3342 break
3346 if {$fname ne {}} {
3347 # all looks good, select it
3348 if {[commitinview $id $curview]} {
3349 selectline [rowofcommit $id] 1 [list $fname $lnum]
3350 } else {
3351 error_popup [mc "That line comes from commit %s, \
3352 which is not in this view" [shortids $id]]
3354 } else {
3355 puts "oops couldn't parse git blame output"
3357 return 0
3360 # delete $dir when we see eof on $f (presumably because the child has exited)
3361 proc delete_at_eof {f dir} {
3362 while {[gets $f line] >= 0} {}
3363 if {[eof $f]} {
3364 if {[catch {close $f} err]} {
3365 error_popup "[mc "External diff viewer failed:"] $err"
3367 file delete -force $dir
3368 return 0
3370 return 1
3373 # Functions for adding and removing shell-type quoting
3375 proc shellquote {str} {
3376 if {![string match "*\['\"\\ \t]*" $str]} {
3377 return $str
3379 if {![string match "*\['\"\\]*" $str]} {
3380 return "\"$str\""
3382 if {![string match "*'*" $str]} {
3383 return "'$str'"
3385 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3388 proc shellarglist {l} {
3389 set str {}
3390 foreach a $l {
3391 if {$str ne {}} {
3392 append str " "
3394 append str [shellquote $a]
3396 return $str
3399 proc shelldequote {str} {
3400 set ret {}
3401 set used -1
3402 while {1} {
3403 incr used
3404 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3405 append ret [string range $str $used end]
3406 set used [string length $str]
3407 break
3409 set first [lindex $first 0]
3410 set ch [string index $str $first]
3411 if {$first > $used} {
3412 append ret [string range $str $used [expr {$first - 1}]]
3413 set used $first
3415 if {$ch eq " " || $ch eq "\t"} break
3416 incr used
3417 if {$ch eq "'"} {
3418 set first [string first "'" $str $used]
3419 if {$first < 0} {
3420 error "unmatched single-quote"
3422 append ret [string range $str $used [expr {$first - 1}]]
3423 set used $first
3424 continue
3426 if {$ch eq "\\"} {
3427 if {$used >= [string length $str]} {
3428 error "trailing backslash"
3430 append ret [string index $str $used]
3431 continue
3433 # here ch == "\""
3434 while {1} {
3435 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3436 error "unmatched double-quote"
3438 set first [lindex $first 0]
3439 set ch [string index $str $first]
3440 if {$first > $used} {
3441 append ret [string range $str $used [expr {$first - 1}]]
3442 set used $first
3444 if {$ch eq "\""} break
3445 incr used
3446 append ret [string index $str $used]
3447 incr used
3450 return [list $used $ret]
3453 proc shellsplit {str} {
3454 set l {}
3455 while {1} {
3456 set str [string trimleft $str]
3457 if {$str eq {}} break
3458 set dq [shelldequote $str]
3459 set n [lindex $dq 0]
3460 set word [lindex $dq 1]
3461 set str [string range $str $n end]
3462 lappend l $word
3464 return $l
3467 # Code to implement multiple views
3469 proc newview {ishighlight} {
3470 global nextviewnum newviewname newviewperm newishighlight
3471 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3473 set newishighlight $ishighlight
3474 set top .gitkview
3475 if {[winfo exists $top]} {
3476 raise $top
3477 return
3479 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3480 set newviewperm($nextviewnum) 0
3481 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3482 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3483 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3486 proc editview {} {
3487 global curview
3488 global viewname viewperm newviewname newviewperm
3489 global viewargs newviewargs viewargscmd newviewargscmd
3491 set top .gitkvedit-$curview
3492 if {[winfo exists $top]} {
3493 raise $top
3494 return
3496 set newviewname($curview) $viewname($curview)
3497 set newviewperm($curview) $viewperm($curview)
3498 set newviewargs($curview) [shellarglist $viewargs($curview)]
3499 set newviewargscmd($curview) $viewargscmd($curview)
3500 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3503 proc vieweditor {top n title} {
3504 global newviewname newviewperm viewfiles bgcolor
3506 toplevel $top
3507 wm title $top $title
3508 wm transient $top .
3509 label $top.nl -text [mc "Name"]
3510 entry $top.name -width 20 -textvariable newviewname($n)
3511 grid $top.nl $top.name -sticky w -pady 5
3512 checkbutton $top.perm -text [mc "Remember this view"] \
3513 -variable newviewperm($n)
3514 grid $top.perm - -pady 5 -sticky w
3515 message $top.al -aspect 1000 \
3516 -text [mc "Commits to include (arguments to git log):"]
3517 grid $top.al - -sticky w -pady 5
3518 entry $top.args -width 50 -textvariable newviewargs($n) \
3519 -background $bgcolor
3520 grid $top.args - -sticky ew -padx 5
3522 message $top.ac -aspect 1000 \
3523 -text [mc "Command to generate more commits to include:"]
3524 grid $top.ac - -sticky w -pady 5
3525 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3526 -background white
3527 grid $top.argscmd - -sticky ew -padx 5
3529 message $top.l -aspect 1000 \
3530 -text [mc "Enter files and directories to include, one per line:"]
3531 grid $top.l - -sticky w
3532 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3533 if {[info exists viewfiles($n)]} {
3534 foreach f $viewfiles($n) {
3535 $top.t insert end $f
3536 $top.t insert end "\n"
3538 $top.t delete {end - 1c} end
3539 $top.t mark set insert 0.0
3541 grid $top.t - -sticky ew -padx 5
3542 frame $top.buts
3543 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3544 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3545 bind $top <Escape> [list destroy $top]
3546 grid $top.buts.ok $top.buts.can
3547 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3548 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3549 grid $top.buts - -pady 10 -sticky ew
3550 focus $top.t
3553 proc doviewmenu {m first cmd op argv} {
3554 set nmenu [$m index end]
3555 for {set i $first} {$i <= $nmenu} {incr i} {
3556 if {[$m entrycget $i -command] eq $cmd} {
3557 eval $m $op $i $argv
3558 break
3563 proc allviewmenus {n op args} {
3564 # global viewhlmenu
3566 doviewmenu .bar.view 5 [list showview $n] $op $args
3567 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3570 proc newviewok {top n} {
3571 global nextviewnum newviewperm newviewname newishighlight
3572 global viewname viewfiles viewperm selectedview curview
3573 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3575 if {[catch {
3576 set newargs [shellsplit $newviewargs($n)]
3577 } err]} {
3578 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3579 return
3581 set files {}
3582 foreach f [split [$top.t get 0.0 end] "\n"] {
3583 set ft [string trim $f]
3584 if {$ft ne {}} {
3585 lappend files $ft
3588 if {![info exists viewfiles($n)]} {
3589 # creating a new view
3590 incr nextviewnum
3591 set viewname($n) $newviewname($n)
3592 set viewperm($n) $newviewperm($n)
3593 set viewfiles($n) $files
3594 set viewargs($n) $newargs
3595 set viewargscmd($n) $newviewargscmd($n)
3596 addviewmenu $n
3597 if {!$newishighlight} {
3598 run showview $n
3599 } else {
3600 run addvhighlight $n
3602 } else {
3603 # editing an existing view
3604 set viewperm($n) $newviewperm($n)
3605 if {$newviewname($n) ne $viewname($n)} {
3606 set viewname($n) $newviewname($n)
3607 doviewmenu .bar.view 5 [list showview $n] \
3608 entryconf [list -label $viewname($n)]
3609 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3610 # entryconf [list -label $viewname($n) -value $viewname($n)]
3612 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3613 $newviewargscmd($n) ne $viewargscmd($n)} {
3614 set viewfiles($n) $files
3615 set viewargs($n) $newargs
3616 set viewargscmd($n) $newviewargscmd($n)
3617 if {$curview == $n} {
3618 run reloadcommits
3622 catch {destroy $top}
3625 proc delview {} {
3626 global curview viewperm hlview selectedhlview
3628 if {$curview == 0} return
3629 if {[info exists hlview] && $hlview == $curview} {
3630 set selectedhlview [mc "None"]
3631 unset hlview
3633 allviewmenus $curview delete
3634 set viewperm($curview) 0
3635 showview 0
3638 proc addviewmenu {n} {
3639 global viewname viewhlmenu
3641 .bar.view add radiobutton -label $viewname($n) \
3642 -command [list showview $n] -variable selectedview -value $n
3643 #$viewhlmenu add radiobutton -label $viewname($n) \
3644 # -command [list addvhighlight $n] -variable selectedhlview
3647 proc showview {n} {
3648 global curview cached_commitrow ordertok
3649 global displayorder parentlist rowidlist rowisopt rowfinal
3650 global colormap rowtextx nextcolor canvxmax
3651 global numcommits viewcomplete
3652 global selectedline currentid canv canvy0
3653 global treediffs
3654 global pending_select mainheadid
3655 global commitidx
3656 global selectedview
3657 global hlview selectedhlview commitinterest
3659 if {$n == $curview} return
3660 set selid {}
3661 set ymax [lindex [$canv cget -scrollregion] 3]
3662 set span [$canv yview]
3663 set ytop [expr {[lindex $span 0] * $ymax}]
3664 set ybot [expr {[lindex $span 1] * $ymax}]
3665 set yscreen [expr {($ybot - $ytop) / 2}]
3666 if {$selectedline ne {}} {
3667 set selid $currentid
3668 set y [yc $selectedline]
3669 if {$ytop < $y && $y < $ybot} {
3670 set yscreen [expr {$y - $ytop}]
3672 } elseif {[info exists pending_select]} {
3673 set selid $pending_select
3674 unset pending_select
3676 unselectline
3677 normalline
3678 catch {unset treediffs}
3679 clear_display
3680 if {[info exists hlview] && $hlview == $n} {
3681 unset hlview
3682 set selectedhlview [mc "None"]
3684 catch {unset commitinterest}
3685 catch {unset cached_commitrow}
3686 catch {unset ordertok}
3688 set curview $n
3689 set selectedview $n
3690 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3691 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3693 run refill_reflist
3694 if {![info exists viewcomplete($n)]} {
3695 getcommits $selid
3696 return
3699 set displayorder {}
3700 set parentlist {}
3701 set rowidlist {}
3702 set rowisopt {}
3703 set rowfinal {}
3704 set numcommits $commitidx($n)
3706 catch {unset colormap}
3707 catch {unset rowtextx}
3708 set nextcolor 0
3709 set canvxmax [$canv cget -width]
3710 set curview $n
3711 set row 0
3712 setcanvscroll
3713 set yf 0
3714 set row {}
3715 if {$selid ne {} && [commitinview $selid $n]} {
3716 set row [rowofcommit $selid]
3717 # try to get the selected row in the same position on the screen
3718 set ymax [lindex [$canv cget -scrollregion] 3]
3719 set ytop [expr {[yc $row] - $yscreen}]
3720 if {$ytop < 0} {
3721 set ytop 0
3723 set yf [expr {$ytop * 1.0 / $ymax}]
3725 allcanvs yview moveto $yf
3726 drawvisible
3727 if {$row ne {}} {
3728 selectline $row 0
3729 } elseif {!$viewcomplete($n)} {
3730 reset_pending_select $selid
3731 } else {
3732 reset_pending_select {}
3734 if {[commitinview $pending_select $curview]} {
3735 selectline [rowofcommit $pending_select] 1
3736 } else {
3737 set row [first_real_row]
3738 if {$row < $numcommits} {
3739 selectline $row 0
3743 if {!$viewcomplete($n)} {
3744 if {$numcommits == 0} {
3745 show_status [mc "Reading commits..."]
3747 } elseif {$numcommits == 0} {
3748 show_status [mc "No commits selected"]
3752 # Stuff relating to the highlighting facility
3754 proc ishighlighted {id} {
3755 global vhighlights fhighlights nhighlights rhighlights
3757 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3758 return $nhighlights($id)
3760 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3761 return $vhighlights($id)
3763 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3764 return $fhighlights($id)
3766 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3767 return $rhighlights($id)
3769 return 0
3772 proc bolden {row font} {
3773 global canv linehtag selectedline boldrows
3775 lappend boldrows $row
3776 $canv itemconf $linehtag($row) -font $font
3777 if {$row == $selectedline} {
3778 $canv delete secsel
3779 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3780 -outline {{}} -tags secsel \
3781 -fill [$canv cget -selectbackground]]
3782 $canv lower $t
3786 proc bolden_name {row font} {
3787 global canv2 linentag selectedline boldnamerows
3789 lappend boldnamerows $row
3790 $canv2 itemconf $linentag($row) -font $font
3791 if {$row == $selectedline} {
3792 $canv2 delete secsel
3793 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3794 -outline {{}} -tags secsel \
3795 -fill [$canv2 cget -selectbackground]]
3796 $canv2 lower $t
3800 proc unbolden {} {
3801 global boldrows
3803 set stillbold {}
3804 foreach row $boldrows {
3805 if {![ishighlighted [commitonrow $row]]} {
3806 bolden $row mainfont
3807 } else {
3808 lappend stillbold $row
3811 set boldrows $stillbold
3814 proc addvhighlight {n} {
3815 global hlview viewcomplete curview vhl_done commitidx
3817 if {[info exists hlview]} {
3818 delvhighlight
3820 set hlview $n
3821 if {$n != $curview && ![info exists viewcomplete($n)]} {
3822 start_rev_list $n
3824 set vhl_done $commitidx($hlview)
3825 if {$vhl_done > 0} {
3826 drawvisible
3830 proc delvhighlight {} {
3831 global hlview vhighlights
3833 if {![info exists hlview]} return
3834 unset hlview
3835 catch {unset vhighlights}
3836 unbolden
3839 proc vhighlightmore {} {
3840 global hlview vhl_done commitidx vhighlights curview
3842 set max $commitidx($hlview)
3843 set vr [visiblerows]
3844 set r0 [lindex $vr 0]
3845 set r1 [lindex $vr 1]
3846 for {set i $vhl_done} {$i < $max} {incr i} {
3847 set id [commitonrow $i $hlview]
3848 if {[commitinview $id $curview]} {
3849 set row [rowofcommit $id]
3850 if {$r0 <= $row && $row <= $r1} {
3851 if {![highlighted $row]} {
3852 bolden $row mainfontbold
3854 set vhighlights($id) 1
3858 set vhl_done $max
3859 return 0
3862 proc askvhighlight {row id} {
3863 global hlview vhighlights iddrawn
3865 if {[commitinview $id $hlview]} {
3866 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3867 bolden $row mainfontbold
3869 set vhighlights($id) 1
3870 } else {
3871 set vhighlights($id) 0
3875 proc hfiles_change {} {
3876 global highlight_files filehighlight fhighlights fh_serial
3877 global highlight_paths gdttype
3879 if {[info exists filehighlight]} {
3880 # delete previous highlights
3881 catch {close $filehighlight}
3882 unset filehighlight
3883 catch {unset fhighlights}
3884 unbolden
3885 unhighlight_filelist
3887 set highlight_paths {}
3888 after cancel do_file_hl $fh_serial
3889 incr fh_serial
3890 if {$highlight_files ne {}} {
3891 after 300 do_file_hl $fh_serial
3895 proc gdttype_change {name ix op} {
3896 global gdttype highlight_files findstring findpattern
3898 stopfinding
3899 if {$findstring ne {}} {
3900 if {$gdttype eq [mc "containing:"]} {
3901 if {$highlight_files ne {}} {
3902 set highlight_files {}
3903 hfiles_change
3905 findcom_change
3906 } else {
3907 if {$findpattern ne {}} {
3908 set findpattern {}
3909 findcom_change
3911 set highlight_files $findstring
3912 hfiles_change
3914 drawvisible
3916 # enable/disable findtype/findloc menus too
3919 proc find_change {name ix op} {
3920 global gdttype findstring highlight_files
3922 stopfinding
3923 if {$gdttype eq [mc "containing:"]} {
3924 findcom_change
3925 } else {
3926 if {$highlight_files ne $findstring} {
3927 set highlight_files $findstring
3928 hfiles_change
3931 drawvisible
3934 proc findcom_change args {
3935 global nhighlights boldnamerows
3936 global findpattern findtype findstring gdttype
3938 stopfinding
3939 # delete previous highlights, if any
3940 foreach row $boldnamerows {
3941 bolden_name $row mainfont
3943 set boldnamerows {}
3944 catch {unset nhighlights}
3945 unbolden
3946 unmarkmatches
3947 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3948 set findpattern {}
3949 } elseif {$findtype eq [mc "Regexp"]} {
3950 set findpattern $findstring
3951 } else {
3952 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3953 $findstring]
3954 set findpattern "*$e*"
3958 proc makepatterns {l} {
3959 set ret {}
3960 foreach e $l {
3961 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3962 if {[string index $ee end] eq "/"} {
3963 lappend ret "$ee*"
3964 } else {
3965 lappend ret $ee
3966 lappend ret "$ee/*"
3969 return $ret
3972 proc do_file_hl {serial} {
3973 global highlight_files filehighlight highlight_paths gdttype fhl_list
3975 if {$gdttype eq [mc "touching paths:"]} {
3976 if {[catch {set paths [shellsplit $highlight_files]}]} return
3977 set highlight_paths [makepatterns $paths]
3978 highlight_filelist
3979 set gdtargs [concat -- $paths]
3980 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3981 set gdtargs [list "-S$highlight_files"]
3982 } else {
3983 # must be "containing:", i.e. we're searching commit info
3984 return
3986 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3987 set filehighlight [open $cmd r+]
3988 fconfigure $filehighlight -blocking 0
3989 filerun $filehighlight readfhighlight
3990 set fhl_list {}
3991 drawvisible
3992 flushhighlights
3995 proc flushhighlights {} {
3996 global filehighlight fhl_list
3998 if {[info exists filehighlight]} {
3999 lappend fhl_list {}
4000 puts $filehighlight ""
4001 flush $filehighlight
4005 proc askfilehighlight {row id} {
4006 global filehighlight fhighlights fhl_list
4008 lappend fhl_list $id
4009 set fhighlights($id) -1
4010 puts $filehighlight $id
4013 proc readfhighlight {} {
4014 global filehighlight fhighlights curview iddrawn
4015 global fhl_list find_dirn
4017 if {![info exists filehighlight]} {
4018 return 0
4020 set nr 0
4021 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4022 set line [string trim $line]
4023 set i [lsearch -exact $fhl_list $line]
4024 if {$i < 0} continue
4025 for {set j 0} {$j < $i} {incr j} {
4026 set id [lindex $fhl_list $j]
4027 set fhighlights($id) 0
4029 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4030 if {$line eq {}} continue
4031 if {![commitinview $line $curview]} continue
4032 set row [rowofcommit $line]
4033 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4034 bolden $row mainfontbold
4036 set fhighlights($line) 1
4038 if {[eof $filehighlight]} {
4039 # strange...
4040 puts "oops, git diff-tree died"
4041 catch {close $filehighlight}
4042 unset filehighlight
4043 return 0
4045 if {[info exists find_dirn]} {
4046 run findmore
4048 return 1
4051 proc doesmatch {f} {
4052 global findtype findpattern
4054 if {$findtype eq [mc "Regexp"]} {
4055 return [regexp $findpattern $f]
4056 } elseif {$findtype eq [mc "IgnCase"]} {
4057 return [string match -nocase $findpattern $f]
4058 } else {
4059 return [string match $findpattern $f]
4063 proc askfindhighlight {row id} {
4064 global nhighlights commitinfo iddrawn
4065 global findloc
4066 global markingmatches
4068 if {![info exists commitinfo($id)]} {
4069 getcommit $id
4071 set info $commitinfo($id)
4072 set isbold 0
4073 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4074 foreach f $info ty $fldtypes {
4075 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4076 [doesmatch $f]} {
4077 if {$ty eq [mc "Author"]} {
4078 set isbold 2
4079 break
4081 set isbold 1
4084 if {$isbold && [info exists iddrawn($id)]} {
4085 if {![ishighlighted $id]} {
4086 bolden $row mainfontbold
4087 if {$isbold > 1} {
4088 bolden_name $row mainfontbold
4091 if {$markingmatches} {
4092 markrowmatches $row $id
4095 set nhighlights($id) $isbold
4098 proc markrowmatches {row id} {
4099 global canv canv2 linehtag linentag commitinfo findloc
4101 set headline [lindex $commitinfo($id) 0]
4102 set author [lindex $commitinfo($id) 1]
4103 $canv delete match$row
4104 $canv2 delete match$row
4105 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4106 set m [findmatches $headline]
4107 if {$m ne {}} {
4108 markmatches $canv $row $headline $linehtag($row) $m \
4109 [$canv itemcget $linehtag($row) -font] $row
4112 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4113 set m [findmatches $author]
4114 if {$m ne {}} {
4115 markmatches $canv2 $row $author $linentag($row) $m \
4116 [$canv2 itemcget $linentag($row) -font] $row
4121 proc vrel_change {name ix op} {
4122 global highlight_related
4124 rhighlight_none
4125 if {$highlight_related ne [mc "None"]} {
4126 run drawvisible
4130 # prepare for testing whether commits are descendents or ancestors of a
4131 proc rhighlight_sel {a} {
4132 global descendent desc_todo ancestor anc_todo
4133 global highlight_related
4135 catch {unset descendent}
4136 set desc_todo [list $a]
4137 catch {unset ancestor}
4138 set anc_todo [list $a]
4139 if {$highlight_related ne [mc "None"]} {
4140 rhighlight_none
4141 run drawvisible
4145 proc rhighlight_none {} {
4146 global rhighlights
4148 catch {unset rhighlights}
4149 unbolden
4152 proc is_descendent {a} {
4153 global curview children descendent desc_todo
4155 set v $curview
4156 set la [rowofcommit $a]
4157 set todo $desc_todo
4158 set leftover {}
4159 set done 0
4160 for {set i 0} {$i < [llength $todo]} {incr i} {
4161 set do [lindex $todo $i]
4162 if {[rowofcommit $do] < $la} {
4163 lappend leftover $do
4164 continue
4166 foreach nk $children($v,$do) {
4167 if {![info exists descendent($nk)]} {
4168 set descendent($nk) 1
4169 lappend todo $nk
4170 if {$nk eq $a} {
4171 set done 1
4175 if {$done} {
4176 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4177 return
4180 set descendent($a) 0
4181 set desc_todo $leftover
4184 proc is_ancestor {a} {
4185 global curview parents ancestor anc_todo
4187 set v $curview
4188 set la [rowofcommit $a]
4189 set todo $anc_todo
4190 set leftover {}
4191 set done 0
4192 for {set i 0} {$i < [llength $todo]} {incr i} {
4193 set do [lindex $todo $i]
4194 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4195 lappend leftover $do
4196 continue
4198 foreach np $parents($v,$do) {
4199 if {![info exists ancestor($np)]} {
4200 set ancestor($np) 1
4201 lappend todo $np
4202 if {$np eq $a} {
4203 set done 1
4207 if {$done} {
4208 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4209 return
4212 set ancestor($a) 0
4213 set anc_todo $leftover
4216 proc askrelhighlight {row id} {
4217 global descendent highlight_related iddrawn rhighlights
4218 global selectedline ancestor
4220 if {$selectedline eq {}} return
4221 set isbold 0
4222 if {$highlight_related eq [mc "Descendant"] ||
4223 $highlight_related eq [mc "Not descendant"]} {
4224 if {![info exists descendent($id)]} {
4225 is_descendent $id
4227 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4228 set isbold 1
4230 } elseif {$highlight_related eq [mc "Ancestor"] ||
4231 $highlight_related eq [mc "Not ancestor"]} {
4232 if {![info exists ancestor($id)]} {
4233 is_ancestor $id
4235 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4236 set isbold 1
4239 if {[info exists iddrawn($id)]} {
4240 if {$isbold && ![ishighlighted $id]} {
4241 bolden $row mainfontbold
4244 set rhighlights($id) $isbold
4247 # Graph layout functions
4249 proc shortids {ids} {
4250 set res {}
4251 foreach id $ids {
4252 if {[llength $id] > 1} {
4253 lappend res [shortids $id]
4254 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4255 lappend res [string range $id 0 7]
4256 } else {
4257 lappend res $id
4260 return $res
4263 proc ntimes {n o} {
4264 set ret {}
4265 set o [list $o]
4266 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4267 if {($n & $mask) != 0} {
4268 set ret [concat $ret $o]
4270 set o [concat $o $o]
4272 return $ret
4275 proc ordertoken {id} {
4276 global ordertok curview varcid varcstart varctok curview parents children
4277 global nullid nullid2
4279 if {[info exists ordertok($id)]} {
4280 return $ordertok($id)
4282 set origid $id
4283 set todo {}
4284 while {1} {
4285 if {[info exists varcid($curview,$id)]} {
4286 set a $varcid($curview,$id)
4287 set p [lindex $varcstart($curview) $a]
4288 } else {
4289 set p [lindex $children($curview,$id) 0]
4291 if {[info exists ordertok($p)]} {
4292 set tok $ordertok($p)
4293 break
4295 set id [first_real_child $curview,$p]
4296 if {$id eq {}} {
4297 # it's a root
4298 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4299 break
4301 if {[llength $parents($curview,$id)] == 1} {
4302 lappend todo [list $p {}]
4303 } else {
4304 set j [lsearch -exact $parents($curview,$id) $p]
4305 if {$j < 0} {
4306 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4308 lappend todo [list $p [strrep $j]]
4311 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4312 set p [lindex $todo $i 0]
4313 append tok [lindex $todo $i 1]
4314 set ordertok($p) $tok
4316 set ordertok($origid) $tok
4317 return $tok
4320 # Work out where id should go in idlist so that order-token
4321 # values increase from left to right
4322 proc idcol {idlist id {i 0}} {
4323 set t [ordertoken $id]
4324 if {$i < 0} {
4325 set i 0
4327 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4328 if {$i > [llength $idlist]} {
4329 set i [llength $idlist]
4331 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4332 incr i
4333 } else {
4334 if {$t > [ordertoken [lindex $idlist $i]]} {
4335 while {[incr i] < [llength $idlist] &&
4336 $t >= [ordertoken [lindex $idlist $i]]} {}
4339 return $i
4342 proc initlayout {} {
4343 global rowidlist rowisopt rowfinal displayorder parentlist
4344 global numcommits canvxmax canv
4345 global nextcolor
4346 global colormap rowtextx
4348 set numcommits 0
4349 set displayorder {}
4350 set parentlist {}
4351 set nextcolor 0
4352 set rowidlist {}
4353 set rowisopt {}
4354 set rowfinal {}
4355 set canvxmax [$canv cget -width]
4356 catch {unset colormap}
4357 catch {unset rowtextx}
4358 setcanvscroll
4361 proc setcanvscroll {} {
4362 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4363 global lastscrollset lastscrollrows
4365 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4366 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4367 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4368 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4369 set lastscrollset [clock clicks -milliseconds]
4370 set lastscrollrows $numcommits
4373 proc visiblerows {} {
4374 global canv numcommits linespc
4376 set ymax [lindex [$canv cget -scrollregion] 3]
4377 if {$ymax eq {} || $ymax == 0} return
4378 set f [$canv yview]
4379 set y0 [expr {int([lindex $f 0] * $ymax)}]
4380 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4381 if {$r0 < 0} {
4382 set r0 0
4384 set y1 [expr {int([lindex $f 1] * $ymax)}]
4385 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4386 if {$r1 >= $numcommits} {
4387 set r1 [expr {$numcommits - 1}]
4389 return [list $r0 $r1]
4392 proc layoutmore {} {
4393 global commitidx viewcomplete curview
4394 global numcommits pending_select curview
4395 global lastscrollset lastscrollrows
4397 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4398 [clock clicks -milliseconds] - $lastscrollset > 500} {
4399 setcanvscroll
4401 if {[info exists pending_select] &&
4402 [commitinview $pending_select $curview]} {
4403 update
4404 selectline [rowofcommit $pending_select] 1
4406 drawvisible
4409 proc doshowlocalchanges {} {
4410 global curview mainheadid
4412 if {$mainheadid eq {}} return
4413 if {[commitinview $mainheadid $curview]} {
4414 dodiffindex
4415 } else {
4416 interestedin $mainheadid dodiffindex
4420 proc dohidelocalchanges {} {
4421 global nullid nullid2 lserial curview
4423 if {[commitinview $nullid $curview]} {
4424 removefakerow $nullid
4426 if {[commitinview $nullid2 $curview]} {
4427 removefakerow $nullid2
4429 incr lserial
4432 # spawn off a process to do git diff-index --cached HEAD
4433 proc dodiffindex {} {
4434 global lserial showlocalchanges
4435 global isworktree
4437 if {!$showlocalchanges || !$isworktree} return
4438 incr lserial
4439 set fd [open "|git diff-index --cached HEAD" r]
4440 fconfigure $fd -blocking 0
4441 set i [reg_instance $fd]
4442 filerun $fd [list readdiffindex $fd $lserial $i]
4445 proc readdiffindex {fd serial inst} {
4446 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4448 set isdiff 1
4449 if {[gets $fd line] < 0} {
4450 if {![eof $fd]} {
4451 return 1
4453 set isdiff 0
4455 # we only need to see one line and we don't really care what it says...
4456 stop_instance $inst
4458 if {$serial != $lserial} {
4459 return 0
4462 # now see if there are any local changes not checked in to the index
4463 set fd [open "|git diff-files" r]
4464 fconfigure $fd -blocking 0
4465 set i [reg_instance $fd]
4466 filerun $fd [list readdifffiles $fd $serial $i]
4468 if {$isdiff && ![commitinview $nullid2 $curview]} {
4469 # add the line for the changes in the index to the graph
4470 set hl [mc "Local changes checked in to index but not committed"]
4471 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4472 set commitdata($nullid2) "\n $hl\n"
4473 if {[commitinview $nullid $curview]} {
4474 removefakerow $nullid
4476 insertfakerow $nullid2 $mainheadid
4477 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4478 removefakerow $nullid2
4480 return 0
4483 proc readdifffiles {fd serial inst} {
4484 global mainheadid nullid nullid2 curview
4485 global commitinfo commitdata lserial
4487 set isdiff 1
4488 if {[gets $fd line] < 0} {
4489 if {![eof $fd]} {
4490 return 1
4492 set isdiff 0
4494 # we only need to see one line and we don't really care what it says...
4495 stop_instance $inst
4497 if {$serial != $lserial} {
4498 return 0
4501 if {$isdiff && ![commitinview $nullid $curview]} {
4502 # add the line for the local diff to the graph
4503 set hl [mc "Local uncommitted changes, not checked in to index"]
4504 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4505 set commitdata($nullid) "\n $hl\n"
4506 if {[commitinview $nullid2 $curview]} {
4507 set p $nullid2
4508 } else {
4509 set p $mainheadid
4511 insertfakerow $nullid $p
4512 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4513 removefakerow $nullid
4515 return 0
4518 proc nextuse {id row} {
4519 global curview children
4521 if {[info exists children($curview,$id)]} {
4522 foreach kid $children($curview,$id) {
4523 if {![commitinview $kid $curview]} {
4524 return -1
4526 if {[rowofcommit $kid] > $row} {
4527 return [rowofcommit $kid]
4531 if {[commitinview $id $curview]} {
4532 return [rowofcommit $id]
4534 return -1
4537 proc prevuse {id row} {
4538 global curview children
4540 set ret -1
4541 if {[info exists children($curview,$id)]} {
4542 foreach kid $children($curview,$id) {
4543 if {![commitinview $kid $curview]} break
4544 if {[rowofcommit $kid] < $row} {
4545 set ret [rowofcommit $kid]
4549 return $ret
4552 proc make_idlist {row} {
4553 global displayorder parentlist uparrowlen downarrowlen mingaplen
4554 global commitidx curview children
4556 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4557 if {$r < 0} {
4558 set r 0
4560 set ra [expr {$row - $downarrowlen}]
4561 if {$ra < 0} {
4562 set ra 0
4564 set rb [expr {$row + $uparrowlen}]
4565 if {$rb > $commitidx($curview)} {
4566 set rb $commitidx($curview)
4568 make_disporder $r [expr {$rb + 1}]
4569 set ids {}
4570 for {} {$r < $ra} {incr r} {
4571 set nextid [lindex $displayorder [expr {$r + 1}]]
4572 foreach p [lindex $parentlist $r] {
4573 if {$p eq $nextid} continue
4574 set rn [nextuse $p $r]
4575 if {$rn >= $row &&
4576 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4577 lappend ids [list [ordertoken $p] $p]
4581 for {} {$r < $row} {incr r} {
4582 set nextid [lindex $displayorder [expr {$r + 1}]]
4583 foreach p [lindex $parentlist $r] {
4584 if {$p eq $nextid} continue
4585 set rn [nextuse $p $r]
4586 if {$rn < 0 || $rn >= $row} {
4587 lappend ids [list [ordertoken $p] $p]
4591 set id [lindex $displayorder $row]
4592 lappend ids [list [ordertoken $id] $id]
4593 while {$r < $rb} {
4594 foreach p [lindex $parentlist $r] {
4595 set firstkid [lindex $children($curview,$p) 0]
4596 if {[rowofcommit $firstkid] < $row} {
4597 lappend ids [list [ordertoken $p] $p]
4600 incr r
4601 set id [lindex $displayorder $r]
4602 if {$id ne {}} {
4603 set firstkid [lindex $children($curview,$id) 0]
4604 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4605 lappend ids [list [ordertoken $id] $id]
4609 set idlist {}
4610 foreach idx [lsort -unique $ids] {
4611 lappend idlist [lindex $idx 1]
4613 return $idlist
4616 proc rowsequal {a b} {
4617 while {[set i [lsearch -exact $a {}]] >= 0} {
4618 set a [lreplace $a $i $i]
4620 while {[set i [lsearch -exact $b {}]] >= 0} {
4621 set b [lreplace $b $i $i]
4623 return [expr {$a eq $b}]
4626 proc makeupline {id row rend col} {
4627 global rowidlist uparrowlen downarrowlen mingaplen
4629 for {set r $rend} {1} {set r $rstart} {
4630 set rstart [prevuse $id $r]
4631 if {$rstart < 0} return
4632 if {$rstart < $row} break
4634 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4635 set rstart [expr {$rend - $uparrowlen - 1}]
4637 for {set r $rstart} {[incr r] <= $row} {} {
4638 set idlist [lindex $rowidlist $r]
4639 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4640 set col [idcol $idlist $id $col]
4641 lset rowidlist $r [linsert $idlist $col $id]
4642 changedrow $r
4647 proc layoutrows {row endrow} {
4648 global rowidlist rowisopt rowfinal displayorder
4649 global uparrowlen downarrowlen maxwidth mingaplen
4650 global children parentlist
4651 global commitidx viewcomplete curview
4653 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4654 set idlist {}
4655 if {$row > 0} {
4656 set rm1 [expr {$row - 1}]
4657 foreach id [lindex $rowidlist $rm1] {
4658 if {$id ne {}} {
4659 lappend idlist $id
4662 set final [lindex $rowfinal $rm1]
4664 for {} {$row < $endrow} {incr row} {
4665 set rm1 [expr {$row - 1}]
4666 if {$rm1 < 0 || $idlist eq {}} {
4667 set idlist [make_idlist $row]
4668 set final 1
4669 } else {
4670 set id [lindex $displayorder $rm1]
4671 set col [lsearch -exact $idlist $id]
4672 set idlist [lreplace $idlist $col $col]
4673 foreach p [lindex $parentlist $rm1] {
4674 if {[lsearch -exact $idlist $p] < 0} {
4675 set col [idcol $idlist $p $col]
4676 set idlist [linsert $idlist $col $p]
4677 # if not the first child, we have to insert a line going up
4678 if {$id ne [lindex $children($curview,$p) 0]} {
4679 makeupline $p $rm1 $row $col
4683 set id [lindex $displayorder $row]
4684 if {$row > $downarrowlen} {
4685 set termrow [expr {$row - $downarrowlen - 1}]
4686 foreach p [lindex $parentlist $termrow] {
4687 set i [lsearch -exact $idlist $p]
4688 if {$i < 0} continue
4689 set nr [nextuse $p $termrow]
4690 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4691 set idlist [lreplace $idlist $i $i]
4695 set col [lsearch -exact $idlist $id]
4696 if {$col < 0} {
4697 set col [idcol $idlist $id]
4698 set idlist [linsert $idlist $col $id]
4699 if {$children($curview,$id) ne {}} {
4700 makeupline $id $rm1 $row $col
4703 set r [expr {$row + $uparrowlen - 1}]
4704 if {$r < $commitidx($curview)} {
4705 set x $col
4706 foreach p [lindex $parentlist $r] {
4707 if {[lsearch -exact $idlist $p] >= 0} continue
4708 set fk [lindex $children($curview,$p) 0]
4709 if {[rowofcommit $fk] < $row} {
4710 set x [idcol $idlist $p $x]
4711 set idlist [linsert $idlist $x $p]
4714 if {[incr r] < $commitidx($curview)} {
4715 set p [lindex $displayorder $r]
4716 if {[lsearch -exact $idlist $p] < 0} {
4717 set fk [lindex $children($curview,$p) 0]
4718 if {$fk ne {} && [rowofcommit $fk] < $row} {
4719 set x [idcol $idlist $p $x]
4720 set idlist [linsert $idlist $x $p]
4726 if {$final && !$viewcomplete($curview) &&
4727 $row + $uparrowlen + $mingaplen + $downarrowlen
4728 >= $commitidx($curview)} {
4729 set final 0
4731 set l [llength $rowidlist]
4732 if {$row == $l} {
4733 lappend rowidlist $idlist
4734 lappend rowisopt 0
4735 lappend rowfinal $final
4736 } elseif {$row < $l} {
4737 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4738 lset rowidlist $row $idlist
4739 changedrow $row
4741 lset rowfinal $row $final
4742 } else {
4743 set pad [ntimes [expr {$row - $l}] {}]
4744 set rowidlist [concat $rowidlist $pad]
4745 lappend rowidlist $idlist
4746 set rowfinal [concat $rowfinal $pad]
4747 lappend rowfinal $final
4748 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4751 return $row
4754 proc changedrow {row} {
4755 global displayorder iddrawn rowisopt need_redisplay
4757 set l [llength $rowisopt]
4758 if {$row < $l} {
4759 lset rowisopt $row 0
4760 if {$row + 1 < $l} {
4761 lset rowisopt [expr {$row + 1}] 0
4762 if {$row + 2 < $l} {
4763 lset rowisopt [expr {$row + 2}] 0
4767 set id [lindex $displayorder $row]
4768 if {[info exists iddrawn($id)]} {
4769 set need_redisplay 1
4773 proc insert_pad {row col npad} {
4774 global rowidlist
4776 set pad [ntimes $npad {}]
4777 set idlist [lindex $rowidlist $row]
4778 set bef [lrange $idlist 0 [expr {$col - 1}]]
4779 set aft [lrange $idlist $col end]
4780 set i [lsearch -exact $aft {}]
4781 if {$i > 0} {
4782 set aft [lreplace $aft $i $i]
4784 lset rowidlist $row [concat $bef $pad $aft]
4785 changedrow $row
4788 proc optimize_rows {row col endrow} {
4789 global rowidlist rowisopt displayorder curview children
4791 if {$row < 1} {
4792 set row 1
4794 for {} {$row < $endrow} {incr row; set col 0} {
4795 if {[lindex $rowisopt $row]} continue
4796 set haspad 0
4797 set y0 [expr {$row - 1}]
4798 set ym [expr {$row - 2}]
4799 set idlist [lindex $rowidlist $row]
4800 set previdlist [lindex $rowidlist $y0]
4801 if {$idlist eq {} || $previdlist eq {}} continue
4802 if {$ym >= 0} {
4803 set pprevidlist [lindex $rowidlist $ym]
4804 if {$pprevidlist eq {}} continue
4805 } else {
4806 set pprevidlist {}
4808 set x0 -1
4809 set xm -1
4810 for {} {$col < [llength $idlist]} {incr col} {
4811 set id [lindex $idlist $col]
4812 if {[lindex $previdlist $col] eq $id} continue
4813 if {$id eq {}} {
4814 set haspad 1
4815 continue
4817 set x0 [lsearch -exact $previdlist $id]
4818 if {$x0 < 0} continue
4819 set z [expr {$x0 - $col}]
4820 set isarrow 0
4821 set z0 {}
4822 if {$ym >= 0} {
4823 set xm [lsearch -exact $pprevidlist $id]
4824 if {$xm >= 0} {
4825 set z0 [expr {$xm - $x0}]
4828 if {$z0 eq {}} {
4829 # if row y0 is the first child of $id then it's not an arrow
4830 if {[lindex $children($curview,$id) 0] ne
4831 [lindex $displayorder $y0]} {
4832 set isarrow 1
4835 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4836 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4837 set isarrow 1
4839 # Looking at lines from this row to the previous row,
4840 # make them go straight up if they end in an arrow on
4841 # the previous row; otherwise make them go straight up
4842 # or at 45 degrees.
4843 if {$z < -1 || ($z < 0 && $isarrow)} {
4844 # Line currently goes left too much;
4845 # insert pads in the previous row, then optimize it
4846 set npad [expr {-1 - $z + $isarrow}]
4847 insert_pad $y0 $x0 $npad
4848 if {$y0 > 0} {
4849 optimize_rows $y0 $x0 $row
4851 set previdlist [lindex $rowidlist $y0]
4852 set x0 [lsearch -exact $previdlist $id]
4853 set z [expr {$x0 - $col}]
4854 if {$z0 ne {}} {
4855 set pprevidlist [lindex $rowidlist $ym]
4856 set xm [lsearch -exact $pprevidlist $id]
4857 set z0 [expr {$xm - $x0}]
4859 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4860 # Line currently goes right too much;
4861 # insert pads in this line
4862 set npad [expr {$z - 1 + $isarrow}]
4863 insert_pad $row $col $npad
4864 set idlist [lindex $rowidlist $row]
4865 incr col $npad
4866 set z [expr {$x0 - $col}]
4867 set haspad 1
4869 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4870 # this line links to its first child on row $row-2
4871 set id [lindex $displayorder $ym]
4872 set xc [lsearch -exact $pprevidlist $id]
4873 if {$xc >= 0} {
4874 set z0 [expr {$xc - $x0}]
4877 # avoid lines jigging left then immediately right
4878 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4879 insert_pad $y0 $x0 1
4880 incr x0
4881 optimize_rows $y0 $x0 $row
4882 set previdlist [lindex $rowidlist $y0]
4885 if {!$haspad} {
4886 # Find the first column that doesn't have a line going right
4887 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4888 set id [lindex $idlist $col]
4889 if {$id eq {}} break
4890 set x0 [lsearch -exact $previdlist $id]
4891 if {$x0 < 0} {
4892 # check if this is the link to the first child
4893 set kid [lindex $displayorder $y0]
4894 if {[lindex $children($curview,$id) 0] eq $kid} {
4895 # it is, work out offset to child
4896 set x0 [lsearch -exact $previdlist $kid]
4899 if {$x0 <= $col} break
4901 # Insert a pad at that column as long as it has a line and
4902 # isn't the last column
4903 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4904 set idlist [linsert $idlist $col {}]
4905 lset rowidlist $row $idlist
4906 changedrow $row
4912 proc xc {row col} {
4913 global canvx0 linespc
4914 return [expr {$canvx0 + $col * $linespc}]
4917 proc yc {row} {
4918 global canvy0 linespc
4919 return [expr {$canvy0 + $row * $linespc}]
4922 proc linewidth {id} {
4923 global thickerline lthickness
4925 set wid $lthickness
4926 if {[info exists thickerline] && $id eq $thickerline} {
4927 set wid [expr {2 * $lthickness}]
4929 return $wid
4932 proc rowranges {id} {
4933 global curview children uparrowlen downarrowlen
4934 global rowidlist
4936 set kids $children($curview,$id)
4937 if {$kids eq {}} {
4938 return {}
4940 set ret {}
4941 lappend kids $id
4942 foreach child $kids {
4943 if {![commitinview $child $curview]} break
4944 set row [rowofcommit $child]
4945 if {![info exists prev]} {
4946 lappend ret [expr {$row + 1}]
4947 } else {
4948 if {$row <= $prevrow} {
4949 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4951 # see if the line extends the whole way from prevrow to row
4952 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4953 [lsearch -exact [lindex $rowidlist \
4954 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4955 # it doesn't, see where it ends
4956 set r [expr {$prevrow + $downarrowlen}]
4957 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4958 while {[incr r -1] > $prevrow &&
4959 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4960 } else {
4961 while {[incr r] <= $row &&
4962 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4963 incr r -1
4965 lappend ret $r
4966 # see where it starts up again
4967 set r [expr {$row - $uparrowlen}]
4968 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4969 while {[incr r] < $row &&
4970 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4971 } else {
4972 while {[incr r -1] >= $prevrow &&
4973 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4974 incr r
4976 lappend ret $r
4979 if {$child eq $id} {
4980 lappend ret $row
4982 set prev $child
4983 set prevrow $row
4985 return $ret
4988 proc drawlineseg {id row endrow arrowlow} {
4989 global rowidlist displayorder iddrawn linesegs
4990 global canv colormap linespc curview maxlinelen parentlist
4992 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4993 set le [expr {$row + 1}]
4994 set arrowhigh 1
4995 while {1} {
4996 set c [lsearch -exact [lindex $rowidlist $le] $id]
4997 if {$c < 0} {
4998 incr le -1
4999 break
5001 lappend cols $c
5002 set x [lindex $displayorder $le]
5003 if {$x eq $id} {
5004 set arrowhigh 0
5005 break
5007 if {[info exists iddrawn($x)] || $le == $endrow} {
5008 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5009 if {$c >= 0} {
5010 lappend cols $c
5011 set arrowhigh 0
5013 break
5015 incr le
5017 if {$le <= $row} {
5018 return $row
5021 set lines {}
5022 set i 0
5023 set joinhigh 0
5024 if {[info exists linesegs($id)]} {
5025 set lines $linesegs($id)
5026 foreach li $lines {
5027 set r0 [lindex $li 0]
5028 if {$r0 > $row} {
5029 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5030 set joinhigh 1
5032 break
5034 incr i
5037 set joinlow 0
5038 if {$i > 0} {
5039 set li [lindex $lines [expr {$i-1}]]
5040 set r1 [lindex $li 1]
5041 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5042 set joinlow 1
5046 set x [lindex $cols [expr {$le - $row}]]
5047 set xp [lindex $cols [expr {$le - 1 - $row}]]
5048 set dir [expr {$xp - $x}]
5049 if {$joinhigh} {
5050 set ith [lindex $lines $i 2]
5051 set coords [$canv coords $ith]
5052 set ah [$canv itemcget $ith -arrow]
5053 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5054 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5055 if {$x2 ne {} && $x - $x2 == $dir} {
5056 set coords [lrange $coords 0 end-2]
5058 } else {
5059 set coords [list [xc $le $x] [yc $le]]
5061 if {$joinlow} {
5062 set itl [lindex $lines [expr {$i-1}] 2]
5063 set al [$canv itemcget $itl -arrow]
5064 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5065 } elseif {$arrowlow} {
5066 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5067 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5068 set arrowlow 0
5071 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5072 for {set y $le} {[incr y -1] > $row} {} {
5073 set x $xp
5074 set xp [lindex $cols [expr {$y - 1 - $row}]]
5075 set ndir [expr {$xp - $x}]
5076 if {$dir != $ndir || $xp < 0} {
5077 lappend coords [xc $y $x] [yc $y]
5079 set dir $ndir
5081 if {!$joinlow} {
5082 if {$xp < 0} {
5083 # join parent line to first child
5084 set ch [lindex $displayorder $row]
5085 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5086 if {$xc < 0} {
5087 puts "oops: drawlineseg: child $ch not on row $row"
5088 } elseif {$xc != $x} {
5089 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5090 set d [expr {int(0.5 * $linespc)}]
5091 set x1 [xc $row $x]
5092 if {$xc < $x} {
5093 set x2 [expr {$x1 - $d}]
5094 } else {
5095 set x2 [expr {$x1 + $d}]
5097 set y2 [yc $row]
5098 set y1 [expr {$y2 + $d}]
5099 lappend coords $x1 $y1 $x2 $y2
5100 } elseif {$xc < $x - 1} {
5101 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5102 } elseif {$xc > $x + 1} {
5103 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5105 set x $xc
5107 lappend coords [xc $row $x] [yc $row]
5108 } else {
5109 set xn [xc $row $xp]
5110 set yn [yc $row]
5111 lappend coords $xn $yn
5113 if {!$joinhigh} {
5114 assigncolor $id
5115 set t [$canv create line $coords -width [linewidth $id] \
5116 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5117 $canv lower $t
5118 bindline $t $id
5119 set lines [linsert $lines $i [list $row $le $t]]
5120 } else {
5121 $canv coords $ith $coords
5122 if {$arrow ne $ah} {
5123 $canv itemconf $ith -arrow $arrow
5125 lset lines $i 0 $row
5127 } else {
5128 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5129 set ndir [expr {$xo - $xp}]
5130 set clow [$canv coords $itl]
5131 if {$dir == $ndir} {
5132 set clow [lrange $clow 2 end]
5134 set coords [concat $coords $clow]
5135 if {!$joinhigh} {
5136 lset lines [expr {$i-1}] 1 $le
5137 } else {
5138 # coalesce two pieces
5139 $canv delete $ith
5140 set b [lindex $lines [expr {$i-1}] 0]
5141 set e [lindex $lines $i 1]
5142 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5144 $canv coords $itl $coords
5145 if {$arrow ne $al} {
5146 $canv itemconf $itl -arrow $arrow
5150 set linesegs($id) $lines
5151 return $le
5154 proc drawparentlinks {id row} {
5155 global rowidlist canv colormap curview parentlist
5156 global idpos linespc
5158 set rowids [lindex $rowidlist $row]
5159 set col [lsearch -exact $rowids $id]
5160 if {$col < 0} return
5161 set olds [lindex $parentlist $row]
5162 set row2 [expr {$row + 1}]
5163 set x [xc $row $col]
5164 set y [yc $row]
5165 set y2 [yc $row2]
5166 set d [expr {int(0.5 * $linespc)}]
5167 set ymid [expr {$y + $d}]
5168 set ids [lindex $rowidlist $row2]
5169 # rmx = right-most X coord used
5170 set rmx 0
5171 foreach p $olds {
5172 set i [lsearch -exact $ids $p]
5173 if {$i < 0} {
5174 puts "oops, parent $p of $id not in list"
5175 continue
5177 set x2 [xc $row2 $i]
5178 if {$x2 > $rmx} {
5179 set rmx $x2
5181 set j [lsearch -exact $rowids $p]
5182 if {$j < 0} {
5183 # drawlineseg will do this one for us
5184 continue
5186 assigncolor $p
5187 # should handle duplicated parents here...
5188 set coords [list $x $y]
5189 if {$i != $col} {
5190 # if attaching to a vertical segment, draw a smaller
5191 # slant for visual distinctness
5192 if {$i == $j} {
5193 if {$i < $col} {
5194 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5195 } else {
5196 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5198 } elseif {$i < $col && $i < $j} {
5199 # segment slants towards us already
5200 lappend coords [xc $row $j] $y
5201 } else {
5202 if {$i < $col - 1} {
5203 lappend coords [expr {$x2 + $linespc}] $y
5204 } elseif {$i > $col + 1} {
5205 lappend coords [expr {$x2 - $linespc}] $y
5207 lappend coords $x2 $y2
5209 } else {
5210 lappend coords $x2 $y2
5212 set t [$canv create line $coords -width [linewidth $p] \
5213 -fill $colormap($p) -tags lines.$p]
5214 $canv lower $t
5215 bindline $t $p
5217 if {$rmx > [lindex $idpos($id) 1]} {
5218 lset idpos($id) 1 $rmx
5219 redrawtags $id
5223 proc drawlines {id} {
5224 global canv
5226 $canv itemconf lines.$id -width [linewidth $id]
5229 proc drawcmittext {id row col} {
5230 global linespc canv canv2 canv3 fgcolor curview
5231 global cmitlisted commitinfo rowidlist parentlist
5232 global rowtextx idpos idtags idheads idotherrefs
5233 global linehtag linentag linedtag selectedline
5234 global canvxmax boldrows boldnamerows fgcolor
5235 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5237 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5238 set listed $cmitlisted($curview,$id)
5239 if {$id eq $nullid} {
5240 set ofill red
5241 } elseif {$id eq $nullid2} {
5242 set ofill green
5243 } elseif {$id eq $mainheadid} {
5244 set ofill yellow
5245 } else {
5246 set ofill [lindex $circlecolors $listed]
5248 set x [xc $row $col]
5249 set y [yc $row]
5250 set orad [expr {$linespc / 3}]
5251 if {$listed <= 2} {
5252 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5253 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5254 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5255 } elseif {$listed == 3} {
5256 # triangle pointing left for left-side commits
5257 set t [$canv create polygon \
5258 [expr {$x - $orad}] $y \
5259 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5260 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5261 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5262 } else {
5263 # triangle pointing right for right-side commits
5264 set t [$canv create polygon \
5265 [expr {$x + $orad - 1}] $y \
5266 [expr {$x - $orad}] [expr {$y - $orad}] \
5267 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5268 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5270 set circleitem($row) $t
5271 $canv raise $t
5272 $canv bind $t <1> {selcanvline {} %x %y}
5273 set rmx [llength [lindex $rowidlist $row]]
5274 set olds [lindex $parentlist $row]
5275 if {$olds ne {}} {
5276 set nextids [lindex $rowidlist [expr {$row + 1}]]
5277 foreach p $olds {
5278 set i [lsearch -exact $nextids $p]
5279 if {$i > $rmx} {
5280 set rmx $i
5284 set xt [xc $row $rmx]
5285 set rowtextx($row) $xt
5286 set idpos($id) [list $x $xt $y]
5287 if {[info exists idtags($id)] || [info exists idheads($id)]
5288 || [info exists idotherrefs($id)]} {
5289 set xt [drawtags $id $x $xt $y]
5291 set headline [lindex $commitinfo($id) 0]
5292 set name [lindex $commitinfo($id) 1]
5293 set date [lindex $commitinfo($id) 2]
5294 set date [formatdate $date]
5295 set font mainfont
5296 set nfont mainfont
5297 set isbold [ishighlighted $id]
5298 if {$isbold > 0} {
5299 lappend boldrows $row
5300 set font mainfontbold
5301 if {$isbold > 1} {
5302 lappend boldnamerows $row
5303 set nfont mainfontbold
5306 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5307 -text $headline -font $font -tags text]
5308 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5309 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5310 -text $name -font $nfont -tags text]
5311 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5312 -text $date -font mainfont -tags text]
5313 if {$selectedline == $row} {
5314 make_secsel $row
5316 set xr [expr {$xt + [font measure $font $headline]}]
5317 if {$xr > $canvxmax} {
5318 set canvxmax $xr
5319 setcanvscroll
5323 proc drawcmitrow {row} {
5324 global displayorder rowidlist nrows_drawn
5325 global iddrawn markingmatches
5326 global commitinfo numcommits
5327 global filehighlight fhighlights findpattern nhighlights
5328 global hlview vhighlights
5329 global highlight_related rhighlights
5331 if {$row >= $numcommits} return
5333 set id [lindex $displayorder $row]
5334 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5335 askvhighlight $row $id
5337 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5338 askfilehighlight $row $id
5340 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5341 askfindhighlight $row $id
5343 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5344 askrelhighlight $row $id
5346 if {![info exists iddrawn($id)]} {
5347 set col [lsearch -exact [lindex $rowidlist $row] $id]
5348 if {$col < 0} {
5349 puts "oops, row $row id $id not in list"
5350 return
5352 if {![info exists commitinfo($id)]} {
5353 getcommit $id
5355 assigncolor $id
5356 drawcmittext $id $row $col
5357 set iddrawn($id) 1
5358 incr nrows_drawn
5360 if {$markingmatches} {
5361 markrowmatches $row $id
5365 proc drawcommits {row {endrow {}}} {
5366 global numcommits iddrawn displayorder curview need_redisplay
5367 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5369 if {$row < 0} {
5370 set row 0
5372 if {$endrow eq {}} {
5373 set endrow $row
5375 if {$endrow >= $numcommits} {
5376 set endrow [expr {$numcommits - 1}]
5379 set rl1 [expr {$row - $downarrowlen - 3}]
5380 if {$rl1 < 0} {
5381 set rl1 0
5383 set ro1 [expr {$row - 3}]
5384 if {$ro1 < 0} {
5385 set ro1 0
5387 set r2 [expr {$endrow + $uparrowlen + 3}]
5388 if {$r2 > $numcommits} {
5389 set r2 $numcommits
5391 for {set r $rl1} {$r < $r2} {incr r} {
5392 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5393 if {$rl1 < $r} {
5394 layoutrows $rl1 $r
5396 set rl1 [expr {$r + 1}]
5399 if {$rl1 < $r} {
5400 layoutrows $rl1 $r
5402 optimize_rows $ro1 0 $r2
5403 if {$need_redisplay || $nrows_drawn > 2000} {
5404 clear_display
5405 drawvisible
5408 # make the lines join to already-drawn rows either side
5409 set r [expr {$row - 1}]
5410 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5411 set r $row
5413 set er [expr {$endrow + 1}]
5414 if {$er >= $numcommits ||
5415 ![info exists iddrawn([lindex $displayorder $er])]} {
5416 set er $endrow
5418 for {} {$r <= $er} {incr r} {
5419 set id [lindex $displayorder $r]
5420 set wasdrawn [info exists iddrawn($id)]
5421 drawcmitrow $r
5422 if {$r == $er} break
5423 set nextid [lindex $displayorder [expr {$r + 1}]]
5424 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5425 drawparentlinks $id $r
5427 set rowids [lindex $rowidlist $r]
5428 foreach lid $rowids {
5429 if {$lid eq {}} continue
5430 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5431 if {$lid eq $id} {
5432 # see if this is the first child of any of its parents
5433 foreach p [lindex $parentlist $r] {
5434 if {[lsearch -exact $rowids $p] < 0} {
5435 # make this line extend up to the child
5436 set lineend($p) [drawlineseg $p $r $er 0]
5439 } else {
5440 set lineend($lid) [drawlineseg $lid $r $er 1]
5446 proc undolayout {row} {
5447 global uparrowlen mingaplen downarrowlen
5448 global rowidlist rowisopt rowfinal need_redisplay
5450 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5451 if {$r < 0} {
5452 set r 0
5454 if {[llength $rowidlist] > $r} {
5455 incr r -1
5456 set rowidlist [lrange $rowidlist 0 $r]
5457 set rowfinal [lrange $rowfinal 0 $r]
5458 set rowisopt [lrange $rowisopt 0 $r]
5459 set need_redisplay 1
5460 run drawvisible
5464 proc drawvisible {} {
5465 global canv linespc curview vrowmod selectedline targetrow targetid
5466 global need_redisplay cscroll numcommits
5468 set fs [$canv yview]
5469 set ymax [lindex [$canv cget -scrollregion] 3]
5470 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5471 set f0 [lindex $fs 0]
5472 set f1 [lindex $fs 1]
5473 set y0 [expr {int($f0 * $ymax)}]
5474 set y1 [expr {int($f1 * $ymax)}]
5476 if {[info exists targetid]} {
5477 if {[commitinview $targetid $curview]} {
5478 set r [rowofcommit $targetid]
5479 if {$r != $targetrow} {
5480 # Fix up the scrollregion and change the scrolling position
5481 # now that our target row has moved.
5482 set diff [expr {($r - $targetrow) * $linespc}]
5483 set targetrow $r
5484 setcanvscroll
5485 set ymax [lindex [$canv cget -scrollregion] 3]
5486 incr y0 $diff
5487 incr y1 $diff
5488 set f0 [expr {$y0 / $ymax}]
5489 set f1 [expr {$y1 / $ymax}]
5490 allcanvs yview moveto $f0
5491 $cscroll set $f0 $f1
5492 set need_redisplay 1
5494 } else {
5495 unset targetid
5499 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5500 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5501 if {$endrow >= $vrowmod($curview)} {
5502 update_arcrows $curview
5504 if {$selectedline ne {} &&
5505 $row <= $selectedline && $selectedline <= $endrow} {
5506 set targetrow $selectedline
5507 } elseif {[info exists targetid]} {
5508 set targetrow [expr {int(($row + $endrow) / 2)}]
5510 if {[info exists targetrow]} {
5511 if {$targetrow >= $numcommits} {
5512 set targetrow [expr {$numcommits - 1}]
5514 set targetid [commitonrow $targetrow]
5516 drawcommits $row $endrow
5519 proc clear_display {} {
5520 global iddrawn linesegs need_redisplay nrows_drawn
5521 global vhighlights fhighlights nhighlights rhighlights
5522 global linehtag linentag linedtag boldrows boldnamerows
5524 allcanvs delete all
5525 catch {unset iddrawn}
5526 catch {unset linesegs}
5527 catch {unset linehtag}
5528 catch {unset linentag}
5529 catch {unset linedtag}
5530 set boldrows {}
5531 set boldnamerows {}
5532 catch {unset vhighlights}
5533 catch {unset fhighlights}
5534 catch {unset nhighlights}
5535 catch {unset rhighlights}
5536 set need_redisplay 0
5537 set nrows_drawn 0
5540 proc findcrossings {id} {
5541 global rowidlist parentlist numcommits displayorder
5543 set cross {}
5544 set ccross {}
5545 foreach {s e} [rowranges $id] {
5546 if {$e >= $numcommits} {
5547 set e [expr {$numcommits - 1}]
5549 if {$e <= $s} continue
5550 for {set row $e} {[incr row -1] >= $s} {} {
5551 set x [lsearch -exact [lindex $rowidlist $row] $id]
5552 if {$x < 0} break
5553 set olds [lindex $parentlist $row]
5554 set kid [lindex $displayorder $row]
5555 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5556 if {$kidx < 0} continue
5557 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5558 foreach p $olds {
5559 set px [lsearch -exact $nextrow $p]
5560 if {$px < 0} continue
5561 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5562 if {[lsearch -exact $ccross $p] >= 0} continue
5563 if {$x == $px + ($kidx < $px? -1: 1)} {
5564 lappend ccross $p
5565 } elseif {[lsearch -exact $cross $p] < 0} {
5566 lappend cross $p
5572 return [concat $ccross {{}} $cross]
5575 proc assigncolor {id} {
5576 global colormap colors nextcolor
5577 global parents children children curview
5579 if {[info exists colormap($id)]} return
5580 set ncolors [llength $colors]
5581 if {[info exists children($curview,$id)]} {
5582 set kids $children($curview,$id)
5583 } else {
5584 set kids {}
5586 if {[llength $kids] == 1} {
5587 set child [lindex $kids 0]
5588 if {[info exists colormap($child)]
5589 && [llength $parents($curview,$child)] == 1} {
5590 set colormap($id) $colormap($child)
5591 return
5594 set badcolors {}
5595 set origbad {}
5596 foreach x [findcrossings $id] {
5597 if {$x eq {}} {
5598 # delimiter between corner crossings and other crossings
5599 if {[llength $badcolors] >= $ncolors - 1} break
5600 set origbad $badcolors
5602 if {[info exists colormap($x)]
5603 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5604 lappend badcolors $colormap($x)
5607 if {[llength $badcolors] >= $ncolors} {
5608 set badcolors $origbad
5610 set origbad $badcolors
5611 if {[llength $badcolors] < $ncolors - 1} {
5612 foreach child $kids {
5613 if {[info exists colormap($child)]
5614 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5615 lappend badcolors $colormap($child)
5617 foreach p $parents($curview,$child) {
5618 if {[info exists colormap($p)]
5619 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5620 lappend badcolors $colormap($p)
5624 if {[llength $badcolors] >= $ncolors} {
5625 set badcolors $origbad
5628 for {set i 0} {$i <= $ncolors} {incr i} {
5629 set c [lindex $colors $nextcolor]
5630 if {[incr nextcolor] >= $ncolors} {
5631 set nextcolor 0
5633 if {[lsearch -exact $badcolors $c]} break
5635 set colormap($id) $c
5638 proc bindline {t id} {
5639 global canv
5641 $canv bind $t <Enter> "lineenter %x %y $id"
5642 $canv bind $t <Motion> "linemotion %x %y $id"
5643 $canv bind $t <Leave> "lineleave $id"
5644 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5647 proc drawtags {id x xt y1} {
5648 global idtags idheads idotherrefs mainhead
5649 global linespc lthickness
5650 global canv rowtextx curview fgcolor bgcolor ctxbut
5652 set marks {}
5653 set ntags 0
5654 set nheads 0
5655 if {[info exists idtags($id)]} {
5656 set marks $idtags($id)
5657 set ntags [llength $marks]
5659 if {[info exists idheads($id)]} {
5660 set marks [concat $marks $idheads($id)]
5661 set nheads [llength $idheads($id)]
5663 if {[info exists idotherrefs($id)]} {
5664 set marks [concat $marks $idotherrefs($id)]
5666 if {$marks eq {}} {
5667 return $xt
5670 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5671 set yt [expr {$y1 - 0.5 * $linespc}]
5672 set yb [expr {$yt + $linespc - 1}]
5673 set xvals {}
5674 set wvals {}
5675 set i -1
5676 foreach tag $marks {
5677 incr i
5678 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5679 set wid [font measure mainfontbold $tag]
5680 } else {
5681 set wid [font measure mainfont $tag]
5683 lappend xvals $xt
5684 lappend wvals $wid
5685 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5687 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5688 -width $lthickness -fill black -tags tag.$id]
5689 $canv lower $t
5690 foreach tag $marks x $xvals wid $wvals {
5691 set xl [expr {$x + $delta}]
5692 set xr [expr {$x + $delta + $wid + $lthickness}]
5693 set font mainfont
5694 if {[incr ntags -1] >= 0} {
5695 # draw a tag
5696 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5697 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5698 -width 1 -outline black -fill yellow -tags tag.$id]
5699 $canv bind $t <1> [list showtag $tag 1]
5700 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5701 } else {
5702 # draw a head or other ref
5703 if {[incr nheads -1] >= 0} {
5704 set col green
5705 if {$tag eq $mainhead} {
5706 set font mainfontbold
5708 } else {
5709 set col "#ddddff"
5711 set xl [expr {$xl - $delta/2}]
5712 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5713 -width 1 -outline black -fill $col -tags tag.$id
5714 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5715 set rwid [font measure mainfont $remoteprefix]
5716 set xi [expr {$x + 1}]
5717 set yti [expr {$yt + 1}]
5718 set xri [expr {$x + $rwid}]
5719 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5720 -width 0 -fill "#ffddaa" -tags tag.$id
5723 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5724 -font $font -tags [list tag.$id text]]
5725 if {$ntags >= 0} {
5726 $canv bind $t <1> [list showtag $tag 1]
5727 } elseif {$nheads >= 0} {
5728 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5731 return $xt
5734 proc xcoord {i level ln} {
5735 global canvx0 xspc1 xspc2
5737 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5738 if {$i > 0 && $i == $level} {
5739 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5740 } elseif {$i > $level} {
5741 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5743 return $x
5746 proc show_status {msg} {
5747 global canv fgcolor
5749 clear_display
5750 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5751 -tags text -fill $fgcolor
5754 # Don't change the text pane cursor if it is currently the hand cursor,
5755 # showing that we are over a sha1 ID link.
5756 proc settextcursor {c} {
5757 global ctext curtextcursor
5759 if {[$ctext cget -cursor] == $curtextcursor} {
5760 $ctext config -cursor $c
5762 set curtextcursor $c
5765 proc nowbusy {what {name {}}} {
5766 global isbusy busyname statusw
5768 if {[array names isbusy] eq {}} {
5769 . config -cursor watch
5770 settextcursor watch
5772 set isbusy($what) 1
5773 set busyname($what) $name
5774 if {$name ne {}} {
5775 $statusw conf -text $name
5779 proc notbusy {what} {
5780 global isbusy maincursor textcursor busyname statusw
5782 catch {
5783 unset isbusy($what)
5784 if {$busyname($what) ne {} &&
5785 [$statusw cget -text] eq $busyname($what)} {
5786 $statusw conf -text {}
5789 if {[array names isbusy] eq {}} {
5790 . config -cursor $maincursor
5791 settextcursor $textcursor
5795 proc findmatches {f} {
5796 global findtype findstring
5797 if {$findtype == [mc "Regexp"]} {
5798 set matches [regexp -indices -all -inline $findstring $f]
5799 } else {
5800 set fs $findstring
5801 if {$findtype == [mc "IgnCase"]} {
5802 set f [string tolower $f]
5803 set fs [string tolower $fs]
5805 set matches {}
5806 set i 0
5807 set l [string length $fs]
5808 while {[set j [string first $fs $f $i]] >= 0} {
5809 lappend matches [list $j [expr {$j+$l-1}]]
5810 set i [expr {$j + $l}]
5813 return $matches
5816 proc dofind {{dirn 1} {wrap 1}} {
5817 global findstring findstartline findcurline selectedline numcommits
5818 global gdttype filehighlight fh_serial find_dirn findallowwrap
5820 if {[info exists find_dirn]} {
5821 if {$find_dirn == $dirn} return
5822 stopfinding
5824 focus .
5825 if {$findstring eq {} || $numcommits == 0} return
5826 if {$selectedline eq {}} {
5827 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5828 } else {
5829 set findstartline $selectedline
5831 set findcurline $findstartline
5832 nowbusy finding [mc "Searching"]
5833 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5834 after cancel do_file_hl $fh_serial
5835 do_file_hl $fh_serial
5837 set find_dirn $dirn
5838 set findallowwrap $wrap
5839 run findmore
5842 proc stopfinding {} {
5843 global find_dirn findcurline fprogcoord
5845 if {[info exists find_dirn]} {
5846 unset find_dirn
5847 unset findcurline
5848 notbusy finding
5849 set fprogcoord 0
5850 adjustprogress
5852 stopblaming
5855 proc findmore {} {
5856 global commitdata commitinfo numcommits findpattern findloc
5857 global findstartline findcurline findallowwrap
5858 global find_dirn gdttype fhighlights fprogcoord
5859 global curview varcorder vrownum varccommits vrowmod
5861 if {![info exists find_dirn]} {
5862 return 0
5864 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5865 set l $findcurline
5866 set moretodo 0
5867 if {$find_dirn > 0} {
5868 incr l
5869 if {$l >= $numcommits} {
5870 set l 0
5872 if {$l <= $findstartline} {
5873 set lim [expr {$findstartline + 1}]
5874 } else {
5875 set lim $numcommits
5876 set moretodo $findallowwrap
5878 } else {
5879 if {$l == 0} {
5880 set l $numcommits
5882 incr l -1
5883 if {$l >= $findstartline} {
5884 set lim [expr {$findstartline - 1}]
5885 } else {
5886 set lim -1
5887 set moretodo $findallowwrap
5890 set n [expr {($lim - $l) * $find_dirn}]
5891 if {$n > 500} {
5892 set n 500
5893 set moretodo 1
5895 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5896 update_arcrows $curview
5898 set found 0
5899 set domore 1
5900 set ai [bsearch $vrownum($curview) $l]
5901 set a [lindex $varcorder($curview) $ai]
5902 set arow [lindex $vrownum($curview) $ai]
5903 set ids [lindex $varccommits($curview,$a)]
5904 set arowend [expr {$arow + [llength $ids]}]
5905 if {$gdttype eq [mc "containing:"]} {
5906 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5907 if {$l < $arow || $l >= $arowend} {
5908 incr ai $find_dirn
5909 set a [lindex $varcorder($curview) $ai]
5910 set arow [lindex $vrownum($curview) $ai]
5911 set ids [lindex $varccommits($curview,$a)]
5912 set arowend [expr {$arow + [llength $ids]}]
5914 set id [lindex $ids [expr {$l - $arow}]]
5915 # shouldn't happen unless git log doesn't give all the commits...
5916 if {![info exists commitdata($id)] ||
5917 ![doesmatch $commitdata($id)]} {
5918 continue
5920 if {![info exists commitinfo($id)]} {
5921 getcommit $id
5923 set info $commitinfo($id)
5924 foreach f $info ty $fldtypes {
5925 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5926 [doesmatch $f]} {
5927 set found 1
5928 break
5931 if {$found} break
5933 } else {
5934 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5935 if {$l < $arow || $l >= $arowend} {
5936 incr ai $find_dirn
5937 set a [lindex $varcorder($curview) $ai]
5938 set arow [lindex $vrownum($curview) $ai]
5939 set ids [lindex $varccommits($curview,$a)]
5940 set arowend [expr {$arow + [llength $ids]}]
5942 set id [lindex $ids [expr {$l - $arow}]]
5943 if {![info exists fhighlights($id)]} {
5944 # this sets fhighlights($id) to -1
5945 askfilehighlight $l $id
5947 if {$fhighlights($id) > 0} {
5948 set found $domore
5949 break
5951 if {$fhighlights($id) < 0} {
5952 if {$domore} {
5953 set domore 0
5954 set findcurline [expr {$l - $find_dirn}]
5959 if {$found || ($domore && !$moretodo)} {
5960 unset findcurline
5961 unset find_dirn
5962 notbusy finding
5963 set fprogcoord 0
5964 adjustprogress
5965 if {$found} {
5966 findselectline $l
5967 } else {
5968 bell
5970 return 0
5972 if {!$domore} {
5973 flushhighlights
5974 } else {
5975 set findcurline [expr {$l - $find_dirn}]
5977 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5978 if {$n < 0} {
5979 incr n $numcommits
5981 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5982 adjustprogress
5983 return $domore
5986 proc findselectline {l} {
5987 global findloc commentend ctext findcurline markingmatches gdttype
5989 set markingmatches 1
5990 set findcurline $l
5991 selectline $l 1
5992 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5993 # highlight the matches in the comments
5994 set f [$ctext get 1.0 $commentend]
5995 set matches [findmatches $f]
5996 foreach match $matches {
5997 set start [lindex $match 0]
5998 set end [expr {[lindex $match 1] + 1}]
5999 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6002 drawvisible
6005 # mark the bits of a headline or author that match a find string
6006 proc markmatches {canv l str tag matches font row} {
6007 global selectedline
6009 set bbox [$canv bbox $tag]
6010 set x0 [lindex $bbox 0]
6011 set y0 [lindex $bbox 1]
6012 set y1 [lindex $bbox 3]
6013 foreach match $matches {
6014 set start [lindex $match 0]
6015 set end [lindex $match 1]
6016 if {$start > $end} continue
6017 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6018 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6019 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6020 [expr {$x0+$xlen+2}] $y1 \
6021 -outline {} -tags [list match$l matches] -fill yellow]
6022 $canv lower $t
6023 if {$row == $selectedline} {
6024 $canv raise $t secsel
6029 proc unmarkmatches {} {
6030 global markingmatches
6032 allcanvs delete matches
6033 set markingmatches 0
6034 stopfinding
6037 proc selcanvline {w x y} {
6038 global canv canvy0 ctext linespc
6039 global rowtextx
6040 set ymax [lindex [$canv cget -scrollregion] 3]
6041 if {$ymax == {}} return
6042 set yfrac [lindex [$canv yview] 0]
6043 set y [expr {$y + $yfrac * $ymax}]
6044 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6045 if {$l < 0} {
6046 set l 0
6048 if {$w eq $canv} {
6049 set xmax [lindex [$canv cget -scrollregion] 2]
6050 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6051 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6053 unmarkmatches
6054 selectline $l 1
6057 proc commit_descriptor {p} {
6058 global commitinfo
6059 if {![info exists commitinfo($p)]} {
6060 getcommit $p
6062 set l "..."
6063 if {[llength $commitinfo($p)] > 1} {
6064 set l [lindex $commitinfo($p) 0]
6066 return "$p ($l)\n"
6069 # append some text to the ctext widget, and make any SHA1 ID
6070 # that we know about be a clickable link.
6071 proc appendwithlinks {text tags} {
6072 global ctext linknum curview
6074 set start [$ctext index "end - 1c"]
6075 $ctext insert end $text $tags
6076 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6077 foreach l $links {
6078 set s [lindex $l 0]
6079 set e [lindex $l 1]
6080 set linkid [string range $text $s $e]
6081 incr e
6082 $ctext tag delete link$linknum
6083 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6084 setlink $linkid link$linknum
6085 incr linknum
6089 proc setlink {id lk} {
6090 global curview ctext pendinglinks
6092 set known 0
6093 if {[string length $id] < 40} {
6094 set matches [longid $id]
6095 if {[llength $matches] > 0} {
6096 if {[llength $matches] > 1} return
6097 set known 1
6098 set id [lindex $matches 0]
6100 } else {
6101 set known [commitinview $id $curview]
6103 if {$known} {
6104 $ctext tag conf $lk -foreground blue -underline 1
6105 $ctext tag bind $lk <1> [list selbyid $id]
6106 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6107 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6108 } else {
6109 lappend pendinglinks($id) $lk
6110 interestedin $id {makelink %P}
6114 proc makelink {id} {
6115 global pendinglinks
6117 if {![info exists pendinglinks($id)]} return
6118 foreach lk $pendinglinks($id) {
6119 setlink $id $lk
6121 unset pendinglinks($id)
6124 proc linkcursor {w inc} {
6125 global linkentercount curtextcursor
6127 if {[incr linkentercount $inc] > 0} {
6128 $w configure -cursor hand2
6129 } else {
6130 $w configure -cursor $curtextcursor
6131 if {$linkentercount < 0} {
6132 set linkentercount 0
6137 proc viewnextline {dir} {
6138 global canv linespc
6140 $canv delete hover
6141 set ymax [lindex [$canv cget -scrollregion] 3]
6142 set wnow [$canv yview]
6143 set wtop [expr {[lindex $wnow 0] * $ymax}]
6144 set newtop [expr {$wtop + $dir * $linespc}]
6145 if {$newtop < 0} {
6146 set newtop 0
6147 } elseif {$newtop > $ymax} {
6148 set newtop $ymax
6150 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6153 # add a list of tag or branch names at position pos
6154 # returns the number of names inserted
6155 proc appendrefs {pos ids var} {
6156 global ctext linknum curview $var maxrefs
6158 if {[catch {$ctext index $pos}]} {
6159 return 0
6161 $ctext conf -state normal
6162 $ctext delete $pos "$pos lineend"
6163 set tags {}
6164 foreach id $ids {
6165 foreach tag [set $var\($id\)] {
6166 lappend tags [list $tag $id]
6169 if {[llength $tags] > $maxrefs} {
6170 $ctext insert $pos "many ([llength $tags])"
6171 } else {
6172 set tags [lsort -index 0 -decreasing $tags]
6173 set sep {}
6174 foreach ti $tags {
6175 set id [lindex $ti 1]
6176 set lk link$linknum
6177 incr linknum
6178 $ctext tag delete $lk
6179 $ctext insert $pos $sep
6180 $ctext insert $pos [lindex $ti 0] $lk
6181 setlink $id $lk
6182 set sep ", "
6185 $ctext conf -state disabled
6186 return [llength $tags]
6189 # called when we have finished computing the nearby tags
6190 proc dispneartags {delay} {
6191 global selectedline currentid showneartags tagphase
6193 if {$selectedline eq {} || !$showneartags} return
6194 after cancel dispnexttag
6195 if {$delay} {
6196 after 200 dispnexttag
6197 set tagphase -1
6198 } else {
6199 after idle dispnexttag
6200 set tagphase 0
6204 proc dispnexttag {} {
6205 global selectedline currentid showneartags tagphase ctext
6207 if {$selectedline eq {} || !$showneartags} return
6208 switch -- $tagphase {
6210 set dtags [desctags $currentid]
6211 if {$dtags ne {}} {
6212 appendrefs precedes $dtags idtags
6216 set atags [anctags $currentid]
6217 if {$atags ne {}} {
6218 appendrefs follows $atags idtags
6222 set dheads [descheads $currentid]
6223 if {$dheads ne {}} {
6224 if {[appendrefs branch $dheads idheads] > 1
6225 && [$ctext get "branch -3c"] eq "h"} {
6226 # turn "Branch" into "Branches"
6227 $ctext conf -state normal
6228 $ctext insert "branch -2c" "es"
6229 $ctext conf -state disabled
6234 if {[incr tagphase] <= 2} {
6235 after idle dispnexttag
6239 proc make_secsel {l} {
6240 global linehtag linentag linedtag canv canv2 canv3
6242 if {![info exists linehtag($l)]} return
6243 $canv delete secsel
6244 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
6245 -tags secsel -fill [$canv cget -selectbackground]]
6246 $canv lower $t
6247 $canv2 delete secsel
6248 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
6249 -tags secsel -fill [$canv2 cget -selectbackground]]
6250 $canv2 lower $t
6251 $canv3 delete secsel
6252 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
6253 -tags secsel -fill [$canv3 cget -selectbackground]]
6254 $canv3 lower $t
6257 proc selectline {l isnew {desired_loc {}}} {
6258 global canv ctext commitinfo selectedline
6259 global canvy0 linespc parents children curview
6260 global currentid sha1entry
6261 global commentend idtags linknum
6262 global mergemax numcommits pending_select
6263 global cmitmode showneartags allcommits
6264 global targetrow targetid lastscrollrows
6265 global autoselect jump_to_here
6267 catch {unset pending_select}
6268 $canv delete hover
6269 normalline
6270 unsel_reflist
6271 stopfinding
6272 if {$l < 0 || $l >= $numcommits} return
6273 set id [commitonrow $l]
6274 set targetid $id
6275 set targetrow $l
6276 set selectedline $l
6277 set currentid $id
6278 if {$lastscrollrows < $numcommits} {
6279 setcanvscroll
6282 set y [expr {$canvy0 + $l * $linespc}]
6283 set ymax [lindex [$canv cget -scrollregion] 3]
6284 set ytop [expr {$y - $linespc - 1}]
6285 set ybot [expr {$y + $linespc + 1}]
6286 set wnow [$canv yview]
6287 set wtop [expr {[lindex $wnow 0] * $ymax}]
6288 set wbot [expr {[lindex $wnow 1] * $ymax}]
6289 set wh [expr {$wbot - $wtop}]
6290 set newtop $wtop
6291 if {$ytop < $wtop} {
6292 if {$ybot < $wtop} {
6293 set newtop [expr {$y - $wh / 2.0}]
6294 } else {
6295 set newtop $ytop
6296 if {$newtop > $wtop - $linespc} {
6297 set newtop [expr {$wtop - $linespc}]
6300 } elseif {$ybot > $wbot} {
6301 if {$ytop > $wbot} {
6302 set newtop [expr {$y - $wh / 2.0}]
6303 } else {
6304 set newtop [expr {$ybot - $wh}]
6305 if {$newtop < $wtop + $linespc} {
6306 set newtop [expr {$wtop + $linespc}]
6310 if {$newtop != $wtop} {
6311 if {$newtop < 0} {
6312 set newtop 0
6314 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6315 drawvisible
6318 make_secsel $l
6320 if {$isnew} {
6321 addtohistory [list selbyid $id]
6324 $sha1entry delete 0 end
6325 $sha1entry insert 0 $id
6326 if {$autoselect} {
6327 $sha1entry selection from 0
6328 $sha1entry selection to end
6330 rhighlight_sel $id
6332 $ctext conf -state normal
6333 clear_ctext
6334 set linknum 0
6335 if {![info exists commitinfo($id)]} {
6336 getcommit $id
6338 set info $commitinfo($id)
6339 set date [formatdate [lindex $info 2]]
6340 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6341 set date [formatdate [lindex $info 4]]
6342 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6343 if {[info exists idtags($id)]} {
6344 $ctext insert end [mc "Tags:"]
6345 foreach tag $idtags($id) {
6346 $ctext insert end " $tag"
6348 $ctext insert end "\n"
6351 set headers {}
6352 set olds $parents($curview,$id)
6353 if {[llength $olds] > 1} {
6354 set np 0
6355 foreach p $olds {
6356 if {$np >= $mergemax} {
6357 set tag mmax
6358 } else {
6359 set tag m$np
6361 $ctext insert end "[mc "Parent"]: " $tag
6362 appendwithlinks [commit_descriptor $p] {}
6363 incr np
6365 } else {
6366 foreach p $olds {
6367 append headers "[mc "Parent"]: [commit_descriptor $p]"
6371 foreach c $children($curview,$id) {
6372 append headers "[mc "Child"]: [commit_descriptor $c]"
6375 # make anything that looks like a SHA1 ID be a clickable link
6376 appendwithlinks $headers {}
6377 if {$showneartags} {
6378 if {![info exists allcommits]} {
6379 getallcommits
6381 $ctext insert end "[mc "Branch"]: "
6382 $ctext mark set branch "end -1c"
6383 $ctext mark gravity branch left
6384 $ctext insert end "\n[mc "Follows"]: "
6385 $ctext mark set follows "end -1c"
6386 $ctext mark gravity follows left
6387 $ctext insert end "\n[mc "Precedes"]: "
6388 $ctext mark set precedes "end -1c"
6389 $ctext mark gravity precedes left
6390 $ctext insert end "\n"
6391 dispneartags 1
6393 $ctext insert end "\n"
6394 set comment [lindex $info 5]
6395 if {[string first "\r" $comment] >= 0} {
6396 set comment [string map {"\r" "\n "} $comment]
6398 appendwithlinks $comment {comment}
6400 $ctext tag remove found 1.0 end
6401 $ctext conf -state disabled
6402 set commentend [$ctext index "end - 1c"]
6404 set jump_to_here $desired_loc
6405 init_flist [mc "Comments"]
6406 if {$cmitmode eq "tree"} {
6407 gettree $id
6408 } elseif {[llength $olds] <= 1} {
6409 startdiff $id
6410 } else {
6411 mergediff $id
6415 proc selfirstline {} {
6416 unmarkmatches
6417 selectline 0 1
6420 proc sellastline {} {
6421 global numcommits
6422 unmarkmatches
6423 set l [expr {$numcommits - 1}]
6424 selectline $l 1
6427 proc selnextline {dir} {
6428 global selectedline
6429 focus .
6430 if {$selectedline eq {}} return
6431 set l [expr {$selectedline + $dir}]
6432 unmarkmatches
6433 selectline $l 1
6436 proc selnextpage {dir} {
6437 global canv linespc selectedline numcommits
6439 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6440 if {$lpp < 1} {
6441 set lpp 1
6443 allcanvs yview scroll [expr {$dir * $lpp}] units
6444 drawvisible
6445 if {$selectedline eq {}} return
6446 set l [expr {$selectedline + $dir * $lpp}]
6447 if {$l < 0} {
6448 set l 0
6449 } elseif {$l >= $numcommits} {
6450 set l [expr $numcommits - 1]
6452 unmarkmatches
6453 selectline $l 1
6456 proc unselectline {} {
6457 global selectedline currentid
6459 set selectedline {}
6460 catch {unset currentid}
6461 allcanvs delete secsel
6462 rhighlight_none
6465 proc reselectline {} {
6466 global selectedline
6468 if {$selectedline ne {}} {
6469 selectline $selectedline 0
6473 proc addtohistory {cmd} {
6474 global history historyindex curview
6476 set elt [list $curview $cmd]
6477 if {$historyindex > 0
6478 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6479 return
6482 if {$historyindex < [llength $history]} {
6483 set history [lreplace $history $historyindex end $elt]
6484 } else {
6485 lappend history $elt
6487 incr historyindex
6488 if {$historyindex > 1} {
6489 .tf.bar.leftbut conf -state normal
6490 } else {
6491 .tf.bar.leftbut conf -state disabled
6493 .tf.bar.rightbut conf -state disabled
6496 proc godo {elt} {
6497 global curview
6499 set view [lindex $elt 0]
6500 set cmd [lindex $elt 1]
6501 if {$curview != $view} {
6502 showview $view
6504 eval $cmd
6507 proc goback {} {
6508 global history historyindex
6509 focus .
6511 if {$historyindex > 1} {
6512 incr historyindex -1
6513 godo [lindex $history [expr {$historyindex - 1}]]
6514 .tf.bar.rightbut conf -state normal
6516 if {$historyindex <= 1} {
6517 .tf.bar.leftbut conf -state disabled
6521 proc goforw {} {
6522 global history historyindex
6523 focus .
6525 if {$historyindex < [llength $history]} {
6526 set cmd [lindex $history $historyindex]
6527 incr historyindex
6528 godo $cmd
6529 .tf.bar.leftbut conf -state normal
6531 if {$historyindex >= [llength $history]} {
6532 .tf.bar.rightbut conf -state disabled
6536 proc gettree {id} {
6537 global treefilelist treeidlist diffids diffmergeid treepending
6538 global nullid nullid2
6540 set diffids $id
6541 catch {unset diffmergeid}
6542 if {![info exists treefilelist($id)]} {
6543 if {![info exists treepending]} {
6544 if {$id eq $nullid} {
6545 set cmd [list | git ls-files]
6546 } elseif {$id eq $nullid2} {
6547 set cmd [list | git ls-files --stage -t]
6548 } else {
6549 set cmd [list | git ls-tree -r $id]
6551 if {[catch {set gtf [open $cmd r]}]} {
6552 return
6554 set treepending $id
6555 set treefilelist($id) {}
6556 set treeidlist($id) {}
6557 fconfigure $gtf -blocking 0 -encoding binary
6558 filerun $gtf [list gettreeline $gtf $id]
6560 } else {
6561 setfilelist $id
6565 proc gettreeline {gtf id} {
6566 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6568 set nl 0
6569 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6570 if {$diffids eq $nullid} {
6571 set fname $line
6572 } else {
6573 set i [string first "\t" $line]
6574 if {$i < 0} continue
6575 set fname [string range $line [expr {$i+1}] end]
6576 set line [string range $line 0 [expr {$i-1}]]
6577 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6578 set sha1 [lindex $line 2]
6579 lappend treeidlist($id) $sha1
6581 if {[string index $fname 0] eq "\""} {
6582 set fname [lindex $fname 0]
6584 set fname [encoding convertfrom $fname]
6585 lappend treefilelist($id) $fname
6587 if {![eof $gtf]} {
6588 return [expr {$nl >= 1000? 2: 1}]
6590 close $gtf
6591 unset treepending
6592 if {$cmitmode ne "tree"} {
6593 if {![info exists diffmergeid]} {
6594 gettreediffs $diffids
6596 } elseif {$id ne $diffids} {
6597 gettree $diffids
6598 } else {
6599 setfilelist $id
6601 return 0
6604 proc showfile {f} {
6605 global treefilelist treeidlist diffids nullid nullid2
6606 global ctext_file_names ctext_file_lines
6607 global ctext commentend
6609 set i [lsearch -exact $treefilelist($diffids) $f]
6610 if {$i < 0} {
6611 puts "oops, $f not in list for id $diffids"
6612 return
6614 if {$diffids eq $nullid} {
6615 if {[catch {set bf [open $f r]} err]} {
6616 puts "oops, can't read $f: $err"
6617 return
6619 } else {
6620 set blob [lindex $treeidlist($diffids) $i]
6621 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6622 puts "oops, error reading blob $blob: $err"
6623 return
6626 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6627 filerun $bf [list getblobline $bf $diffids]
6628 $ctext config -state normal
6629 clear_ctext $commentend
6630 lappend ctext_file_names $f
6631 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6632 $ctext insert end "\n"
6633 $ctext insert end "$f\n" filesep
6634 $ctext config -state disabled
6635 $ctext yview $commentend
6636 settabs 0
6639 proc getblobline {bf id} {
6640 global diffids cmitmode ctext
6642 if {$id ne $diffids || $cmitmode ne "tree"} {
6643 catch {close $bf}
6644 return 0
6646 $ctext config -state normal
6647 set nl 0
6648 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6649 $ctext insert end "$line\n"
6651 if {[eof $bf]} {
6652 global jump_to_here ctext_file_names commentend
6654 # delete last newline
6655 $ctext delete "end - 2c" "end - 1c"
6656 close $bf
6657 if {$jump_to_here ne {} &&
6658 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6659 set lnum [expr {[lindex $jump_to_here 1] +
6660 [lindex [split $commentend .] 0]}]
6661 mark_ctext_line $lnum
6663 return 0
6665 $ctext config -state disabled
6666 return [expr {$nl >= 1000? 2: 1}]
6669 proc mark_ctext_line {lnum} {
6670 global ctext markbgcolor
6672 $ctext tag delete omark
6673 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6674 $ctext tag conf omark -background $markbgcolor
6675 $ctext see $lnum.0
6678 proc mergediff {id} {
6679 global diffmergeid mdifffd
6680 global diffids treediffs
6681 global parents
6682 global diffcontext
6683 global diffencoding
6684 global limitdiffs vfilelimit curview
6685 global targetline
6687 set diffmergeid $id
6688 set diffids $id
6689 set treediffs($id) {}
6690 set targetline {}
6691 # this doesn't seem to actually affect anything...
6692 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6693 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6694 set cmd [concat $cmd -- $vfilelimit($curview)]
6696 if {[catch {set mdf [open $cmd r]} err]} {
6697 error_popup "[mc "Error getting merge diffs:"] $err"
6698 return
6700 fconfigure $mdf -blocking 0 -encoding binary
6701 set mdifffd($id) $mdf
6702 set np [llength $parents($curview,$id)]
6703 set diffencoding [get_path_encoding {}]
6704 settabs $np
6705 filerun $mdf [list getmergediffline $mdf $id $np]
6708 proc getmergediffline {mdf id np} {
6709 global diffmergeid ctext cflist mergemax
6710 global difffilestart mdifffd treediffs
6711 global ctext_file_names ctext_file_lines
6712 global diffencoding jump_to_here targetline diffline
6714 $ctext conf -state normal
6715 set nr 0
6716 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6717 if {![info exists diffmergeid] || $id != $diffmergeid
6718 || $mdf != $mdifffd($id)} {
6719 close $mdf
6720 return 0
6722 if {[regexp {^diff --cc (.*)} $line match fname]} {
6723 # start of a new file
6724 set fname [encoding convertfrom $fname]
6725 $ctext insert end "\n"
6726 set here [$ctext index "end - 1c"]
6727 lappend difffilestart $here
6728 lappend treediffs($id) $fname
6729 add_flist [list $fname]
6730 lappend ctext_file_names $fname
6731 lappend ctext_file_lines [lindex [split $here "."] 0]
6732 set diffencoding [get_path_encoding $fname]
6733 set l [expr {(78 - [string length $fname]) / 2}]
6734 set pad [string range "----------------------------------------" 1 $l]
6735 $ctext insert end "$pad $fname $pad\n" filesep
6736 set targetline {}
6737 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
6738 set targetline [lindex $jump_to_here 1]
6740 set diffline 0
6741 } elseif {[regexp {^@@} $line]} {
6742 set line [encoding convertfrom $diffencoding $line]
6743 $ctext insert end "$line\n" hunksep
6744 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
6745 set diffline $nl
6747 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6748 # do nothing
6749 } else {
6750 set line [encoding convertfrom $diffencoding $line]
6751 # parse the prefix - one ' ', '-' or '+' for each parent
6752 set spaces {}
6753 set minuses {}
6754 set pluses {}
6755 set isbad 0
6756 for {set j 0} {$j < $np} {incr j} {
6757 set c [string range $line $j $j]
6758 if {$c == " "} {
6759 lappend spaces $j
6760 } elseif {$c == "-"} {
6761 lappend minuses $j
6762 } elseif {$c == "+"} {
6763 lappend pluses $j
6764 } else {
6765 set isbad 1
6766 break
6769 set tags {}
6770 set num {}
6771 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6772 # line doesn't appear in result, parents in $minuses have the line
6773 set num [lindex $minuses 0]
6774 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6775 # line appears in result, parents in $pluses don't have the line
6776 lappend tags mresult
6777 set num [lindex $spaces 0]
6779 if {$num ne {}} {
6780 if {$num >= $mergemax} {
6781 set num "max"
6783 lappend tags m$num
6785 $ctext insert end "$line\n" $tags
6786 if {$targetline ne {} && $minuses eq {}} {
6787 if {$diffline == $targetline} {
6788 set here [$ctext index "end - 1 line"]
6789 mark_ctext_line [lindex [split $here .] 0]
6790 set targetline {}
6791 } else {
6792 incr diffline
6797 $ctext conf -state disabled
6798 if {[eof $mdf]} {
6799 close $mdf
6800 return 0
6802 return [expr {$nr >= 1000? 2: 1}]
6805 proc startdiff {ids} {
6806 global treediffs diffids treepending diffmergeid nullid nullid2
6808 settabs 1
6809 set diffids $ids
6810 catch {unset diffmergeid}
6811 if {![info exists treediffs($ids)] ||
6812 [lsearch -exact $ids $nullid] >= 0 ||
6813 [lsearch -exact $ids $nullid2] >= 0} {
6814 if {![info exists treepending]} {
6815 gettreediffs $ids
6817 } else {
6818 addtocflist $ids
6822 proc path_filter {filter name} {
6823 foreach p $filter {
6824 set l [string length $p]
6825 if {[string index $p end] eq "/"} {
6826 if {[string compare -length $l $p $name] == 0} {
6827 return 1
6829 } else {
6830 if {[string compare -length $l $p $name] == 0 &&
6831 ([string length $name] == $l ||
6832 [string index $name $l] eq "/")} {
6833 return 1
6837 return 0
6840 proc addtocflist {ids} {
6841 global treediffs
6843 add_flist $treediffs($ids)
6844 getblobdiffs $ids
6847 proc diffcmd {ids flags} {
6848 global nullid nullid2
6850 set i [lsearch -exact $ids $nullid]
6851 set j [lsearch -exact $ids $nullid2]
6852 if {$i >= 0} {
6853 if {[llength $ids] > 1 && $j < 0} {
6854 # comparing working directory with some specific revision
6855 set cmd [concat | git diff-index $flags]
6856 if {$i == 0} {
6857 lappend cmd -R [lindex $ids 1]
6858 } else {
6859 lappend cmd [lindex $ids 0]
6861 } else {
6862 # comparing working directory with index
6863 set cmd [concat | git diff-files $flags]
6864 if {$j == 1} {
6865 lappend cmd -R
6868 } elseif {$j >= 0} {
6869 set cmd [concat | git diff-index --cached $flags]
6870 if {[llength $ids] > 1} {
6871 # comparing index with specific revision
6872 if {$i == 0} {
6873 lappend cmd -R [lindex $ids 1]
6874 } else {
6875 lappend cmd [lindex $ids 0]
6877 } else {
6878 # comparing index with HEAD
6879 lappend cmd HEAD
6881 } else {
6882 set cmd [concat | git diff-tree -r $flags $ids]
6884 return $cmd
6887 proc gettreediffs {ids} {
6888 global treediff treepending
6890 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6892 set treepending $ids
6893 set treediff {}
6894 fconfigure $gdtf -blocking 0 -encoding binary
6895 filerun $gdtf [list gettreediffline $gdtf $ids]
6898 proc gettreediffline {gdtf ids} {
6899 global treediff treediffs treepending diffids diffmergeid
6900 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6902 set nr 0
6903 set sublist {}
6904 set max 1000
6905 if {$perfile_attrs} {
6906 # cache_gitattr is slow, and even slower on win32 where we
6907 # have to invoke it for only about 30 paths at a time
6908 set max 500
6909 if {[tk windowingsystem] == "win32"} {
6910 set max 120
6913 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6914 set i [string first "\t" $line]
6915 if {$i >= 0} {
6916 set file [string range $line [expr {$i+1}] end]
6917 if {[string index $file 0] eq "\""} {
6918 set file [lindex $file 0]
6920 set file [encoding convertfrom $file]
6921 lappend treediff $file
6922 lappend sublist $file
6925 if {$perfile_attrs} {
6926 cache_gitattr encoding $sublist
6928 if {![eof $gdtf]} {
6929 return [expr {$nr >= $max? 2: 1}]
6931 close $gdtf
6932 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6933 set flist {}
6934 foreach f $treediff {
6935 if {[path_filter $vfilelimit($curview) $f]} {
6936 lappend flist $f
6939 set treediffs($ids) $flist
6940 } else {
6941 set treediffs($ids) $treediff
6943 unset treepending
6944 if {$cmitmode eq "tree"} {
6945 gettree $diffids
6946 } elseif {$ids != $diffids} {
6947 if {![info exists diffmergeid]} {
6948 gettreediffs $diffids
6950 } else {
6951 addtocflist $ids
6953 return 0
6956 # empty string or positive integer
6957 proc diffcontextvalidate {v} {
6958 return [regexp {^(|[1-9][0-9]*)$} $v]
6961 proc diffcontextchange {n1 n2 op} {
6962 global diffcontextstring diffcontext
6964 if {[string is integer -strict $diffcontextstring]} {
6965 if {$diffcontextstring > 0} {
6966 set diffcontext $diffcontextstring
6967 reselectline
6972 proc changeignorespace {} {
6973 reselectline
6976 proc getblobdiffs {ids} {
6977 global blobdifffd diffids env
6978 global diffinhdr treediffs
6979 global diffcontext
6980 global ignorespace
6981 global limitdiffs vfilelimit curview
6982 global diffencoding targetline
6984 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6985 if {$ignorespace} {
6986 append cmd " -w"
6988 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6989 set cmd [concat $cmd -- $vfilelimit($curview)]
6991 if {[catch {set bdf [open $cmd r]} err]} {
6992 puts "error getting diffs: $err"
6993 return
6995 set targetline {}
6996 set diffinhdr 0
6997 set diffencoding [get_path_encoding {}]
6998 fconfigure $bdf -blocking 0 -encoding binary
6999 set blobdifffd($ids) $bdf
7000 filerun $bdf [list getblobdiffline $bdf $diffids]
7003 proc setinlist {var i val} {
7004 global $var
7006 while {[llength [set $var]] < $i} {
7007 lappend $var {}
7009 if {[llength [set $var]] == $i} {
7010 lappend $var $val
7011 } else {
7012 lset $var $i $val
7016 proc makediffhdr {fname ids} {
7017 global ctext curdiffstart treediffs
7018 global ctext_file_names jump_to_here targetline diffline
7020 set i [lsearch -exact $treediffs($ids) $fname]
7021 if {$i >= 0} {
7022 setinlist difffilestart $i $curdiffstart
7024 set ctext_file_names [lreplace $ctext_file_names end end $fname]
7025 set l [expr {(78 - [string length $fname]) / 2}]
7026 set pad [string range "----------------------------------------" 1 $l]
7027 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7028 set targetline {}
7029 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7030 set targetline [lindex $jump_to_here 1]
7032 set diffline 0
7035 proc getblobdiffline {bdf ids} {
7036 global diffids blobdifffd ctext curdiffstart
7037 global diffnexthead diffnextnote difffilestart
7038 global ctext_file_names ctext_file_lines
7039 global diffinhdr treediffs
7040 global diffencoding jump_to_here targetline diffline
7042 set nr 0
7043 $ctext conf -state normal
7044 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7045 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7046 close $bdf
7047 return 0
7049 if {![string compare -length 11 "diff --git " $line]} {
7050 # trim off "diff --git "
7051 set line [string range $line 11 end]
7052 set diffinhdr 1
7053 # start of a new file
7054 $ctext insert end "\n"
7055 set curdiffstart [$ctext index "end - 1c"]
7056 lappend ctext_file_names ""
7057 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7058 $ctext insert end "\n" filesep
7059 # If the name hasn't changed the length will be odd,
7060 # the middle char will be a space, and the two bits either
7061 # side will be a/name and b/name, or "a/name" and "b/name".
7062 # If the name has changed we'll get "rename from" and
7063 # "rename to" or "copy from" and "copy to" lines following this,
7064 # and we'll use them to get the filenames.
7065 # This complexity is necessary because spaces in the filename(s)
7066 # don't get escaped.
7067 set l [string length $line]
7068 set i [expr {$l / 2}]
7069 if {!(($l & 1) && [string index $line $i] eq " " &&
7070 [string range $line 2 [expr {$i - 1}]] eq \
7071 [string range $line [expr {$i + 3}] end])} {
7072 continue
7074 # unescape if quoted and chop off the a/ from the front
7075 if {[string index $line 0] eq "\""} {
7076 set fname [string range [lindex $line 0] 2 end]
7077 } else {
7078 set fname [string range $line 2 [expr {$i - 1}]]
7080 set fname [encoding convertfrom $fname]
7081 set diffencoding [get_path_encoding $fname]
7082 makediffhdr $fname $ids
7084 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
7085 $line match f1l f1c f2l f2c rest]} {
7086 set line [encoding convertfrom $diffencoding $line]
7087 $ctext insert end "$line\n" hunksep
7088 set diffinhdr 0
7089 set diffline $f2l
7091 } elseif {$diffinhdr} {
7092 if {![string compare -length 12 "rename from " $line]} {
7093 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7094 if {[string index $fname 0] eq "\""} {
7095 set fname [lindex $fname 0]
7097 set fname [encoding convertfrom $fname]
7098 set i [lsearch -exact $treediffs($ids) $fname]
7099 if {$i >= 0} {
7100 setinlist difffilestart $i $curdiffstart
7102 } elseif {![string compare -length 10 $line "rename to "] ||
7103 ![string compare -length 8 $line "copy to "]} {
7104 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7105 if {[string index $fname 0] eq "\""} {
7106 set fname [lindex $fname 0]
7108 set fname [encoding convertfrom $fname]
7109 set diffencoding [get_path_encoding $fname]
7110 makediffhdr $fname $ids
7111 } elseif {[string compare -length 3 $line "---"] == 0} {
7112 # do nothing
7113 continue
7114 } elseif {[string compare -length 3 $line "+++"] == 0} {
7115 set diffinhdr 0
7116 continue
7118 $ctext insert end "$line\n" filesep
7120 } else {
7121 set line [encoding convertfrom $diffencoding $line]
7122 set x [string range $line 0 0]
7123 set here [$ctext index "end - 1 chars"]
7124 if {$x == "-" || $x == "+"} {
7125 set tag [expr {$x == "+"}]
7126 $ctext insert end "$line\n" d$tag
7127 } elseif {$x == " "} {
7128 $ctext insert end "$line\n"
7129 } else {
7130 # "\ No newline at end of file",
7131 # or something else we don't recognize
7132 $ctext insert end "$line\n" hunksep
7134 if {$targetline ne {} && ($x eq " " || $x eq "+")} {
7135 if {$diffline == $targetline} {
7136 mark_ctext_line [lindex [split $here .] 0]
7137 set targetline {}
7138 } else {
7139 incr diffline
7144 $ctext conf -state disabled
7145 if {[eof $bdf]} {
7146 close $bdf
7147 return 0
7149 return [expr {$nr >= 1000? 2: 1}]
7152 proc changediffdisp {} {
7153 global ctext diffelide
7155 $ctext tag conf d0 -elide [lindex $diffelide 0]
7156 $ctext tag conf d1 -elide [lindex $diffelide 1]
7159 proc highlightfile {loc cline} {
7160 global ctext cflist cflist_top
7162 $ctext yview $loc
7163 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7164 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7165 $cflist see $cline.0
7166 set cflist_top $cline
7169 proc prevfile {} {
7170 global difffilestart ctext cmitmode
7172 if {$cmitmode eq "tree"} return
7173 set prev 0.0
7174 set prevline 1
7175 set here [$ctext index @0,0]
7176 foreach loc $difffilestart {
7177 if {[$ctext compare $loc >= $here]} {
7178 highlightfile $prev $prevline
7179 return
7181 set prev $loc
7182 incr prevline
7184 highlightfile $prev $prevline
7187 proc nextfile {} {
7188 global difffilestart ctext cmitmode
7190 if {$cmitmode eq "tree"} return
7191 set here [$ctext index @0,0]
7192 set line 1
7193 foreach loc $difffilestart {
7194 incr line
7195 if {[$ctext compare $loc > $here]} {
7196 highlightfile $loc $line
7197 return
7202 proc clear_ctext {{first 1.0}} {
7203 global ctext smarktop smarkbot
7204 global ctext_file_names ctext_file_lines
7205 global pendinglinks
7207 set l [lindex [split $first .] 0]
7208 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7209 set smarktop $l
7211 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7212 set smarkbot $l
7214 $ctext delete $first end
7215 if {$first eq "1.0"} {
7216 catch {unset pendinglinks}
7218 set ctext_file_names {}
7219 set ctext_file_lines {}
7222 proc settabs {{firstab {}}} {
7223 global firsttabstop tabstop ctext have_tk85
7225 if {$firstab ne {} && $have_tk85} {
7226 set firsttabstop $firstab
7228 set w [font measure textfont "0"]
7229 if {$firsttabstop != 0} {
7230 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7231 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7232 } elseif {$have_tk85 || $tabstop != 8} {
7233 $ctext conf -tabs [expr {$tabstop * $w}]
7234 } else {
7235 $ctext conf -tabs {}
7239 proc incrsearch {name ix op} {
7240 global ctext searchstring searchdirn
7242 $ctext tag remove found 1.0 end
7243 if {[catch {$ctext index anchor}]} {
7244 # no anchor set, use start of selection, or of visible area
7245 set sel [$ctext tag ranges sel]
7246 if {$sel ne {}} {
7247 $ctext mark set anchor [lindex $sel 0]
7248 } elseif {$searchdirn eq "-forwards"} {
7249 $ctext mark set anchor @0,0
7250 } else {
7251 $ctext mark set anchor @0,[winfo height $ctext]
7254 if {$searchstring ne {}} {
7255 set here [$ctext search $searchdirn -- $searchstring anchor]
7256 if {$here ne {}} {
7257 $ctext see $here
7259 searchmarkvisible 1
7263 proc dosearch {} {
7264 global sstring ctext searchstring searchdirn
7266 focus $sstring
7267 $sstring icursor end
7268 set searchdirn -forwards
7269 if {$searchstring ne {}} {
7270 set sel [$ctext tag ranges sel]
7271 if {$sel ne {}} {
7272 set start "[lindex $sel 0] + 1c"
7273 } elseif {[catch {set start [$ctext index anchor]}]} {
7274 set start "@0,0"
7276 set match [$ctext search -count mlen -- $searchstring $start]
7277 $ctext tag remove sel 1.0 end
7278 if {$match eq {}} {
7279 bell
7280 return
7282 $ctext see $match
7283 set mend "$match + $mlen c"
7284 $ctext tag add sel $match $mend
7285 $ctext mark unset anchor
7289 proc dosearchback {} {
7290 global sstring ctext searchstring searchdirn
7292 focus $sstring
7293 $sstring icursor end
7294 set searchdirn -backwards
7295 if {$searchstring ne {}} {
7296 set sel [$ctext tag ranges sel]
7297 if {$sel ne {}} {
7298 set start [lindex $sel 0]
7299 } elseif {[catch {set start [$ctext index anchor]}]} {
7300 set start @0,[winfo height $ctext]
7302 set match [$ctext search -backwards -count ml -- $searchstring $start]
7303 $ctext tag remove sel 1.0 end
7304 if {$match eq {}} {
7305 bell
7306 return
7308 $ctext see $match
7309 set mend "$match + $ml c"
7310 $ctext tag add sel $match $mend
7311 $ctext mark unset anchor
7315 proc searchmark {first last} {
7316 global ctext searchstring
7318 set mend $first.0
7319 while {1} {
7320 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7321 if {$match eq {}} break
7322 set mend "$match + $mlen c"
7323 $ctext tag add found $match $mend
7327 proc searchmarkvisible {doall} {
7328 global ctext smarktop smarkbot
7330 set topline [lindex [split [$ctext index @0,0] .] 0]
7331 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7332 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7333 # no overlap with previous
7334 searchmark $topline $botline
7335 set smarktop $topline
7336 set smarkbot $botline
7337 } else {
7338 if {$topline < $smarktop} {
7339 searchmark $topline [expr {$smarktop-1}]
7340 set smarktop $topline
7342 if {$botline > $smarkbot} {
7343 searchmark [expr {$smarkbot+1}] $botline
7344 set smarkbot $botline
7349 proc scrolltext {f0 f1} {
7350 global searchstring
7352 .bleft.bottom.sb set $f0 $f1
7353 if {$searchstring ne {}} {
7354 searchmarkvisible 0
7358 proc setcoords {} {
7359 global linespc charspc canvx0 canvy0
7360 global xspc1 xspc2 lthickness
7362 set linespc [font metrics mainfont -linespace]
7363 set charspc [font measure mainfont "m"]
7364 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7365 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7366 set lthickness [expr {int($linespc / 9) + 1}]
7367 set xspc1(0) $linespc
7368 set xspc2 $linespc
7371 proc redisplay {} {
7372 global canv
7373 global selectedline
7375 set ymax [lindex [$canv cget -scrollregion] 3]
7376 if {$ymax eq {} || $ymax == 0} return
7377 set span [$canv yview]
7378 clear_display
7379 setcanvscroll
7380 allcanvs yview moveto [lindex $span 0]
7381 drawvisible
7382 if {$selectedline ne {}} {
7383 selectline $selectedline 0
7384 allcanvs yview moveto [lindex $span 0]
7388 proc parsefont {f n} {
7389 global fontattr
7391 set fontattr($f,family) [lindex $n 0]
7392 set s [lindex $n 1]
7393 if {$s eq {} || $s == 0} {
7394 set s 10
7395 } elseif {$s < 0} {
7396 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7398 set fontattr($f,size) $s
7399 set fontattr($f,weight) normal
7400 set fontattr($f,slant) roman
7401 foreach style [lrange $n 2 end] {
7402 switch -- $style {
7403 "normal" -
7404 "bold" {set fontattr($f,weight) $style}
7405 "roman" -
7406 "italic" {set fontattr($f,slant) $style}
7411 proc fontflags {f {isbold 0}} {
7412 global fontattr
7414 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7415 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7416 -slant $fontattr($f,slant)]
7419 proc fontname {f} {
7420 global fontattr
7422 set n [list $fontattr($f,family) $fontattr($f,size)]
7423 if {$fontattr($f,weight) eq "bold"} {
7424 lappend n "bold"
7426 if {$fontattr($f,slant) eq "italic"} {
7427 lappend n "italic"
7429 return $n
7432 proc incrfont {inc} {
7433 global mainfont textfont ctext canv cflist showrefstop
7434 global stopped entries fontattr
7436 unmarkmatches
7437 set s $fontattr(mainfont,size)
7438 incr s $inc
7439 if {$s < 1} {
7440 set s 1
7442 set fontattr(mainfont,size) $s
7443 font config mainfont -size $s
7444 font config mainfontbold -size $s
7445 set mainfont [fontname mainfont]
7446 set s $fontattr(textfont,size)
7447 incr s $inc
7448 if {$s < 1} {
7449 set s 1
7451 set fontattr(textfont,size) $s
7452 font config textfont -size $s
7453 font config textfontbold -size $s
7454 set textfont [fontname textfont]
7455 setcoords
7456 settabs
7457 redisplay
7460 proc clearsha1 {} {
7461 global sha1entry sha1string
7462 if {[string length $sha1string] == 40} {
7463 $sha1entry delete 0 end
7467 proc sha1change {n1 n2 op} {
7468 global sha1string currentid sha1but
7469 if {$sha1string == {}
7470 || ([info exists currentid] && $sha1string == $currentid)} {
7471 set state disabled
7472 } else {
7473 set state normal
7475 if {[$sha1but cget -state] == $state} return
7476 if {$state == "normal"} {
7477 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7478 } else {
7479 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7483 proc gotocommit {} {
7484 global sha1string tagids headids curview varcid
7486 if {$sha1string == {}
7487 || ([info exists currentid] && $sha1string == $currentid)} return
7488 if {[info exists tagids($sha1string)]} {
7489 set id $tagids($sha1string)
7490 } elseif {[info exists headids($sha1string)]} {
7491 set id $headids($sha1string)
7492 } else {
7493 set id [string tolower $sha1string]
7494 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7495 set matches [longid $id]
7496 if {$matches ne {}} {
7497 if {[llength $matches] > 1} {
7498 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7499 return
7501 set id [lindex $matches 0]
7505 if {[commitinview $id $curview]} {
7506 selectline [rowofcommit $id] 1
7507 return
7509 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7510 set msg [mc "SHA1 id %s is not known" $sha1string]
7511 } else {
7512 set msg [mc "Tag/Head %s is not known" $sha1string]
7514 error_popup $msg
7517 proc lineenter {x y id} {
7518 global hoverx hovery hoverid hovertimer
7519 global commitinfo canv
7521 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7522 set hoverx $x
7523 set hovery $y
7524 set hoverid $id
7525 if {[info exists hovertimer]} {
7526 after cancel $hovertimer
7528 set hovertimer [after 500 linehover]
7529 $canv delete hover
7532 proc linemotion {x y id} {
7533 global hoverx hovery hoverid hovertimer
7535 if {[info exists hoverid] && $id == $hoverid} {
7536 set hoverx $x
7537 set hovery $y
7538 if {[info exists hovertimer]} {
7539 after cancel $hovertimer
7541 set hovertimer [after 500 linehover]
7545 proc lineleave {id} {
7546 global hoverid hovertimer canv
7548 if {[info exists hoverid] && $id == $hoverid} {
7549 $canv delete hover
7550 if {[info exists hovertimer]} {
7551 after cancel $hovertimer
7552 unset hovertimer
7554 unset hoverid
7558 proc linehover {} {
7559 global hoverx hovery hoverid hovertimer
7560 global canv linespc lthickness
7561 global commitinfo
7563 set text [lindex $commitinfo($hoverid) 0]
7564 set ymax [lindex [$canv cget -scrollregion] 3]
7565 if {$ymax == {}} return
7566 set yfrac [lindex [$canv yview] 0]
7567 set x [expr {$hoverx + 2 * $linespc}]
7568 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7569 set x0 [expr {$x - 2 * $lthickness}]
7570 set y0 [expr {$y - 2 * $lthickness}]
7571 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7572 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7573 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7574 -fill \#ffff80 -outline black -width 1 -tags hover]
7575 $canv raise $t
7576 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7577 -font mainfont]
7578 $canv raise $t
7581 proc clickisonarrow {id y} {
7582 global lthickness
7584 set ranges [rowranges $id]
7585 set thresh [expr {2 * $lthickness + 6}]
7586 set n [expr {[llength $ranges] - 1}]
7587 for {set i 1} {$i < $n} {incr i} {
7588 set row [lindex $ranges $i]
7589 if {abs([yc $row] - $y) < $thresh} {
7590 return $i
7593 return {}
7596 proc arrowjump {id n y} {
7597 global canv
7599 # 1 <-> 2, 3 <-> 4, etc...
7600 set n [expr {(($n - 1) ^ 1) + 1}]
7601 set row [lindex [rowranges $id] $n]
7602 set yt [yc $row]
7603 set ymax [lindex [$canv cget -scrollregion] 3]
7604 if {$ymax eq {} || $ymax <= 0} return
7605 set view [$canv yview]
7606 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7607 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7608 if {$yfrac < 0} {
7609 set yfrac 0
7611 allcanvs yview moveto $yfrac
7614 proc lineclick {x y id isnew} {
7615 global ctext commitinfo children canv thickerline curview
7617 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7618 unmarkmatches
7619 unselectline
7620 normalline
7621 $canv delete hover
7622 # draw this line thicker than normal
7623 set thickerline $id
7624 drawlines $id
7625 if {$isnew} {
7626 set ymax [lindex [$canv cget -scrollregion] 3]
7627 if {$ymax eq {}} return
7628 set yfrac [lindex [$canv yview] 0]
7629 set y [expr {$y + $yfrac * $ymax}]
7631 set dirn [clickisonarrow $id $y]
7632 if {$dirn ne {}} {
7633 arrowjump $id $dirn $y
7634 return
7637 if {$isnew} {
7638 addtohistory [list lineclick $x $y $id 0]
7640 # fill the details pane with info about this line
7641 $ctext conf -state normal
7642 clear_ctext
7643 settabs 0
7644 $ctext insert end "[mc "Parent"]:\t"
7645 $ctext insert end $id link0
7646 setlink $id link0
7647 set info $commitinfo($id)
7648 $ctext insert end "\n\t[lindex $info 0]\n"
7649 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7650 set date [formatdate [lindex $info 2]]
7651 $ctext insert end "\t[mc "Date"]:\t$date\n"
7652 set kids $children($curview,$id)
7653 if {$kids ne {}} {
7654 $ctext insert end "\n[mc "Children"]:"
7655 set i 0
7656 foreach child $kids {
7657 incr i
7658 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7659 set info $commitinfo($child)
7660 $ctext insert end "\n\t"
7661 $ctext insert end $child link$i
7662 setlink $child link$i
7663 $ctext insert end "\n\t[lindex $info 0]"
7664 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7665 set date [formatdate [lindex $info 2]]
7666 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7669 $ctext conf -state disabled
7670 init_flist {}
7673 proc normalline {} {
7674 global thickerline
7675 if {[info exists thickerline]} {
7676 set id $thickerline
7677 unset thickerline
7678 drawlines $id
7682 proc selbyid {id} {
7683 global curview
7684 if {[commitinview $id $curview]} {
7685 selectline [rowofcommit $id] 1
7689 proc mstime {} {
7690 global startmstime
7691 if {![info exists startmstime]} {
7692 set startmstime [clock clicks -milliseconds]
7694 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7697 proc rowmenu {x y id} {
7698 global rowctxmenu selectedline rowmenuid curview
7699 global nullid nullid2 fakerowmenu mainhead
7701 stopfinding
7702 set rowmenuid $id
7703 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7704 set state disabled
7705 } else {
7706 set state normal
7708 if {$id ne $nullid && $id ne $nullid2} {
7709 set menu $rowctxmenu
7710 if {$mainhead ne {}} {
7711 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7712 } else {
7713 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7715 } else {
7716 set menu $fakerowmenu
7718 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7719 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7720 $menu entryconfigure [mca "Make patch"] -state $state
7721 tk_popup $menu $x $y
7724 proc diffvssel {dirn} {
7725 global rowmenuid selectedline
7727 if {$selectedline eq {}} return
7728 if {$dirn} {
7729 set oldid [commitonrow $selectedline]
7730 set newid $rowmenuid
7731 } else {
7732 set oldid $rowmenuid
7733 set newid [commitonrow $selectedline]
7735 addtohistory [list doseldiff $oldid $newid]
7736 doseldiff $oldid $newid
7739 proc doseldiff {oldid newid} {
7740 global ctext
7741 global commitinfo
7743 $ctext conf -state normal
7744 clear_ctext
7745 init_flist [mc "Top"]
7746 $ctext insert end "[mc "From"] "
7747 $ctext insert end $oldid link0
7748 setlink $oldid link0
7749 $ctext insert end "\n "
7750 $ctext insert end [lindex $commitinfo($oldid) 0]
7751 $ctext insert end "\n\n[mc "To"] "
7752 $ctext insert end $newid link1
7753 setlink $newid link1
7754 $ctext insert end "\n "
7755 $ctext insert end [lindex $commitinfo($newid) 0]
7756 $ctext insert end "\n"
7757 $ctext conf -state disabled
7758 $ctext tag remove found 1.0 end
7759 startdiff [list $oldid $newid]
7762 proc mkpatch {} {
7763 global rowmenuid currentid commitinfo patchtop patchnum
7765 if {![info exists currentid]} return
7766 set oldid $currentid
7767 set oldhead [lindex $commitinfo($oldid) 0]
7768 set newid $rowmenuid
7769 set newhead [lindex $commitinfo($newid) 0]
7770 set top .patch
7771 set patchtop $top
7772 catch {destroy $top}
7773 toplevel $top
7774 wm transient $top .
7775 label $top.title -text [mc "Generate patch"]
7776 grid $top.title - -pady 10
7777 label $top.from -text [mc "From:"]
7778 entry $top.fromsha1 -width 40 -relief flat
7779 $top.fromsha1 insert 0 $oldid
7780 $top.fromsha1 conf -state readonly
7781 grid $top.from $top.fromsha1 -sticky w
7782 entry $top.fromhead -width 60 -relief flat
7783 $top.fromhead insert 0 $oldhead
7784 $top.fromhead conf -state readonly
7785 grid x $top.fromhead -sticky w
7786 label $top.to -text [mc "To:"]
7787 entry $top.tosha1 -width 40 -relief flat
7788 $top.tosha1 insert 0 $newid
7789 $top.tosha1 conf -state readonly
7790 grid $top.to $top.tosha1 -sticky w
7791 entry $top.tohead -width 60 -relief flat
7792 $top.tohead insert 0 $newhead
7793 $top.tohead conf -state readonly
7794 grid x $top.tohead -sticky w
7795 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7796 grid $top.rev x -pady 10
7797 label $top.flab -text [mc "Output file:"]
7798 entry $top.fname -width 60
7799 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7800 incr patchnum
7801 grid $top.flab $top.fname -sticky w
7802 frame $top.buts
7803 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7804 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7805 bind $top <Key-Return> mkpatchgo
7806 bind $top <Key-Escape> mkpatchcan
7807 grid $top.buts.gen $top.buts.can
7808 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7809 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7810 grid $top.buts - -pady 10 -sticky ew
7811 focus $top.fname
7814 proc mkpatchrev {} {
7815 global patchtop
7817 set oldid [$patchtop.fromsha1 get]
7818 set oldhead [$patchtop.fromhead get]
7819 set newid [$patchtop.tosha1 get]
7820 set newhead [$patchtop.tohead get]
7821 foreach e [list fromsha1 fromhead tosha1 tohead] \
7822 v [list $newid $newhead $oldid $oldhead] {
7823 $patchtop.$e conf -state normal
7824 $patchtop.$e delete 0 end
7825 $patchtop.$e insert 0 $v
7826 $patchtop.$e conf -state readonly
7830 proc mkpatchgo {} {
7831 global patchtop nullid nullid2
7833 set oldid [$patchtop.fromsha1 get]
7834 set newid [$patchtop.tosha1 get]
7835 set fname [$patchtop.fname get]
7836 set cmd [diffcmd [list $oldid $newid] -p]
7837 # trim off the initial "|"
7838 set cmd [lrange $cmd 1 end]
7839 lappend cmd >$fname &
7840 if {[catch {eval exec $cmd} err]} {
7841 error_popup "[mc "Error creating patch:"] $err" $patchtop
7843 catch {destroy $patchtop}
7844 unset patchtop
7847 proc mkpatchcan {} {
7848 global patchtop
7850 catch {destroy $patchtop}
7851 unset patchtop
7854 proc mktag {} {
7855 global rowmenuid mktagtop commitinfo
7857 set top .maketag
7858 set mktagtop $top
7859 catch {destroy $top}
7860 toplevel $top
7861 wm transient $top .
7862 label $top.title -text [mc "Create tag"]
7863 grid $top.title - -pady 10
7864 label $top.id -text [mc "ID:"]
7865 entry $top.sha1 -width 40 -relief flat
7866 $top.sha1 insert 0 $rowmenuid
7867 $top.sha1 conf -state readonly
7868 grid $top.id $top.sha1 -sticky w
7869 entry $top.head -width 60 -relief flat
7870 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7871 $top.head conf -state readonly
7872 grid x $top.head -sticky w
7873 label $top.tlab -text [mc "Tag name:"]
7874 entry $top.tag -width 60
7875 grid $top.tlab $top.tag -sticky w
7876 frame $top.buts
7877 button $top.buts.gen -text [mc "Create"] -command mktaggo
7878 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7879 bind $top <Key-Return> mktaggo
7880 bind $top <Key-Escape> mktagcan
7881 grid $top.buts.gen $top.buts.can
7882 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7883 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7884 grid $top.buts - -pady 10 -sticky ew
7885 focus $top.tag
7888 proc domktag {} {
7889 global mktagtop env tagids idtags
7891 set id [$mktagtop.sha1 get]
7892 set tag [$mktagtop.tag get]
7893 if {$tag == {}} {
7894 error_popup [mc "No tag name specified"] $mktagtop
7895 return 0
7897 if {[info exists tagids($tag)]} {
7898 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
7899 return 0
7901 if {[catch {
7902 exec git tag $tag $id
7903 } err]} {
7904 error_popup "[mc "Error creating tag:"] $err" $mktagtop
7905 return 0
7908 set tagids($tag) $id
7909 lappend idtags($id) $tag
7910 redrawtags $id
7911 addedtag $id
7912 dispneartags 0
7913 run refill_reflist
7914 return 1
7917 proc redrawtags {id} {
7918 global canv linehtag idpos currentid curview cmitlisted
7919 global canvxmax iddrawn circleitem mainheadid circlecolors
7921 if {![commitinview $id $curview]} return
7922 if {![info exists iddrawn($id)]} return
7923 set row [rowofcommit $id]
7924 if {$id eq $mainheadid} {
7925 set ofill yellow
7926 } else {
7927 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7929 $canv itemconf $circleitem($row) -fill $ofill
7930 $canv delete tag.$id
7931 set xt [eval drawtags $id $idpos($id)]
7932 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7933 set text [$canv itemcget $linehtag($row) -text]
7934 set font [$canv itemcget $linehtag($row) -font]
7935 set xr [expr {$xt + [font measure $font $text]}]
7936 if {$xr > $canvxmax} {
7937 set canvxmax $xr
7938 setcanvscroll
7940 if {[info exists currentid] && $currentid == $id} {
7941 make_secsel $row
7945 proc mktagcan {} {
7946 global mktagtop
7948 catch {destroy $mktagtop}
7949 unset mktagtop
7952 proc mktaggo {} {
7953 if {![domktag]} return
7954 mktagcan
7957 proc writecommit {} {
7958 global rowmenuid wrcomtop commitinfo wrcomcmd
7960 set top .writecommit
7961 set wrcomtop $top
7962 catch {destroy $top}
7963 toplevel $top
7964 wm transient $top .
7965 label $top.title -text [mc "Write commit to file"]
7966 grid $top.title - -pady 10
7967 label $top.id -text [mc "ID:"]
7968 entry $top.sha1 -width 40 -relief flat
7969 $top.sha1 insert 0 $rowmenuid
7970 $top.sha1 conf -state readonly
7971 grid $top.id $top.sha1 -sticky w
7972 entry $top.head -width 60 -relief flat
7973 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7974 $top.head conf -state readonly
7975 grid x $top.head -sticky w
7976 label $top.clab -text [mc "Command:"]
7977 entry $top.cmd -width 60 -textvariable wrcomcmd
7978 grid $top.clab $top.cmd -sticky w -pady 10
7979 label $top.flab -text [mc "Output file:"]
7980 entry $top.fname -width 60
7981 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7982 grid $top.flab $top.fname -sticky w
7983 frame $top.buts
7984 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7985 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7986 bind $top <Key-Return> wrcomgo
7987 bind $top <Key-Escape> wrcomcan
7988 grid $top.buts.gen $top.buts.can
7989 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7990 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7991 grid $top.buts - -pady 10 -sticky ew
7992 focus $top.fname
7995 proc wrcomgo {} {
7996 global wrcomtop
7998 set id [$wrcomtop.sha1 get]
7999 set cmd "echo $id | [$wrcomtop.cmd get]"
8000 set fname [$wrcomtop.fname get]
8001 if {[catch {exec sh -c $cmd >$fname &} err]} {
8002 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8004 catch {destroy $wrcomtop}
8005 unset wrcomtop
8008 proc wrcomcan {} {
8009 global wrcomtop
8011 catch {destroy $wrcomtop}
8012 unset wrcomtop
8015 proc mkbranch {} {
8016 global rowmenuid mkbrtop
8018 set top .makebranch
8019 catch {destroy $top}
8020 toplevel $top
8021 wm transient $top .
8022 label $top.title -text [mc "Create new branch"]
8023 grid $top.title - -pady 10
8024 label $top.id -text [mc "ID:"]
8025 entry $top.sha1 -width 40 -relief flat
8026 $top.sha1 insert 0 $rowmenuid
8027 $top.sha1 conf -state readonly
8028 grid $top.id $top.sha1 -sticky w
8029 label $top.nlab -text [mc "Name:"]
8030 entry $top.name -width 40
8031 bind $top.name <Key-Return> "[list mkbrgo $top]"
8032 grid $top.nlab $top.name -sticky w
8033 frame $top.buts
8034 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8035 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8036 bind $top <Key-Return> [list mkbrgo $top]
8037 bind $top <Key-Escape> "catch {destroy $top}"
8038 grid $top.buts.go $top.buts.can
8039 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8040 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8041 grid $top.buts - -pady 10 -sticky ew
8042 focus $top.name
8045 proc mkbrgo {top} {
8046 global headids idheads
8048 set name [$top.name get]
8049 set id [$top.sha1 get]
8050 set cmdargs {}
8051 set old_id {}
8052 if {$name eq {}} {
8053 error_popup [mc "Please specify a name for the new branch"] $top
8054 return
8056 if {[info exists headids($name)]} {
8057 if {![confirm_popup [mc \
8058 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8059 return
8061 set old_id $headids($name)
8062 lappend cmdargs -f
8064 catch {destroy $top}
8065 lappend cmdargs $name $id
8066 nowbusy newbranch
8067 update
8068 if {[catch {
8069 eval exec git branch $cmdargs
8070 } err]} {
8071 notbusy newbranch
8072 error_popup $err
8073 } else {
8074 notbusy newbranch
8075 if {$old_id ne {}} {
8076 movehead $id $name
8077 movedhead $id $name
8078 redrawtags $old_id
8079 redrawtags $id
8080 } else {
8081 set headids($name) $id
8082 lappend idheads($id) $name
8083 addedhead $id $name
8084 redrawtags $id
8086 dispneartags 0
8087 run refill_reflist
8091 proc exec_citool {tool_args {baseid {}}} {
8092 global commitinfo env
8094 set save_env [array get env GIT_AUTHOR_*]
8096 if {$baseid ne {}} {
8097 if {![info exists commitinfo($baseid)]} {
8098 getcommit $baseid
8100 set author [lindex $commitinfo($baseid) 1]
8101 set date [lindex $commitinfo($baseid) 2]
8102 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8103 $author author name email]
8104 && $date ne {}} {
8105 set env(GIT_AUTHOR_NAME) $name
8106 set env(GIT_AUTHOR_EMAIL) $email
8107 set env(GIT_AUTHOR_DATE) $date
8111 eval exec git citool $tool_args &
8113 array unset env GIT_AUTHOR_*
8114 array set env $save_env
8117 proc cherrypick {} {
8118 global rowmenuid curview
8119 global mainhead mainheadid
8121 set oldhead [exec git rev-parse HEAD]
8122 set dheads [descheads $rowmenuid]
8123 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8124 set ok [confirm_popup [mc "Commit %s is already\
8125 included in branch %s -- really re-apply it?" \
8126 [string range $rowmenuid 0 7] $mainhead]]
8127 if {!$ok} return
8129 nowbusy cherrypick [mc "Cherry-picking"]
8130 update
8131 # Unfortunately git-cherry-pick writes stuff to stderr even when
8132 # no error occurs, and exec takes that as an indication of error...
8133 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8134 notbusy cherrypick
8135 if {[regexp -line \
8136 {Entry '(.*)' would be overwritten by merge} $err msg fname]} {
8137 error_popup [mc "Cherry-pick failed:
8138 file '%s' had local modifications.
8140 Please commit, reset or stash your changes." $fname]
8141 } elseif {[regexp -line {^CONFLICT \(.*\):} $err msg]} {
8142 # Force citool to read MERGE_MSG
8143 file delete [file join [gitdir] "GITGUI_MSG"]
8144 exec_citool {} $rowmenuid
8145 } else {
8146 error_popup $err
8148 return
8150 set newhead [exec git rev-parse HEAD]
8151 if {$newhead eq $oldhead} {
8152 notbusy cherrypick
8153 error_popup [mc "No changes committed"]
8154 return
8156 addnewchild $newhead $oldhead
8157 if {[commitinview $oldhead $curview]} {
8158 insertrow $newhead $oldhead $curview
8159 if {$mainhead ne {}} {
8160 movehead $newhead $mainhead
8161 movedhead $newhead $mainhead
8163 set mainheadid $newhead
8164 redrawtags $oldhead
8165 redrawtags $newhead
8166 selbyid $newhead
8168 notbusy cherrypick
8171 proc resethead {} {
8172 global mainhead rowmenuid confirm_ok resettype
8174 set confirm_ok 0
8175 set w ".confirmreset"
8176 toplevel $w
8177 wm transient $w .
8178 wm title $w [mc "Confirm reset"]
8179 message $w.m -text \
8180 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8181 -justify center -aspect 1000
8182 pack $w.m -side top -fill x -padx 20 -pady 20
8183 frame $w.f -relief sunken -border 2
8184 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8185 grid $w.f.rt -sticky w
8186 set resettype mixed
8187 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8188 -text [mc "Soft: Leave working tree and index untouched"]
8189 grid $w.f.soft -sticky w
8190 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8191 -text [mc "Mixed: Leave working tree untouched, reset index"]
8192 grid $w.f.mixed -sticky w
8193 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8194 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8195 grid $w.f.hard -sticky w
8196 pack $w.f -side top -fill x
8197 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8198 pack $w.ok -side left -fill x -padx 20 -pady 20
8199 button $w.cancel -text [mc Cancel] -command "destroy $w"
8200 bind $w <Key-Escape> [list destroy $w]
8201 pack $w.cancel -side right -fill x -padx 20 -pady 20
8202 bind $w <Visibility> "grab $w; focus $w"
8203 tkwait window $w
8204 if {!$confirm_ok} return
8205 if {[catch {set fd [open \
8206 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8207 error_popup $err
8208 } else {
8209 dohidelocalchanges
8210 filerun $fd [list readresetstat $fd]
8211 nowbusy reset [mc "Resetting"]
8212 selbyid $rowmenuid
8216 proc readresetstat {fd} {
8217 global mainhead mainheadid showlocalchanges rprogcoord
8219 if {[gets $fd line] >= 0} {
8220 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8221 set rprogcoord [expr {1.0 * $m / $n}]
8222 adjustprogress
8224 return 1
8226 set rprogcoord 0
8227 adjustprogress
8228 notbusy reset
8229 if {[catch {close $fd} err]} {
8230 error_popup $err
8232 set oldhead $mainheadid
8233 set newhead [exec git rev-parse HEAD]
8234 if {$newhead ne $oldhead} {
8235 movehead $newhead $mainhead
8236 movedhead $newhead $mainhead
8237 set mainheadid $newhead
8238 redrawtags $oldhead
8239 redrawtags $newhead
8241 if {$showlocalchanges} {
8242 doshowlocalchanges
8244 return 0
8247 # context menu for a head
8248 proc headmenu {x y id head} {
8249 global headmenuid headmenuhead headctxmenu mainhead
8251 stopfinding
8252 set headmenuid $id
8253 set headmenuhead $head
8254 set state normal
8255 if {$head eq $mainhead} {
8256 set state disabled
8258 $headctxmenu entryconfigure 0 -state $state
8259 $headctxmenu entryconfigure 1 -state $state
8260 tk_popup $headctxmenu $x $y
8263 proc cobranch {} {
8264 global headmenuid headmenuhead headids
8265 global showlocalchanges mainheadid
8267 # check the tree is clean first??
8268 nowbusy checkout [mc "Checking out"]
8269 update
8270 dohidelocalchanges
8271 if {[catch {
8272 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8273 } err]} {
8274 notbusy checkout
8275 error_popup $err
8276 if {$showlocalchanges} {
8277 dodiffindex
8279 } else {
8280 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8284 proc readcheckoutstat {fd newhead newheadid} {
8285 global mainhead mainheadid headids showlocalchanges progresscoords
8287 if {[gets $fd line] >= 0} {
8288 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8289 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8290 adjustprogress
8292 return 1
8294 set progresscoords {0 0}
8295 adjustprogress
8296 notbusy checkout
8297 if {[catch {close $fd} err]} {
8298 error_popup $err
8300 set oldmainid $mainheadid
8301 set mainhead $newhead
8302 set mainheadid $newheadid
8303 redrawtags $oldmainid
8304 redrawtags $newheadid
8305 selbyid $newheadid
8306 if {$showlocalchanges} {
8307 dodiffindex
8311 proc rmbranch {} {
8312 global headmenuid headmenuhead mainhead
8313 global idheads
8315 set head $headmenuhead
8316 set id $headmenuid
8317 # this check shouldn't be needed any more...
8318 if {$head eq $mainhead} {
8319 error_popup [mc "Cannot delete the currently checked-out branch"]
8320 return
8322 set dheads [descheads $id]
8323 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8324 # the stuff on this branch isn't on any other branch
8325 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8326 branch.\nReally delete branch %s?" $head $head]]} return
8328 nowbusy rmbranch
8329 update
8330 if {[catch {exec git branch -D $head} err]} {
8331 notbusy rmbranch
8332 error_popup $err
8333 return
8335 removehead $id $head
8336 removedhead $id $head
8337 redrawtags $id
8338 notbusy rmbranch
8339 dispneartags 0
8340 run refill_reflist
8343 # Display a list of tags and heads
8344 proc showrefs {} {
8345 global showrefstop bgcolor fgcolor selectbgcolor
8346 global bglist fglist reflistfilter reflist maincursor
8348 set top .showrefs
8349 set showrefstop $top
8350 if {[winfo exists $top]} {
8351 raise $top
8352 refill_reflist
8353 return
8355 toplevel $top
8356 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8357 wm transient $top .
8358 text $top.list -background $bgcolor -foreground $fgcolor \
8359 -selectbackground $selectbgcolor -font mainfont \
8360 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8361 -width 30 -height 20 -cursor $maincursor \
8362 -spacing1 1 -spacing3 1 -state disabled
8363 $top.list tag configure highlight -background $selectbgcolor
8364 lappend bglist $top.list
8365 lappend fglist $top.list
8366 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8367 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8368 grid $top.list $top.ysb -sticky nsew
8369 grid $top.xsb x -sticky ew
8370 frame $top.f
8371 label $top.f.l -text "[mc "Filter"]: "
8372 entry $top.f.e -width 20 -textvariable reflistfilter
8373 set reflistfilter "*"
8374 trace add variable reflistfilter write reflistfilter_change
8375 pack $top.f.e -side right -fill x -expand 1
8376 pack $top.f.l -side left
8377 grid $top.f - -sticky ew -pady 2
8378 button $top.close -command [list destroy $top] -text [mc "Close"]
8379 bind $top <Key-Escape> [list destroy $top]
8380 grid $top.close -
8381 grid columnconfigure $top 0 -weight 1
8382 grid rowconfigure $top 0 -weight 1
8383 bind $top.list <1> {break}
8384 bind $top.list <B1-Motion> {break}
8385 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8386 set reflist {}
8387 refill_reflist
8390 proc sel_reflist {w x y} {
8391 global showrefstop reflist headids tagids otherrefids
8393 if {![winfo exists $showrefstop]} return
8394 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8395 set ref [lindex $reflist [expr {$l-1}]]
8396 set n [lindex $ref 0]
8397 switch -- [lindex $ref 1] {
8398 "H" {selbyid $headids($n)}
8399 "T" {selbyid $tagids($n)}
8400 "o" {selbyid $otherrefids($n)}
8402 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8405 proc unsel_reflist {} {
8406 global showrefstop
8408 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8409 $showrefstop.list tag remove highlight 0.0 end
8412 proc reflistfilter_change {n1 n2 op} {
8413 global reflistfilter
8415 after cancel refill_reflist
8416 after 200 refill_reflist
8419 proc refill_reflist {} {
8420 global reflist reflistfilter showrefstop headids tagids otherrefids
8421 global curview
8423 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8424 set refs {}
8425 foreach n [array names headids] {
8426 if {[string match $reflistfilter $n]} {
8427 if {[commitinview $headids($n) $curview]} {
8428 lappend refs [list $n H]
8429 } else {
8430 interestedin $headids($n) {run refill_reflist}
8434 foreach n [array names tagids] {
8435 if {[string match $reflistfilter $n]} {
8436 if {[commitinview $tagids($n) $curview]} {
8437 lappend refs [list $n T]
8438 } else {
8439 interestedin $tagids($n) {run refill_reflist}
8443 foreach n [array names otherrefids] {
8444 if {[string match $reflistfilter $n]} {
8445 if {[commitinview $otherrefids($n) $curview]} {
8446 lappend refs [list $n o]
8447 } else {
8448 interestedin $otherrefids($n) {run refill_reflist}
8452 set refs [lsort -index 0 $refs]
8453 if {$refs eq $reflist} return
8455 # Update the contents of $showrefstop.list according to the
8456 # differences between $reflist (old) and $refs (new)
8457 $showrefstop.list conf -state normal
8458 $showrefstop.list insert end "\n"
8459 set i 0
8460 set j 0
8461 while {$i < [llength $reflist] || $j < [llength $refs]} {
8462 if {$i < [llength $reflist]} {
8463 if {$j < [llength $refs]} {
8464 set cmp [string compare [lindex $reflist $i 0] \
8465 [lindex $refs $j 0]]
8466 if {$cmp == 0} {
8467 set cmp [string compare [lindex $reflist $i 1] \
8468 [lindex $refs $j 1]]
8470 } else {
8471 set cmp -1
8473 } else {
8474 set cmp 1
8476 switch -- $cmp {
8477 -1 {
8478 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8479 incr i
8482 incr i
8483 incr j
8486 set l [expr {$j + 1}]
8487 $showrefstop.list image create $l.0 -align baseline \
8488 -image reficon-[lindex $refs $j 1] -padx 2
8489 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8490 incr j
8494 set reflist $refs
8495 # delete last newline
8496 $showrefstop.list delete end-2c end-1c
8497 $showrefstop.list conf -state disabled
8500 # Stuff for finding nearby tags
8501 proc getallcommits {} {
8502 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8503 global idheads idtags idotherrefs allparents tagobjid
8505 if {![info exists allcommits]} {
8506 set nextarc 0
8507 set allcommits 0
8508 set seeds {}
8509 set allcwait 0
8510 set cachedarcs 0
8511 set allccache [file join [gitdir] "gitk.cache"]
8512 if {![catch {
8513 set f [open $allccache r]
8514 set allcwait 1
8515 getcache $f
8516 }]} return
8519 if {$allcwait} {
8520 return
8522 set cmd [list | git rev-list --parents]
8523 set allcupdate [expr {$seeds ne {}}]
8524 if {!$allcupdate} {
8525 set ids "--all"
8526 } else {
8527 set refs [concat [array names idheads] [array names idtags] \
8528 [array names idotherrefs]]
8529 set ids {}
8530 set tagobjs {}
8531 foreach name [array names tagobjid] {
8532 lappend tagobjs $tagobjid($name)
8534 foreach id [lsort -unique $refs] {
8535 if {![info exists allparents($id)] &&
8536 [lsearch -exact $tagobjs $id] < 0} {
8537 lappend ids $id
8540 if {$ids ne {}} {
8541 foreach id $seeds {
8542 lappend ids "^$id"
8546 if {$ids ne {}} {
8547 set fd [open [concat $cmd $ids] r]
8548 fconfigure $fd -blocking 0
8549 incr allcommits
8550 nowbusy allcommits
8551 filerun $fd [list getallclines $fd]
8552 } else {
8553 dispneartags 0
8557 # Since most commits have 1 parent and 1 child, we group strings of
8558 # such commits into "arcs" joining branch/merge points (BMPs), which
8559 # are commits that either don't have 1 parent or don't have 1 child.
8561 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8562 # arcout(id) - outgoing arcs for BMP
8563 # arcids(a) - list of IDs on arc including end but not start
8564 # arcstart(a) - BMP ID at start of arc
8565 # arcend(a) - BMP ID at end of arc
8566 # growing(a) - arc a is still growing
8567 # arctags(a) - IDs out of arcids (excluding end) that have tags
8568 # archeads(a) - IDs out of arcids (excluding end) that have heads
8569 # The start of an arc is at the descendent end, so "incoming" means
8570 # coming from descendents, and "outgoing" means going towards ancestors.
8572 proc getallclines {fd} {
8573 global allparents allchildren idtags idheads nextarc
8574 global arcnos arcids arctags arcout arcend arcstart archeads growing
8575 global seeds allcommits cachedarcs allcupdate
8577 set nid 0
8578 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8579 set id [lindex $line 0]
8580 if {[info exists allparents($id)]} {
8581 # seen it already
8582 continue
8584 set cachedarcs 0
8585 set olds [lrange $line 1 end]
8586 set allparents($id) $olds
8587 if {![info exists allchildren($id)]} {
8588 set allchildren($id) {}
8589 set arcnos($id) {}
8590 lappend seeds $id
8591 } else {
8592 set a $arcnos($id)
8593 if {[llength $olds] == 1 && [llength $a] == 1} {
8594 lappend arcids($a) $id
8595 if {[info exists idtags($id)]} {
8596 lappend arctags($a) $id
8598 if {[info exists idheads($id)]} {
8599 lappend archeads($a) $id
8601 if {[info exists allparents($olds)]} {
8602 # seen parent already
8603 if {![info exists arcout($olds)]} {
8604 splitarc $olds
8606 lappend arcids($a) $olds
8607 set arcend($a) $olds
8608 unset growing($a)
8610 lappend allchildren($olds) $id
8611 lappend arcnos($olds) $a
8612 continue
8615 foreach a $arcnos($id) {
8616 lappend arcids($a) $id
8617 set arcend($a) $id
8618 unset growing($a)
8621 set ao {}
8622 foreach p $olds {
8623 lappend allchildren($p) $id
8624 set a [incr nextarc]
8625 set arcstart($a) $id
8626 set archeads($a) {}
8627 set arctags($a) {}
8628 set archeads($a) {}
8629 set arcids($a) {}
8630 lappend ao $a
8631 set growing($a) 1
8632 if {[info exists allparents($p)]} {
8633 # seen it already, may need to make a new branch
8634 if {![info exists arcout($p)]} {
8635 splitarc $p
8637 lappend arcids($a) $p
8638 set arcend($a) $p
8639 unset growing($a)
8641 lappend arcnos($p) $a
8643 set arcout($id) $ao
8645 if {$nid > 0} {
8646 global cached_dheads cached_dtags cached_atags
8647 catch {unset cached_dheads}
8648 catch {unset cached_dtags}
8649 catch {unset cached_atags}
8651 if {![eof $fd]} {
8652 return [expr {$nid >= 1000? 2: 1}]
8654 set cacheok 1
8655 if {[catch {
8656 fconfigure $fd -blocking 1
8657 close $fd
8658 } err]} {
8659 # got an error reading the list of commits
8660 # if we were updating, try rereading the whole thing again
8661 if {$allcupdate} {
8662 incr allcommits -1
8663 dropcache $err
8664 return
8666 error_popup "[mc "Error reading commit topology information;\
8667 branch and preceding/following tag information\
8668 will be incomplete."]\n($err)"
8669 set cacheok 0
8671 if {[incr allcommits -1] == 0} {
8672 notbusy allcommits
8673 if {$cacheok} {
8674 run savecache
8677 dispneartags 0
8678 return 0
8681 proc recalcarc {a} {
8682 global arctags archeads arcids idtags idheads
8684 set at {}
8685 set ah {}
8686 foreach id [lrange $arcids($a) 0 end-1] {
8687 if {[info exists idtags($id)]} {
8688 lappend at $id
8690 if {[info exists idheads($id)]} {
8691 lappend ah $id
8694 set arctags($a) $at
8695 set archeads($a) $ah
8698 proc splitarc {p} {
8699 global arcnos arcids nextarc arctags archeads idtags idheads
8700 global arcstart arcend arcout allparents growing
8702 set a $arcnos($p)
8703 if {[llength $a] != 1} {
8704 puts "oops splitarc called but [llength $a] arcs already"
8705 return
8707 set a [lindex $a 0]
8708 set i [lsearch -exact $arcids($a) $p]
8709 if {$i < 0} {
8710 puts "oops splitarc $p not in arc $a"
8711 return
8713 set na [incr nextarc]
8714 if {[info exists arcend($a)]} {
8715 set arcend($na) $arcend($a)
8716 } else {
8717 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8718 set j [lsearch -exact $arcnos($l) $a]
8719 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8721 set tail [lrange $arcids($a) [expr {$i+1}] end]
8722 set arcids($a) [lrange $arcids($a) 0 $i]
8723 set arcend($a) $p
8724 set arcstart($na) $p
8725 set arcout($p) $na
8726 set arcids($na) $tail
8727 if {[info exists growing($a)]} {
8728 set growing($na) 1
8729 unset growing($a)
8732 foreach id $tail {
8733 if {[llength $arcnos($id)] == 1} {
8734 set arcnos($id) $na
8735 } else {
8736 set j [lsearch -exact $arcnos($id) $a]
8737 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8741 # reconstruct tags and heads lists
8742 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8743 recalcarc $a
8744 recalcarc $na
8745 } else {
8746 set arctags($na) {}
8747 set archeads($na) {}
8751 # Update things for a new commit added that is a child of one
8752 # existing commit. Used when cherry-picking.
8753 proc addnewchild {id p} {
8754 global allparents allchildren idtags nextarc
8755 global arcnos arcids arctags arcout arcend arcstart archeads growing
8756 global seeds allcommits
8758 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8759 set allparents($id) [list $p]
8760 set allchildren($id) {}
8761 set arcnos($id) {}
8762 lappend seeds $id
8763 lappend allchildren($p) $id
8764 set a [incr nextarc]
8765 set arcstart($a) $id
8766 set archeads($a) {}
8767 set arctags($a) {}
8768 set arcids($a) [list $p]
8769 set arcend($a) $p
8770 if {![info exists arcout($p)]} {
8771 splitarc $p
8773 lappend arcnos($p) $a
8774 set arcout($id) [list $a]
8777 # This implements a cache for the topology information.
8778 # The cache saves, for each arc, the start and end of the arc,
8779 # the ids on the arc, and the outgoing arcs from the end.
8780 proc readcache {f} {
8781 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8782 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8783 global allcwait
8785 set a $nextarc
8786 set lim $cachedarcs
8787 if {$lim - $a > 500} {
8788 set lim [expr {$a + 500}]
8790 if {[catch {
8791 if {$a == $lim} {
8792 # finish reading the cache and setting up arctags, etc.
8793 set line [gets $f]
8794 if {$line ne "1"} {error "bad final version"}
8795 close $f
8796 foreach id [array names idtags] {
8797 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8798 [llength $allparents($id)] == 1} {
8799 set a [lindex $arcnos($id) 0]
8800 if {$arctags($a) eq {}} {
8801 recalcarc $a
8805 foreach id [array names idheads] {
8806 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8807 [llength $allparents($id)] == 1} {
8808 set a [lindex $arcnos($id) 0]
8809 if {$archeads($a) eq {}} {
8810 recalcarc $a
8814 foreach id [lsort -unique $possible_seeds] {
8815 if {$arcnos($id) eq {}} {
8816 lappend seeds $id
8819 set allcwait 0
8820 } else {
8821 while {[incr a] <= $lim} {
8822 set line [gets $f]
8823 if {[llength $line] != 3} {error "bad line"}
8824 set s [lindex $line 0]
8825 set arcstart($a) $s
8826 lappend arcout($s) $a
8827 if {![info exists arcnos($s)]} {
8828 lappend possible_seeds $s
8829 set arcnos($s) {}
8831 set e [lindex $line 1]
8832 if {$e eq {}} {
8833 set growing($a) 1
8834 } else {
8835 set arcend($a) $e
8836 if {![info exists arcout($e)]} {
8837 set arcout($e) {}
8840 set arcids($a) [lindex $line 2]
8841 foreach id $arcids($a) {
8842 lappend allparents($s) $id
8843 set s $id
8844 lappend arcnos($id) $a
8846 if {![info exists allparents($s)]} {
8847 set allparents($s) {}
8849 set arctags($a) {}
8850 set archeads($a) {}
8852 set nextarc [expr {$a - 1}]
8854 } err]} {
8855 dropcache $err
8856 return 0
8858 if {!$allcwait} {
8859 getallcommits
8861 return $allcwait
8864 proc getcache {f} {
8865 global nextarc cachedarcs possible_seeds
8867 if {[catch {
8868 set line [gets $f]
8869 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8870 # make sure it's an integer
8871 set cachedarcs [expr {int([lindex $line 1])}]
8872 if {$cachedarcs < 0} {error "bad number of arcs"}
8873 set nextarc 0
8874 set possible_seeds {}
8875 run readcache $f
8876 } err]} {
8877 dropcache $err
8879 return 0
8882 proc dropcache {err} {
8883 global allcwait nextarc cachedarcs seeds
8885 #puts "dropping cache ($err)"
8886 foreach v {arcnos arcout arcids arcstart arcend growing \
8887 arctags archeads allparents allchildren} {
8888 global $v
8889 catch {unset $v}
8891 set allcwait 0
8892 set nextarc 0
8893 set cachedarcs 0
8894 set seeds {}
8895 getallcommits
8898 proc writecache {f} {
8899 global cachearc cachedarcs allccache
8900 global arcstart arcend arcnos arcids arcout
8902 set a $cachearc
8903 set lim $cachedarcs
8904 if {$lim - $a > 1000} {
8905 set lim [expr {$a + 1000}]
8907 if {[catch {
8908 while {[incr a] <= $lim} {
8909 if {[info exists arcend($a)]} {
8910 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8911 } else {
8912 puts $f [list $arcstart($a) {} $arcids($a)]
8915 } err]} {
8916 catch {close $f}
8917 catch {file delete $allccache}
8918 #puts "writing cache failed ($err)"
8919 return 0
8921 set cachearc [expr {$a - 1}]
8922 if {$a > $cachedarcs} {
8923 puts $f "1"
8924 close $f
8925 return 0
8927 return 1
8930 proc savecache {} {
8931 global nextarc cachedarcs cachearc allccache
8933 if {$nextarc == $cachedarcs} return
8934 set cachearc 0
8935 set cachedarcs $nextarc
8936 catch {
8937 set f [open $allccache w]
8938 puts $f [list 1 $cachedarcs]
8939 run writecache $f
8943 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8944 # or 0 if neither is true.
8945 proc anc_or_desc {a b} {
8946 global arcout arcstart arcend arcnos cached_isanc
8948 if {$arcnos($a) eq $arcnos($b)} {
8949 # Both are on the same arc(s); either both are the same BMP,
8950 # or if one is not a BMP, the other is also not a BMP or is
8951 # the BMP at end of the arc (and it only has 1 incoming arc).
8952 # Or both can be BMPs with no incoming arcs.
8953 if {$a eq $b || $arcnos($a) eq {}} {
8954 return 0
8956 # assert {[llength $arcnos($a)] == 1}
8957 set arc [lindex $arcnos($a) 0]
8958 set i [lsearch -exact $arcids($arc) $a]
8959 set j [lsearch -exact $arcids($arc) $b]
8960 if {$i < 0 || $i > $j} {
8961 return 1
8962 } else {
8963 return -1
8967 if {![info exists arcout($a)]} {
8968 set arc [lindex $arcnos($a) 0]
8969 if {[info exists arcend($arc)]} {
8970 set aend $arcend($arc)
8971 } else {
8972 set aend {}
8974 set a $arcstart($arc)
8975 } else {
8976 set aend $a
8978 if {![info exists arcout($b)]} {
8979 set arc [lindex $arcnos($b) 0]
8980 if {[info exists arcend($arc)]} {
8981 set bend $arcend($arc)
8982 } else {
8983 set bend {}
8985 set b $arcstart($arc)
8986 } else {
8987 set bend $b
8989 if {$a eq $bend} {
8990 return 1
8992 if {$b eq $aend} {
8993 return -1
8995 if {[info exists cached_isanc($a,$bend)]} {
8996 if {$cached_isanc($a,$bend)} {
8997 return 1
9000 if {[info exists cached_isanc($b,$aend)]} {
9001 if {$cached_isanc($b,$aend)} {
9002 return -1
9004 if {[info exists cached_isanc($a,$bend)]} {
9005 return 0
9009 set todo [list $a $b]
9010 set anc($a) a
9011 set anc($b) b
9012 for {set i 0} {$i < [llength $todo]} {incr i} {
9013 set x [lindex $todo $i]
9014 if {$anc($x) eq {}} {
9015 continue
9017 foreach arc $arcnos($x) {
9018 set xd $arcstart($arc)
9019 if {$xd eq $bend} {
9020 set cached_isanc($a,$bend) 1
9021 set cached_isanc($b,$aend) 0
9022 return 1
9023 } elseif {$xd eq $aend} {
9024 set cached_isanc($b,$aend) 1
9025 set cached_isanc($a,$bend) 0
9026 return -1
9028 if {![info exists anc($xd)]} {
9029 set anc($xd) $anc($x)
9030 lappend todo $xd
9031 } elseif {$anc($xd) ne $anc($x)} {
9032 set anc($xd) {}
9036 set cached_isanc($a,$bend) 0
9037 set cached_isanc($b,$aend) 0
9038 return 0
9041 # This identifies whether $desc has an ancestor that is
9042 # a growing tip of the graph and which is not an ancestor of $anc
9043 # and returns 0 if so and 1 if not.
9044 # If we subsequently discover a tag on such a growing tip, and that
9045 # turns out to be a descendent of $anc (which it could, since we
9046 # don't necessarily see children before parents), then $desc
9047 # isn't a good choice to display as a descendent tag of
9048 # $anc (since it is the descendent of another tag which is
9049 # a descendent of $anc). Similarly, $anc isn't a good choice to
9050 # display as a ancestor tag of $desc.
9052 proc is_certain {desc anc} {
9053 global arcnos arcout arcstart arcend growing problems
9055 set certain {}
9056 if {[llength $arcnos($anc)] == 1} {
9057 # tags on the same arc are certain
9058 if {$arcnos($desc) eq $arcnos($anc)} {
9059 return 1
9061 if {![info exists arcout($anc)]} {
9062 # if $anc is partway along an arc, use the start of the arc instead
9063 set a [lindex $arcnos($anc) 0]
9064 set anc $arcstart($a)
9067 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9068 set x $desc
9069 } else {
9070 set a [lindex $arcnos($desc) 0]
9071 set x $arcend($a)
9073 if {$x == $anc} {
9074 return 1
9076 set anclist [list $x]
9077 set dl($x) 1
9078 set nnh 1
9079 set ngrowanc 0
9080 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9081 set x [lindex $anclist $i]
9082 if {$dl($x)} {
9083 incr nnh -1
9085 set done($x) 1
9086 foreach a $arcout($x) {
9087 if {[info exists growing($a)]} {
9088 if {![info exists growanc($x)] && $dl($x)} {
9089 set growanc($x) 1
9090 incr ngrowanc
9092 } else {
9093 set y $arcend($a)
9094 if {[info exists dl($y)]} {
9095 if {$dl($y)} {
9096 if {!$dl($x)} {
9097 set dl($y) 0
9098 if {![info exists done($y)]} {
9099 incr nnh -1
9101 if {[info exists growanc($x)]} {
9102 incr ngrowanc -1
9104 set xl [list $y]
9105 for {set k 0} {$k < [llength $xl]} {incr k} {
9106 set z [lindex $xl $k]
9107 foreach c $arcout($z) {
9108 if {[info exists arcend($c)]} {
9109 set v $arcend($c)
9110 if {[info exists dl($v)] && $dl($v)} {
9111 set dl($v) 0
9112 if {![info exists done($v)]} {
9113 incr nnh -1
9115 if {[info exists growanc($v)]} {
9116 incr ngrowanc -1
9118 lappend xl $v
9125 } elseif {$y eq $anc || !$dl($x)} {
9126 set dl($y) 0
9127 lappend anclist $y
9128 } else {
9129 set dl($y) 1
9130 lappend anclist $y
9131 incr nnh
9136 foreach x [array names growanc] {
9137 if {$dl($x)} {
9138 return 0
9140 return 0
9142 return 1
9145 proc validate_arctags {a} {
9146 global arctags idtags
9148 set i -1
9149 set na $arctags($a)
9150 foreach id $arctags($a) {
9151 incr i
9152 if {![info exists idtags($id)]} {
9153 set na [lreplace $na $i $i]
9154 incr i -1
9157 set arctags($a) $na
9160 proc validate_archeads {a} {
9161 global archeads idheads
9163 set i -1
9164 set na $archeads($a)
9165 foreach id $archeads($a) {
9166 incr i
9167 if {![info exists idheads($id)]} {
9168 set na [lreplace $na $i $i]
9169 incr i -1
9172 set archeads($a) $na
9175 # Return the list of IDs that have tags that are descendents of id,
9176 # ignoring IDs that are descendents of IDs already reported.
9177 proc desctags {id} {
9178 global arcnos arcstart arcids arctags idtags allparents
9179 global growing cached_dtags
9181 if {![info exists allparents($id)]} {
9182 return {}
9184 set t1 [clock clicks -milliseconds]
9185 set argid $id
9186 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9187 # part-way along an arc; check that arc first
9188 set a [lindex $arcnos($id) 0]
9189 if {$arctags($a) ne {}} {
9190 validate_arctags $a
9191 set i [lsearch -exact $arcids($a) $id]
9192 set tid {}
9193 foreach t $arctags($a) {
9194 set j [lsearch -exact $arcids($a) $t]
9195 if {$j >= $i} break
9196 set tid $t
9198 if {$tid ne {}} {
9199 return $tid
9202 set id $arcstart($a)
9203 if {[info exists idtags($id)]} {
9204 return $id
9207 if {[info exists cached_dtags($id)]} {
9208 return $cached_dtags($id)
9211 set origid $id
9212 set todo [list $id]
9213 set queued($id) 1
9214 set nc 1
9215 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9216 set id [lindex $todo $i]
9217 set done($id) 1
9218 set ta [info exists hastaggedancestor($id)]
9219 if {!$ta} {
9220 incr nc -1
9222 # ignore tags on starting node
9223 if {!$ta && $i > 0} {
9224 if {[info exists idtags($id)]} {
9225 set tagloc($id) $id
9226 set ta 1
9227 } elseif {[info exists cached_dtags($id)]} {
9228 set tagloc($id) $cached_dtags($id)
9229 set ta 1
9232 foreach a $arcnos($id) {
9233 set d $arcstart($a)
9234 if {!$ta && $arctags($a) ne {}} {
9235 validate_arctags $a
9236 if {$arctags($a) ne {}} {
9237 lappend tagloc($id) [lindex $arctags($a) end]
9240 if {$ta || $arctags($a) ne {}} {
9241 set tomark [list $d]
9242 for {set j 0} {$j < [llength $tomark]} {incr j} {
9243 set dd [lindex $tomark $j]
9244 if {![info exists hastaggedancestor($dd)]} {
9245 if {[info exists done($dd)]} {
9246 foreach b $arcnos($dd) {
9247 lappend tomark $arcstart($b)
9249 if {[info exists tagloc($dd)]} {
9250 unset tagloc($dd)
9252 } elseif {[info exists queued($dd)]} {
9253 incr nc -1
9255 set hastaggedancestor($dd) 1
9259 if {![info exists queued($d)]} {
9260 lappend todo $d
9261 set queued($d) 1
9262 if {![info exists hastaggedancestor($d)]} {
9263 incr nc
9268 set tags {}
9269 foreach id [array names tagloc] {
9270 if {![info exists hastaggedancestor($id)]} {
9271 foreach t $tagloc($id) {
9272 if {[lsearch -exact $tags $t] < 0} {
9273 lappend tags $t
9278 set t2 [clock clicks -milliseconds]
9279 set loopix $i
9281 # remove tags that are descendents of other tags
9282 for {set i 0} {$i < [llength $tags]} {incr i} {
9283 set a [lindex $tags $i]
9284 for {set j 0} {$j < $i} {incr j} {
9285 set b [lindex $tags $j]
9286 set r [anc_or_desc $a $b]
9287 if {$r == 1} {
9288 set tags [lreplace $tags $j $j]
9289 incr j -1
9290 incr i -1
9291 } elseif {$r == -1} {
9292 set tags [lreplace $tags $i $i]
9293 incr i -1
9294 break
9299 if {[array names growing] ne {}} {
9300 # graph isn't finished, need to check if any tag could get
9301 # eclipsed by another tag coming later. Simply ignore any
9302 # tags that could later get eclipsed.
9303 set ctags {}
9304 foreach t $tags {
9305 if {[is_certain $t $origid]} {
9306 lappend ctags $t
9309 if {$tags eq $ctags} {
9310 set cached_dtags($origid) $tags
9311 } else {
9312 set tags $ctags
9314 } else {
9315 set cached_dtags($origid) $tags
9317 set t3 [clock clicks -milliseconds]
9318 if {0 && $t3 - $t1 >= 100} {
9319 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9320 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9322 return $tags
9325 proc anctags {id} {
9326 global arcnos arcids arcout arcend arctags idtags allparents
9327 global growing cached_atags
9329 if {![info exists allparents($id)]} {
9330 return {}
9332 set t1 [clock clicks -milliseconds]
9333 set argid $id
9334 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9335 # part-way along an arc; check that arc first
9336 set a [lindex $arcnos($id) 0]
9337 if {$arctags($a) ne {}} {
9338 validate_arctags $a
9339 set i [lsearch -exact $arcids($a) $id]
9340 foreach t $arctags($a) {
9341 set j [lsearch -exact $arcids($a) $t]
9342 if {$j > $i} {
9343 return $t
9347 if {![info exists arcend($a)]} {
9348 return {}
9350 set id $arcend($a)
9351 if {[info exists idtags($id)]} {
9352 return $id
9355 if {[info exists cached_atags($id)]} {
9356 return $cached_atags($id)
9359 set origid $id
9360 set todo [list $id]
9361 set queued($id) 1
9362 set taglist {}
9363 set nc 1
9364 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9365 set id [lindex $todo $i]
9366 set done($id) 1
9367 set td [info exists hastaggeddescendent($id)]
9368 if {!$td} {
9369 incr nc -1
9371 # ignore tags on starting node
9372 if {!$td && $i > 0} {
9373 if {[info exists idtags($id)]} {
9374 set tagloc($id) $id
9375 set td 1
9376 } elseif {[info exists cached_atags($id)]} {
9377 set tagloc($id) $cached_atags($id)
9378 set td 1
9381 foreach a $arcout($id) {
9382 if {!$td && $arctags($a) ne {}} {
9383 validate_arctags $a
9384 if {$arctags($a) ne {}} {
9385 lappend tagloc($id) [lindex $arctags($a) 0]
9388 if {![info exists arcend($a)]} continue
9389 set d $arcend($a)
9390 if {$td || $arctags($a) ne {}} {
9391 set tomark [list $d]
9392 for {set j 0} {$j < [llength $tomark]} {incr j} {
9393 set dd [lindex $tomark $j]
9394 if {![info exists hastaggeddescendent($dd)]} {
9395 if {[info exists done($dd)]} {
9396 foreach b $arcout($dd) {
9397 if {[info exists arcend($b)]} {
9398 lappend tomark $arcend($b)
9401 if {[info exists tagloc($dd)]} {
9402 unset tagloc($dd)
9404 } elseif {[info exists queued($dd)]} {
9405 incr nc -1
9407 set hastaggeddescendent($dd) 1
9411 if {![info exists queued($d)]} {
9412 lappend todo $d
9413 set queued($d) 1
9414 if {![info exists hastaggeddescendent($d)]} {
9415 incr nc
9420 set t2 [clock clicks -milliseconds]
9421 set loopix $i
9422 set tags {}
9423 foreach id [array names tagloc] {
9424 if {![info exists hastaggeddescendent($id)]} {
9425 foreach t $tagloc($id) {
9426 if {[lsearch -exact $tags $t] < 0} {
9427 lappend tags $t
9433 # remove tags that are ancestors of other tags
9434 for {set i 0} {$i < [llength $tags]} {incr i} {
9435 set a [lindex $tags $i]
9436 for {set j 0} {$j < $i} {incr j} {
9437 set b [lindex $tags $j]
9438 set r [anc_or_desc $a $b]
9439 if {$r == -1} {
9440 set tags [lreplace $tags $j $j]
9441 incr j -1
9442 incr i -1
9443 } elseif {$r == 1} {
9444 set tags [lreplace $tags $i $i]
9445 incr i -1
9446 break
9451 if {[array names growing] ne {}} {
9452 # graph isn't finished, need to check if any tag could get
9453 # eclipsed by another tag coming later. Simply ignore any
9454 # tags that could later get eclipsed.
9455 set ctags {}
9456 foreach t $tags {
9457 if {[is_certain $origid $t]} {
9458 lappend ctags $t
9461 if {$tags eq $ctags} {
9462 set cached_atags($origid) $tags
9463 } else {
9464 set tags $ctags
9466 } else {
9467 set cached_atags($origid) $tags
9469 set t3 [clock clicks -milliseconds]
9470 if {0 && $t3 - $t1 >= 100} {
9471 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9472 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9474 return $tags
9477 # Return the list of IDs that have heads that are descendents of id,
9478 # including id itself if it has a head.
9479 proc descheads {id} {
9480 global arcnos arcstart arcids archeads idheads cached_dheads
9481 global allparents
9483 if {![info exists allparents($id)]} {
9484 return {}
9486 set aret {}
9487 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9488 # part-way along an arc; check it first
9489 set a [lindex $arcnos($id) 0]
9490 if {$archeads($a) ne {}} {
9491 validate_archeads $a
9492 set i [lsearch -exact $arcids($a) $id]
9493 foreach t $archeads($a) {
9494 set j [lsearch -exact $arcids($a) $t]
9495 if {$j > $i} break
9496 lappend aret $t
9499 set id $arcstart($a)
9501 set origid $id
9502 set todo [list $id]
9503 set seen($id) 1
9504 set ret {}
9505 for {set i 0} {$i < [llength $todo]} {incr i} {
9506 set id [lindex $todo $i]
9507 if {[info exists cached_dheads($id)]} {
9508 set ret [concat $ret $cached_dheads($id)]
9509 } else {
9510 if {[info exists idheads($id)]} {
9511 lappend ret $id
9513 foreach a $arcnos($id) {
9514 if {$archeads($a) ne {}} {
9515 validate_archeads $a
9516 if {$archeads($a) ne {}} {
9517 set ret [concat $ret $archeads($a)]
9520 set d $arcstart($a)
9521 if {![info exists seen($d)]} {
9522 lappend todo $d
9523 set seen($d) 1
9528 set ret [lsort -unique $ret]
9529 set cached_dheads($origid) $ret
9530 return [concat $ret $aret]
9533 proc addedtag {id} {
9534 global arcnos arcout cached_dtags cached_atags
9536 if {![info exists arcnos($id)]} return
9537 if {![info exists arcout($id)]} {
9538 recalcarc [lindex $arcnos($id) 0]
9540 catch {unset cached_dtags}
9541 catch {unset cached_atags}
9544 proc addedhead {hid head} {
9545 global arcnos arcout cached_dheads
9547 if {![info exists arcnos($hid)]} return
9548 if {![info exists arcout($hid)]} {
9549 recalcarc [lindex $arcnos($hid) 0]
9551 catch {unset cached_dheads}
9554 proc removedhead {hid head} {
9555 global cached_dheads
9557 catch {unset cached_dheads}
9560 proc movedhead {hid head} {
9561 global arcnos arcout cached_dheads
9563 if {![info exists arcnos($hid)]} return
9564 if {![info exists arcout($hid)]} {
9565 recalcarc [lindex $arcnos($hid) 0]
9567 catch {unset cached_dheads}
9570 proc changedrefs {} {
9571 global cached_dheads cached_dtags cached_atags
9572 global arctags archeads arcnos arcout idheads idtags
9574 foreach id [concat [array names idheads] [array names idtags]] {
9575 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9576 set a [lindex $arcnos($id) 0]
9577 if {![info exists donearc($a)]} {
9578 recalcarc $a
9579 set donearc($a) 1
9583 catch {unset cached_dtags}
9584 catch {unset cached_atags}
9585 catch {unset cached_dheads}
9588 proc rereadrefs {} {
9589 global idtags idheads idotherrefs mainheadid
9591 set refids [concat [array names idtags] \
9592 [array names idheads] [array names idotherrefs]]
9593 foreach id $refids {
9594 if {![info exists ref($id)]} {
9595 set ref($id) [listrefs $id]
9598 set oldmainhead $mainheadid
9599 readrefs
9600 changedrefs
9601 set refids [lsort -unique [concat $refids [array names idtags] \
9602 [array names idheads] [array names idotherrefs]]]
9603 foreach id $refids {
9604 set v [listrefs $id]
9605 if {![info exists ref($id)] || $ref($id) != $v} {
9606 redrawtags $id
9609 if {$oldmainhead ne $mainheadid} {
9610 redrawtags $oldmainhead
9611 redrawtags $mainheadid
9613 run refill_reflist
9616 proc listrefs {id} {
9617 global idtags idheads idotherrefs
9619 set x {}
9620 if {[info exists idtags($id)]} {
9621 set x $idtags($id)
9623 set y {}
9624 if {[info exists idheads($id)]} {
9625 set y $idheads($id)
9627 set z {}
9628 if {[info exists idotherrefs($id)]} {
9629 set z $idotherrefs($id)
9631 return [list $x $y $z]
9634 proc showtag {tag isnew} {
9635 global ctext tagcontents tagids linknum tagobjid
9637 if {$isnew} {
9638 addtohistory [list showtag $tag 0]
9640 $ctext conf -state normal
9641 clear_ctext
9642 settabs 0
9643 set linknum 0
9644 if {![info exists tagcontents($tag)]} {
9645 catch {
9646 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9649 if {[info exists tagcontents($tag)]} {
9650 set text $tagcontents($tag)
9651 } else {
9652 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9654 appendwithlinks $text {}
9655 $ctext conf -state disabled
9656 init_flist {}
9659 proc doquit {} {
9660 global stopped
9661 global gitktmpdir
9663 set stopped 100
9664 savestuff .
9665 destroy .
9667 if {[info exists gitktmpdir]} {
9668 catch {file delete -force $gitktmpdir}
9672 proc mkfontdisp {font top which} {
9673 global fontattr fontpref $font
9675 set fontpref($font) [set $font]
9676 button $top.${font}but -text $which -font optionfont \
9677 -command [list choosefont $font $which]
9678 label $top.$font -relief flat -font $font \
9679 -text $fontattr($font,family) -justify left
9680 grid x $top.${font}but $top.$font -sticky w
9683 proc choosefont {font which} {
9684 global fontparam fontlist fonttop fontattr
9685 global prefstop
9687 set fontparam(which) $which
9688 set fontparam(font) $font
9689 set fontparam(family) [font actual $font -family]
9690 set fontparam(size) $fontattr($font,size)
9691 set fontparam(weight) $fontattr($font,weight)
9692 set fontparam(slant) $fontattr($font,slant)
9693 set top .gitkfont
9694 set fonttop $top
9695 if {![winfo exists $top]} {
9696 font create sample
9697 eval font config sample [font actual $font]
9698 toplevel $top
9699 wm transient $top $prefstop
9700 wm title $top [mc "Gitk font chooser"]
9701 label $top.l -textvariable fontparam(which)
9702 pack $top.l -side top
9703 set fontlist [lsort [font families]]
9704 frame $top.f
9705 listbox $top.f.fam -listvariable fontlist \
9706 -yscrollcommand [list $top.f.sb set]
9707 bind $top.f.fam <<ListboxSelect>> selfontfam
9708 scrollbar $top.f.sb -command [list $top.f.fam yview]
9709 pack $top.f.sb -side right -fill y
9710 pack $top.f.fam -side left -fill both -expand 1
9711 pack $top.f -side top -fill both -expand 1
9712 frame $top.g
9713 spinbox $top.g.size -from 4 -to 40 -width 4 \
9714 -textvariable fontparam(size) \
9715 -validatecommand {string is integer -strict %s}
9716 checkbutton $top.g.bold -padx 5 \
9717 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9718 -variable fontparam(weight) -onvalue bold -offvalue normal
9719 checkbutton $top.g.ital -padx 5 \
9720 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9721 -variable fontparam(slant) -onvalue italic -offvalue roman
9722 pack $top.g.size $top.g.bold $top.g.ital -side left
9723 pack $top.g -side top
9724 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9725 -background white
9726 $top.c create text 100 25 -anchor center -text $which -font sample \
9727 -fill black -tags text
9728 bind $top.c <Configure> [list centertext $top.c]
9729 pack $top.c -side top -fill x
9730 frame $top.buts
9731 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9732 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9733 bind $top <Key-Return> fontok
9734 bind $top <Key-Escape> fontcan
9735 grid $top.buts.ok $top.buts.can
9736 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9737 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9738 pack $top.buts -side bottom -fill x
9739 trace add variable fontparam write chg_fontparam
9740 } else {
9741 raise $top
9742 $top.c itemconf text -text $which
9744 set i [lsearch -exact $fontlist $fontparam(family)]
9745 if {$i >= 0} {
9746 $top.f.fam selection set $i
9747 $top.f.fam see $i
9751 proc centertext {w} {
9752 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9755 proc fontok {} {
9756 global fontparam fontpref prefstop
9758 set f $fontparam(font)
9759 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9760 if {$fontparam(weight) eq "bold"} {
9761 lappend fontpref($f) "bold"
9763 if {$fontparam(slant) eq "italic"} {
9764 lappend fontpref($f) "italic"
9766 set w $prefstop.$f
9767 $w conf -text $fontparam(family) -font $fontpref($f)
9769 fontcan
9772 proc fontcan {} {
9773 global fonttop fontparam
9775 if {[info exists fonttop]} {
9776 catch {destroy $fonttop}
9777 catch {font delete sample}
9778 unset fonttop
9779 unset fontparam
9783 proc selfontfam {} {
9784 global fonttop fontparam
9786 set i [$fonttop.f.fam curselection]
9787 if {$i ne {}} {
9788 set fontparam(family) [$fonttop.f.fam get $i]
9792 proc chg_fontparam {v sub op} {
9793 global fontparam
9795 font config sample -$sub $fontparam($sub)
9798 proc doprefs {} {
9799 global maxwidth maxgraphpct
9800 global oldprefs prefstop showneartags showlocalchanges
9801 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
9802 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9804 set top .gitkprefs
9805 set prefstop $top
9806 if {[winfo exists $top]} {
9807 raise $top
9808 return
9810 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9811 limitdiffs tabstop perfile_attrs} {
9812 set oldprefs($v) [set $v]
9814 toplevel $top
9815 wm title $top [mc "Gitk preferences"]
9816 wm transient $top .
9817 label $top.ldisp -text [mc "Commit list display options"]
9818 grid $top.ldisp - -sticky w -pady 10
9819 label $top.spacer -text " "
9820 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9821 -font optionfont
9822 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9823 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9824 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9825 -font optionfont
9826 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9827 grid x $top.maxpctl $top.maxpct -sticky w
9828 frame $top.showlocal
9829 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9830 checkbutton $top.showlocal.b -variable showlocalchanges
9831 pack $top.showlocal.b $top.showlocal.l -side left
9832 grid x $top.showlocal -sticky w
9833 frame $top.autoselect
9834 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9835 checkbutton $top.autoselect.b -variable autoselect
9836 pack $top.autoselect.b $top.autoselect.l -side left
9837 grid x $top.autoselect -sticky w
9839 label $top.ddisp -text [mc "Diff display options"]
9840 grid $top.ddisp - -sticky w -pady 10
9841 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9842 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9843 grid x $top.tabstopl $top.tabstop -sticky w
9844 frame $top.ntag
9845 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9846 checkbutton $top.ntag.b -variable showneartags
9847 pack $top.ntag.b $top.ntag.l -side left
9848 grid x $top.ntag -sticky w
9849 frame $top.ldiff
9850 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9851 checkbutton $top.ldiff.b -variable limitdiffs
9852 pack $top.ldiff.b $top.ldiff.l -side left
9853 grid x $top.ldiff -sticky w
9854 frame $top.lattr
9855 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9856 checkbutton $top.lattr.b -variable perfile_attrs
9857 pack $top.lattr.b $top.lattr.l -side left
9858 grid x $top.lattr -sticky w
9860 entry $top.extdifft -textvariable extdifftool
9861 frame $top.extdifff
9862 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9863 -padx 10
9864 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9865 -command choose_extdiff
9866 pack $top.extdifff.l $top.extdifff.b -side left
9867 grid x $top.extdifff $top.extdifft -sticky w
9869 label $top.cdisp -text [mc "Colors: press to choose"]
9870 grid $top.cdisp - -sticky w -pady 10
9871 label $top.bg -padx 40 -relief sunk -background $bgcolor
9872 button $top.bgbut -text [mc "Background"] -font optionfont \
9873 -command [list choosecolor bgcolor {} $top.bg background setbg]
9874 grid x $top.bgbut $top.bg -sticky w
9875 label $top.fg -padx 40 -relief sunk -background $fgcolor
9876 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9877 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9878 grid x $top.fgbut $top.fg -sticky w
9879 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9880 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9881 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9882 [list $ctext tag conf d0 -foreground]]
9883 grid x $top.diffoldbut $top.diffold -sticky w
9884 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9885 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9886 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9887 [list $ctext tag conf d1 -foreground]]
9888 grid x $top.diffnewbut $top.diffnew -sticky w
9889 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9890 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9891 -command [list choosecolor diffcolors 2 $top.hunksep \
9892 "diff hunk header" \
9893 [list $ctext tag conf hunksep -foreground]]
9894 grid x $top.hunksepbut $top.hunksep -sticky w
9895 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
9896 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
9897 -command [list choosecolor markbgcolor {} $top.markbgsep \
9898 [mc "marked line background"] \
9899 [list $ctext tag conf omark -background]]
9900 grid x $top.markbgbut $top.markbgsep -sticky w
9901 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9902 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9903 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9904 grid x $top.selbgbut $top.selbgsep -sticky w
9906 label $top.cfont -text [mc "Fonts: press to choose"]
9907 grid $top.cfont - -sticky w -pady 10
9908 mkfontdisp mainfont $top [mc "Main font"]
9909 mkfontdisp textfont $top [mc "Diff display font"]
9910 mkfontdisp uifont $top [mc "User interface font"]
9912 frame $top.buts
9913 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9914 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9915 bind $top <Key-Return> prefsok
9916 bind $top <Key-Escape> prefscan
9917 grid $top.buts.ok $top.buts.can
9918 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9919 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9920 grid $top.buts - - -pady 10 -sticky ew
9921 bind $top <Visibility> "focus $top.buts.ok"
9924 proc choose_extdiff {} {
9925 global extdifftool
9927 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9928 if {$prog ne {}} {
9929 set extdifftool $prog
9933 proc choosecolor {v vi w x cmd} {
9934 global $v
9936 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9937 -title [mc "Gitk: choose color for %s" $x]]
9938 if {$c eq {}} return
9939 $w conf -background $c
9940 lset $v $vi $c
9941 eval $cmd $c
9944 proc setselbg {c} {
9945 global bglist cflist
9946 foreach w $bglist {
9947 $w configure -selectbackground $c
9949 $cflist tag configure highlight \
9950 -background [$cflist cget -selectbackground]
9951 allcanvs itemconf secsel -fill $c
9954 proc setbg {c} {
9955 global bglist
9957 foreach w $bglist {
9958 $w conf -background $c
9962 proc setfg {c} {
9963 global fglist canv
9965 foreach w $fglist {
9966 $w conf -foreground $c
9968 allcanvs itemconf text -fill $c
9969 $canv itemconf circle -outline $c
9972 proc prefscan {} {
9973 global oldprefs prefstop
9975 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9976 limitdiffs tabstop perfile_attrs} {
9977 global $v
9978 set $v $oldprefs($v)
9980 catch {destroy $prefstop}
9981 unset prefstop
9982 fontcan
9985 proc prefsok {} {
9986 global maxwidth maxgraphpct
9987 global oldprefs prefstop showneartags showlocalchanges
9988 global fontpref mainfont textfont uifont
9989 global limitdiffs treediffs perfile_attrs
9991 catch {destroy $prefstop}
9992 unset prefstop
9993 fontcan
9994 set fontchanged 0
9995 if {$mainfont ne $fontpref(mainfont)} {
9996 set mainfont $fontpref(mainfont)
9997 parsefont mainfont $mainfont
9998 eval font configure mainfont [fontflags mainfont]
9999 eval font configure mainfontbold [fontflags mainfont 1]
10000 setcoords
10001 set fontchanged 1
10003 if {$textfont ne $fontpref(textfont)} {
10004 set textfont $fontpref(textfont)
10005 parsefont textfont $textfont
10006 eval font configure textfont [fontflags textfont]
10007 eval font configure textfontbold [fontflags textfont 1]
10009 if {$uifont ne $fontpref(uifont)} {
10010 set uifont $fontpref(uifont)
10011 parsefont uifont $uifont
10012 eval font configure uifont [fontflags uifont]
10014 settabs
10015 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10016 if {$showlocalchanges} {
10017 doshowlocalchanges
10018 } else {
10019 dohidelocalchanges
10022 if {$limitdiffs != $oldprefs(limitdiffs) ||
10023 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10024 # treediffs elements are limited by path;
10025 # won't have encodings cached if perfile_attrs was just turned on
10026 catch {unset treediffs}
10028 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10029 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10030 redisplay
10031 } elseif {$showneartags != $oldprefs(showneartags) ||
10032 $limitdiffs != $oldprefs(limitdiffs)} {
10033 reselectline
10037 proc formatdate {d} {
10038 global datetimeformat
10039 if {$d ne {}} {
10040 set d [clock format $d -format $datetimeformat]
10042 return $d
10045 # This list of encoding names and aliases is distilled from
10046 # http://www.iana.org/assignments/character-sets.
10047 # Not all of them are supported by Tcl.
10048 set encoding_aliases {
10049 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10050 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10051 { ISO-10646-UTF-1 csISO10646UTF1 }
10052 { ISO_646.basic:1983 ref csISO646basic1983 }
10053 { INVARIANT csINVARIANT }
10054 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10055 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10056 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10057 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10058 { NATS-DANO iso-ir-9-1 csNATSDANO }
10059 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10060 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10061 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10062 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10063 { ISO-2022-KR csISO2022KR }
10064 { EUC-KR csEUCKR }
10065 { ISO-2022-JP csISO2022JP }
10066 { ISO-2022-JP-2 csISO2022JP2 }
10067 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10068 csISO13JISC6220jp }
10069 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10070 { IT iso-ir-15 ISO646-IT csISO15Italian }
10071 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10072 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10073 { greek7-old iso-ir-18 csISO18Greek7Old }
10074 { latin-greek iso-ir-19 csISO19LatinGreek }
10075 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10076 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10077 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10078 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10079 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10080 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10081 { INIS iso-ir-49 csISO49INIS }
10082 { INIS-8 iso-ir-50 csISO50INIS8 }
10083 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10084 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10085 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10086 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10087 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10088 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10089 csISO60Norwegian1 }
10090 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10091 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10092 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10093 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10094 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10095 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10096 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10097 { greek7 iso-ir-88 csISO88Greek7 }
10098 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10099 { iso-ir-90 csISO90 }
10100 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10101 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10102 csISO92JISC62991984b }
10103 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10104 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10105 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10106 csISO95JIS62291984handadd }
10107 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10108 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10109 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10110 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10111 CP819 csISOLatin1 }
10112 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10113 { T.61-7bit iso-ir-102 csISO102T617bit }
10114 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10115 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10116 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10117 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10118 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10119 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10120 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10121 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10122 arabic csISOLatinArabic }
10123 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10124 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10125 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10126 greek greek8 csISOLatinGreek }
10127 { T.101-G2 iso-ir-128 csISO128T101G2 }
10128 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10129 csISOLatinHebrew }
10130 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10131 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10132 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10133 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10134 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10135 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10136 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10137 csISOLatinCyrillic }
10138 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10139 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10140 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10141 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10142 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10143 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10144 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10145 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10146 { ISO_10367-box iso-ir-155 csISO10367Box }
10147 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10148 { latin-lap lap iso-ir-158 csISO158Lap }
10149 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10150 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10151 { us-dk csUSDK }
10152 { dk-us csDKUS }
10153 { JIS_X0201 X0201 csHalfWidthKatakana }
10154 { KSC5636 ISO646-KR csKSC5636 }
10155 { ISO-10646-UCS-2 csUnicode }
10156 { ISO-10646-UCS-4 csUCS4 }
10157 { DEC-MCS dec csDECMCS }
10158 { hp-roman8 roman8 r8 csHPRoman8 }
10159 { macintosh mac csMacintosh }
10160 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10161 csIBM037 }
10162 { IBM038 EBCDIC-INT cp038 csIBM038 }
10163 { IBM273 CP273 csIBM273 }
10164 { IBM274 EBCDIC-BE CP274 csIBM274 }
10165 { IBM275 EBCDIC-BR cp275 csIBM275 }
10166 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10167 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10168 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10169 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10170 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10171 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10172 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10173 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10174 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10175 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10176 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10177 { IBM437 cp437 437 csPC8CodePage437 }
10178 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10179 { IBM775 cp775 csPC775Baltic }
10180 { IBM850 cp850 850 csPC850Multilingual }
10181 { IBM851 cp851 851 csIBM851 }
10182 { IBM852 cp852 852 csPCp852 }
10183 { IBM855 cp855 855 csIBM855 }
10184 { IBM857 cp857 857 csIBM857 }
10185 { IBM860 cp860 860 csIBM860 }
10186 { IBM861 cp861 861 cp-is csIBM861 }
10187 { IBM862 cp862 862 csPC862LatinHebrew }
10188 { IBM863 cp863 863 csIBM863 }
10189 { IBM864 cp864 csIBM864 }
10190 { IBM865 cp865 865 csIBM865 }
10191 { IBM866 cp866 866 csIBM866 }
10192 { IBM868 CP868 cp-ar csIBM868 }
10193 { IBM869 cp869 869 cp-gr csIBM869 }
10194 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10195 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10196 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10197 { IBM891 cp891 csIBM891 }
10198 { IBM903 cp903 csIBM903 }
10199 { IBM904 cp904 904 csIBBM904 }
10200 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10201 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10202 { IBM1026 CP1026 csIBM1026 }
10203 { EBCDIC-AT-DE csIBMEBCDICATDE }
10204 { EBCDIC-AT-DE-A csEBCDICATDEA }
10205 { EBCDIC-CA-FR csEBCDICCAFR }
10206 { EBCDIC-DK-NO csEBCDICDKNO }
10207 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10208 { EBCDIC-FI-SE csEBCDICFISE }
10209 { EBCDIC-FI-SE-A csEBCDICFISEA }
10210 { EBCDIC-FR csEBCDICFR }
10211 { EBCDIC-IT csEBCDICIT }
10212 { EBCDIC-PT csEBCDICPT }
10213 { EBCDIC-ES csEBCDICES }
10214 { EBCDIC-ES-A csEBCDICESA }
10215 { EBCDIC-ES-S csEBCDICESS }
10216 { EBCDIC-UK csEBCDICUK }
10217 { EBCDIC-US csEBCDICUS }
10218 { UNKNOWN-8BIT csUnknown8BiT }
10219 { MNEMONIC csMnemonic }
10220 { MNEM csMnem }
10221 { VISCII csVISCII }
10222 { VIQR csVIQR }
10223 { KOI8-R csKOI8R }
10224 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10225 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10226 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10227 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10228 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10229 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10230 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10231 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10232 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10233 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10234 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10235 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10236 { IBM1047 IBM-1047 }
10237 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10238 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10239 { UNICODE-1-1 csUnicode11 }
10240 { CESU-8 csCESU-8 }
10241 { BOCU-1 csBOCU-1 }
10242 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10243 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10244 l8 }
10245 { ISO-8859-15 ISO_8859-15 Latin-9 }
10246 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10247 { GBK CP936 MS936 windows-936 }
10248 { JIS_Encoding csJISEncoding }
10249 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10250 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10251 EUC-JP }
10252 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10253 { ISO-10646-UCS-Basic csUnicodeASCII }
10254 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10255 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10256 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10257 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10258 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10259 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10260 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10261 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10262 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10263 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10264 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10265 { Ventura-US csVenturaUS }
10266 { Ventura-International csVenturaInternational }
10267 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10268 { PC8-Turkish csPC8Turkish }
10269 { IBM-Symbols csIBMSymbols }
10270 { IBM-Thai csIBMThai }
10271 { HP-Legal csHPLegal }
10272 { HP-Pi-font csHPPiFont }
10273 { HP-Math8 csHPMath8 }
10274 { Adobe-Symbol-Encoding csHPPSMath }
10275 { HP-DeskTop csHPDesktop }
10276 { Ventura-Math csVenturaMath }
10277 { Microsoft-Publishing csMicrosoftPublishing }
10278 { Windows-31J csWindows31J }
10279 { GB2312 csGB2312 }
10280 { Big5 csBig5 }
10283 proc tcl_encoding {enc} {
10284 global encoding_aliases tcl_encoding_cache
10285 if {[info exists tcl_encoding_cache($enc)]} {
10286 return $tcl_encoding_cache($enc)
10288 set names [encoding names]
10289 set lcnames [string tolower $names]
10290 set enc [string tolower $enc]
10291 set i [lsearch -exact $lcnames $enc]
10292 if {$i < 0} {
10293 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10294 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10295 set i [lsearch -exact $lcnames $encx]
10298 if {$i < 0} {
10299 foreach l $encoding_aliases {
10300 set ll [string tolower $l]
10301 if {[lsearch -exact $ll $enc] < 0} continue
10302 # look through the aliases for one that tcl knows about
10303 foreach e $ll {
10304 set i [lsearch -exact $lcnames $e]
10305 if {$i < 0} {
10306 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10307 set i [lsearch -exact $lcnames $ex]
10310 if {$i >= 0} break
10312 break
10315 set tclenc {}
10316 if {$i >= 0} {
10317 set tclenc [lindex $names $i]
10319 set tcl_encoding_cache($enc) $tclenc
10320 return $tclenc
10323 proc gitattr {path attr default} {
10324 global path_attr_cache
10325 if {[info exists path_attr_cache($attr,$path)]} {
10326 set r $path_attr_cache($attr,$path)
10327 } else {
10328 set r "unspecified"
10329 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10330 regexp "(.*): encoding: (.*)" $line m f r
10332 set path_attr_cache($attr,$path) $r
10334 if {$r eq "unspecified"} {
10335 return $default
10337 return $r
10340 proc cache_gitattr {attr pathlist} {
10341 global path_attr_cache
10342 set newlist {}
10343 foreach path $pathlist {
10344 if {![info exists path_attr_cache($attr,$path)]} {
10345 lappend newlist $path
10348 set lim 1000
10349 if {[tk windowingsystem] == "win32"} {
10350 # windows has a 32k limit on the arguments to a command...
10351 set lim 30
10353 while {$newlist ne {}} {
10354 set head [lrange $newlist 0 [expr {$lim - 1}]]
10355 set newlist [lrange $newlist $lim end]
10356 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10357 foreach row [split $rlist "\n"] {
10358 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10359 if {[string index $path 0] eq "\""} {
10360 set path [encoding convertfrom [lindex $path 0]]
10362 set path_attr_cache($attr,$path) $value
10369 proc get_path_encoding {path} {
10370 global gui_encoding perfile_attrs
10371 set tcl_enc $gui_encoding
10372 if {$path ne {} && $perfile_attrs} {
10373 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10374 if {$enc2 ne {}} {
10375 set tcl_enc $enc2
10378 return $tcl_enc
10381 # First check that Tcl/Tk is recent enough
10382 if {[catch {package require Tk 8.4} err]} {
10383 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10384 Gitk requires at least Tcl/Tk 8.4."]
10385 exit 1
10388 # defaults...
10389 set wrcomcmd "git diff-tree --stdin -p --pretty"
10391 set gitencoding {}
10392 catch {
10393 set gitencoding [exec git config --get i18n.commitencoding]
10395 if {$gitencoding == ""} {
10396 set gitencoding "utf-8"
10398 set tclencoding [tcl_encoding $gitencoding]
10399 if {$tclencoding == {}} {
10400 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10403 set gui_encoding [encoding system]
10404 catch {
10405 set enc [exec git config --get gui.encoding]
10406 if {$enc ne {}} {
10407 set tclenc [tcl_encoding $enc]
10408 if {$tclenc ne {}} {
10409 set gui_encoding $tclenc
10410 } else {
10411 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10416 set mainfont {Helvetica 9}
10417 set textfont {Courier 9}
10418 set uifont {Helvetica 9 bold}
10419 set tabstop 8
10420 set findmergefiles 0
10421 set maxgraphpct 50
10422 set maxwidth 16
10423 set revlistorder 0
10424 set fastdate 0
10425 set uparrowlen 5
10426 set downarrowlen 5
10427 set mingaplen 100
10428 set cmitmode "patch"
10429 set wrapcomment "none"
10430 set showneartags 1
10431 set maxrefs 20
10432 set maxlinelen 200
10433 set showlocalchanges 1
10434 set limitdiffs 1
10435 set datetimeformat "%Y-%m-%d %H:%M:%S"
10436 set autoselect 1
10437 set perfile_attrs 0
10439 set extdifftool "meld"
10441 set colors {green red blue magenta darkgrey brown orange}
10442 set bgcolor white
10443 set fgcolor black
10444 set diffcolors {red "#00a000" blue}
10445 set diffcontext 3
10446 set ignorespace 0
10447 set selectbgcolor gray85
10448 set markbgcolor "#e0e0ff"
10450 set circlecolors {white blue gray blue blue}
10452 # button for popping up context menus
10453 if {[tk windowingsystem] eq "aqua"} {
10454 set ctxbut <Button-2>
10455 } else {
10456 set ctxbut <Button-3>
10459 ## For msgcat loading, first locate the installation location.
10460 if { [info exists ::env(GITK_MSGSDIR)] } {
10461 ## Msgsdir was manually set in the environment.
10462 set gitk_msgsdir $::env(GITK_MSGSDIR)
10463 } else {
10464 ## Let's guess the prefix from argv0.
10465 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10466 set gitk_libdir [file join $gitk_prefix share gitk lib]
10467 set gitk_msgsdir [file join $gitk_libdir msgs]
10468 unset gitk_prefix
10471 ## Internationalization (i18n) through msgcat and gettext. See
10472 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10473 package require msgcat
10474 namespace import ::msgcat::mc
10475 ## And eventually load the actual message catalog
10476 ::msgcat::mcload $gitk_msgsdir
10478 catch {source ~/.gitk}
10480 font create optionfont -family sans-serif -size -12
10482 parsefont mainfont $mainfont
10483 eval font create mainfont [fontflags mainfont]
10484 eval font create mainfontbold [fontflags mainfont 1]
10486 parsefont textfont $textfont
10487 eval font create textfont [fontflags textfont]
10488 eval font create textfontbold [fontflags textfont 1]
10490 parsefont uifont $uifont
10491 eval font create uifont [fontflags uifont]
10493 setoptions
10495 # check that we can find a .git directory somewhere...
10496 if {[catch {set gitdir [gitdir]}]} {
10497 show_error {} . [mc "Cannot find a git repository here."]
10498 exit 1
10500 if {![file isdirectory $gitdir]} {
10501 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10502 exit 1
10505 set selecthead {}
10506 set selectheadid {}
10508 set revtreeargs {}
10509 set cmdline_files {}
10510 set i 0
10511 set revtreeargscmd {}
10512 foreach arg $argv {
10513 switch -glob -- $arg {
10514 "" { }
10515 "--" {
10516 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10517 break
10519 "--select-commit=*" {
10520 set selecthead [string range $arg 16 end]
10522 "--argscmd=*" {
10523 set revtreeargscmd [string range $arg 10 end]
10525 default {
10526 lappend revtreeargs $arg
10529 incr i
10532 if {$selecthead eq "HEAD"} {
10533 set selecthead {}
10536 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10537 # no -- on command line, but some arguments (other than --argscmd)
10538 if {[catch {
10539 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10540 set cmdline_files [split $f "\n"]
10541 set n [llength $cmdline_files]
10542 set revtreeargs [lrange $revtreeargs 0 end-$n]
10543 # Unfortunately git rev-parse doesn't produce an error when
10544 # something is both a revision and a filename. To be consistent
10545 # with git log and git rev-list, check revtreeargs for filenames.
10546 foreach arg $revtreeargs {
10547 if {[file exists $arg]} {
10548 show_error {} . [mc "Ambiguous argument '%s': both revision\
10549 and filename" $arg]
10550 exit 1
10553 } err]} {
10554 # unfortunately we get both stdout and stderr in $err,
10555 # so look for "fatal:".
10556 set i [string first "fatal:" $err]
10557 if {$i > 0} {
10558 set err [string range $err [expr {$i + 6}] end]
10560 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10561 exit 1
10565 set nullid "0000000000000000000000000000000000000000"
10566 set nullid2 "0000000000000000000000000000000000000001"
10567 set nullfile "/dev/null"
10569 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10571 set runq {}
10572 set history {}
10573 set historyindex 0
10574 set fh_serial 0
10575 set nhl_names {}
10576 set highlight_paths {}
10577 set findpattern {}
10578 set searchdirn -forwards
10579 set boldrows {}
10580 set boldnamerows {}
10581 set diffelide {0 0}
10582 set markingmatches 0
10583 set linkentercount 0
10584 set need_redisplay 0
10585 set nrows_drawn 0
10586 set firsttabstop 0
10588 set nextviewnum 1
10589 set curview 0
10590 set selectedview 0
10591 set selectedhlview [mc "None"]
10592 set highlight_related [mc "None"]
10593 set highlight_files {}
10594 set viewfiles(0) {}
10595 set viewperm(0) 0
10596 set viewargs(0) {}
10597 set viewargscmd(0) {}
10599 set selectedline {}
10600 set numcommits 0
10601 set loginstance 0
10602 set cmdlineok 0
10603 set stopped 0
10604 set stuffsaved 0
10605 set patchnum 0
10606 set lserial 0
10607 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10608 setcoords
10609 makewindow
10610 # wait for the window to become visible
10611 tkwait visibility .
10612 wm title . "[file tail $argv0]: [file tail [pwd]]"
10613 readrefs
10615 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10616 # create a view for the files/dirs specified on the command line
10617 set curview 1
10618 set selectedview 1
10619 set nextviewnum 2
10620 set viewname(1) [mc "Command line"]
10621 set viewfiles(1) $cmdline_files
10622 set viewargs(1) $revtreeargs
10623 set viewargscmd(1) $revtreeargscmd
10624 set viewperm(1) 0
10625 set vdatemode(1) 0
10626 addviewmenu 1
10627 .bar.view entryconf [mca "Edit view..."] -state normal
10628 .bar.view entryconf [mca "Delete view"] -state normal
10631 if {[info exists permviews]} {
10632 foreach v $permviews {
10633 set n $nextviewnum
10634 incr nextviewnum
10635 set viewname($n) [lindex $v 0]
10636 set viewfiles($n) [lindex $v 1]
10637 set viewargs($n) [lindex $v 2]
10638 set viewargscmd($n) [lindex $v 3]
10639 set viewperm($n) 1
10640 addviewmenu $n
10643 getcommits {}