Merge branch 'ml/http'
[tgit.git] / gitk-git / gitk
blob4604c831fe0c5ac9b855cdef6f71888e99dd9462
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
183 lappend glflags $arg
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
191 "--simplify-by-decoration" {
192 # These mean that we get a subset of the commits
193 set filtered 1
194 lappend glflags $arg
196 "-n" {
197 # This appears to be the only one that has a value as a
198 # separate word following it
199 set filtered 1
200 set nextisval 1
201 lappend glflags $arg
203 "--not" - "--all" {
204 lappend revargs $arg
206 "--merge" {
207 set vmergeonly($n) 1
208 # git rev-parse doesn't understand --merge
209 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
211 "-*" {
212 # Other flag arguments including -<n>
213 if {[string is digit -strict [string range $arg 1 end]]} {
214 set filtered 1
215 } else {
216 # a flag argument that we don't recognize;
217 # that means we can't optimize
218 set allknown 0
220 lappend glflags $arg
222 default {
223 # Non-flag arguments specify commits or ranges of commits
224 if {[string match "*...*" $arg]} {
225 lappend revargs --gitk-symmetric-diff-marker
227 lappend revargs $arg
231 set vdflags($n) $diffargs
232 set vflags($n) $glflags
233 set vrevs($n) $revargs
234 set vfiltered($n) $filtered
235 set vorigargs($n) $origargs
236 return $allknown
239 proc parseviewrevs {view revs} {
240 global vposids vnegids
242 if {$revs eq {}} {
243 set revs HEAD
245 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
246 # we get stdout followed by stderr in $err
247 # for an unknown rev, git rev-parse echoes it and then errors out
248 set errlines [split $err "\n"]
249 set badrev {}
250 for {set l 0} {$l < [llength $errlines]} {incr l} {
251 set line [lindex $errlines $l]
252 if {!([string length $line] == 40 && [string is xdigit $line])} {
253 if {[string match "fatal:*" $line]} {
254 if {[string match "fatal: ambiguous argument*" $line]
255 && $badrev ne {}} {
256 if {[llength $badrev] == 1} {
257 set err "unknown revision $badrev"
258 } else {
259 set err "unknown revisions: [join $badrev ", "]"
261 } else {
262 set err [join [lrange $errlines $l end] "\n"]
264 break
266 lappend badrev $line
269 error_popup "[mc "Error parsing revisions:"] $err"
270 return {}
272 set ret {}
273 set pos {}
274 set neg {}
275 set sdm 0
276 foreach id [split $ids "\n"] {
277 if {$id eq "--gitk-symmetric-diff-marker"} {
278 set sdm 4
279 } elseif {[string match "^*" $id]} {
280 if {$sdm != 1} {
281 lappend ret $id
282 if {$sdm == 3} {
283 set sdm 0
286 lappend neg [string range $id 1 end]
287 } else {
288 if {$sdm != 2} {
289 lappend ret $id
290 } else {
291 lset ret end [lindex $ret end]...$id
293 lappend pos $id
295 incr sdm -1
297 set vposids($view) $pos
298 set vnegids($view) $neg
299 return $ret
302 # Start off a git log process and arrange to read its output
303 proc start_rev_list {view} {
304 global startmsecs commitidx viewcomplete curview
305 global tclencoding
306 global viewargs viewargscmd viewfiles vfilelimit
307 global showlocalchanges
308 global viewactive viewinstances vmergeonly
309 global mainheadid viewmainheadid viewmainheadid_orig
310 global vcanopt vflags vrevs vorigargs
312 set startmsecs [clock clicks -milliseconds]
313 set commitidx($view) 0
314 # these are set this way for the error exits
315 set viewcomplete($view) 1
316 set viewactive($view) 0
317 varcinit $view
319 set args $viewargs($view)
320 if {$viewargscmd($view) ne {}} {
321 if {[catch {
322 set str [exec sh -c $viewargscmd($view)]
323 } err]} {
324 error_popup "[mc "Error executing --argscmd command:"] $err"
325 return 0
327 set args [concat $args [split $str "\n"]]
329 set vcanopt($view) [parseviewargs $view $args]
331 set files $viewfiles($view)
332 if {$vmergeonly($view)} {
333 set files [unmerged_files $files]
334 if {$files eq {}} {
335 global nr_unmerged
336 if {$nr_unmerged == 0} {
337 error_popup [mc "No files selected: --merge specified but\
338 no files are unmerged."]
339 } else {
340 error_popup [mc "No files selected: --merge specified but\
341 no unmerged files are within file limit."]
343 return 0
346 set vfilelimit($view) $files
348 if {$vcanopt($view)} {
349 set revs [parseviewrevs $view $vrevs($view)]
350 if {$revs eq {}} {
351 return 0
353 set args [concat $vflags($view) $revs]
354 } else {
355 set args $vorigargs($view)
358 if {[catch {
359 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
360 --boundary $args "--" $files] r]
361 } err]} {
362 error_popup "[mc "Error executing git log:"] $err"
363 return 0
365 set i [reg_instance $fd]
366 set viewinstances($view) [list $i]
367 set viewmainheadid($view) $mainheadid
368 set viewmainheadid_orig($view) $mainheadid
369 if {$files ne {} && $mainheadid ne {}} {
370 get_viewmainhead $view
372 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
373 interestedin $viewmainheadid($view) dodiffindex
375 fconfigure $fd -blocking 0 -translation lf -eofchar {}
376 if {$tclencoding != {}} {
377 fconfigure $fd -encoding $tclencoding
379 filerun $fd [list getcommitlines $fd $i $view 0]
380 nowbusy $view [mc "Reading"]
381 set viewcomplete($view) 0
382 set viewactive($view) 1
383 return 1
386 proc stop_instance {inst} {
387 global commfd leftover
389 set fd $commfd($inst)
390 catch {
391 set pid [pid $fd]
393 if {$::tcl_platform(platform) eq {windows}} {
394 exec kill -f $pid
395 } else {
396 exec kill $pid
399 catch {close $fd}
400 nukefile $fd
401 unset commfd($inst)
402 unset leftover($inst)
405 proc stop_backends {} {
406 global commfd
408 foreach inst [array names commfd] {
409 stop_instance $inst
413 proc stop_rev_list {view} {
414 global viewinstances
416 foreach inst $viewinstances($view) {
417 stop_instance $inst
419 set viewinstances($view) {}
422 proc reset_pending_select {selid} {
423 global pending_select mainheadid selectheadid
425 if {$selid ne {}} {
426 set pending_select $selid
427 } elseif {$selectheadid ne {}} {
428 set pending_select $selectheadid
429 } else {
430 set pending_select $mainheadid
434 proc getcommits {selid} {
435 global canv curview need_redisplay viewactive
437 initlayout
438 if {[start_rev_list $curview]} {
439 reset_pending_select $selid
440 show_status [mc "Reading commits..."]
441 set need_redisplay 1
442 } else {
443 show_status [mc "No commits selected"]
447 proc updatecommits {} {
448 global curview vcanopt vorigargs vfilelimit viewinstances
449 global viewactive viewcomplete tclencoding
450 global startmsecs showneartags showlocalchanges
451 global mainheadid viewmainheadid viewmainheadid_orig pending_select
452 global isworktree
453 global varcid vposids vnegids vflags vrevs
455 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
456 rereadrefs
457 set view $curview
458 if {$mainheadid ne $viewmainheadid_orig($view)} {
459 if {$showlocalchanges} {
460 dohidelocalchanges
462 set viewmainheadid($view) $mainheadid
463 set viewmainheadid_orig($view) $mainheadid
464 if {$vfilelimit($view) ne {}} {
465 get_viewmainhead $view
468 if {$showlocalchanges} {
469 doshowlocalchanges
471 if {$vcanopt($view)} {
472 set oldpos $vposids($view)
473 set oldneg $vnegids($view)
474 set revs [parseviewrevs $view $vrevs($view)]
475 if {$revs eq {}} {
476 return
478 # note: getting the delta when negative refs change is hard,
479 # and could require multiple git log invocations, so in that
480 # case we ask git log for all the commits (not just the delta)
481 if {$oldneg eq $vnegids($view)} {
482 set newrevs {}
483 set npos 0
484 # take out positive refs that we asked for before or
485 # that we have already seen
486 foreach rev $revs {
487 if {[string length $rev] == 40} {
488 if {[lsearch -exact $oldpos $rev] < 0
489 && ![info exists varcid($view,$rev)]} {
490 lappend newrevs $rev
491 incr npos
493 } else {
494 lappend $newrevs $rev
497 if {$npos == 0} return
498 set revs $newrevs
499 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
501 set args [concat $vflags($view) $revs --not $oldpos]
502 } else {
503 set args $vorigargs($view)
505 if {[catch {
506 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
507 --boundary $args "--" $vfilelimit($view)] r]
508 } err]} {
509 error_popup "[mc "Error executing git log:"] $err"
510 return
512 if {$viewactive($view) == 0} {
513 set startmsecs [clock clicks -milliseconds]
515 set i [reg_instance $fd]
516 lappend viewinstances($view) $i
517 fconfigure $fd -blocking 0 -translation lf -eofchar {}
518 if {$tclencoding != {}} {
519 fconfigure $fd -encoding $tclencoding
521 filerun $fd [list getcommitlines $fd $i $view 1]
522 incr viewactive($view)
523 set viewcomplete($view) 0
524 reset_pending_select {}
525 nowbusy $view [mc "Reading"]
526 if {$showneartags} {
527 getallcommits
531 proc reloadcommits {} {
532 global curview viewcomplete selectedline currentid thickerline
533 global showneartags treediffs commitinterest cached_commitrow
534 global targetid
536 set selid {}
537 if {$selectedline ne {}} {
538 set selid $currentid
541 if {!$viewcomplete($curview)} {
542 stop_rev_list $curview
544 resetvarcs $curview
545 set selectedline {}
546 catch {unset currentid}
547 catch {unset thickerline}
548 catch {unset treediffs}
549 readrefs
550 changedrefs
551 if {$showneartags} {
552 getallcommits
554 clear_display
555 catch {unset commitinterest}
556 catch {unset cached_commitrow}
557 catch {unset targetid}
558 setcanvscroll
559 getcommits $selid
560 return 0
563 # This makes a string representation of a positive integer which
564 # sorts as a string in numerical order
565 proc strrep {n} {
566 if {$n < 16} {
567 return [format "%x" $n]
568 } elseif {$n < 256} {
569 return [format "x%.2x" $n]
570 } elseif {$n < 65536} {
571 return [format "y%.4x" $n]
573 return [format "z%.8x" $n]
576 # Procedures used in reordering commits from git log (without
577 # --topo-order) into the order for display.
579 proc varcinit {view} {
580 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
581 global vtokmod varcmod vrowmod varcix vlastins
583 set varcstart($view) {{}}
584 set vupptr($view) {0}
585 set vdownptr($view) {0}
586 set vleftptr($view) {0}
587 set vbackptr($view) {0}
588 set varctok($view) {{}}
589 set varcrow($view) {{}}
590 set vtokmod($view) {}
591 set varcmod($view) 0
592 set vrowmod($view) 0
593 set varcix($view) {{}}
594 set vlastins($view) {0}
597 proc resetvarcs {view} {
598 global varcid varccommits parents children vseedcount ordertok
600 foreach vid [array names varcid $view,*] {
601 unset varcid($vid)
602 unset children($vid)
603 unset parents($vid)
605 # some commits might have children but haven't been seen yet
606 foreach vid [array names children $view,*] {
607 unset children($vid)
609 foreach va [array names varccommits $view,*] {
610 unset varccommits($va)
612 foreach vd [array names vseedcount $view,*] {
613 unset vseedcount($vd)
615 catch {unset ordertok}
618 # returns a list of the commits with no children
619 proc seeds {v} {
620 global vdownptr vleftptr varcstart
622 set ret {}
623 set a [lindex $vdownptr($v) 0]
624 while {$a != 0} {
625 lappend ret [lindex $varcstart($v) $a]
626 set a [lindex $vleftptr($v) $a]
628 return $ret
631 proc newvarc {view id} {
632 global varcid varctok parents children vdatemode
633 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
634 global commitdata commitinfo vseedcount varccommits vlastins
636 set a [llength $varctok($view)]
637 set vid $view,$id
638 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
639 if {![info exists commitinfo($id)]} {
640 parsecommit $id $commitdata($id) 1
642 set cdate [lindex $commitinfo($id) 4]
643 if {![string is integer -strict $cdate]} {
644 set cdate 0
646 if {![info exists vseedcount($view,$cdate)]} {
647 set vseedcount($view,$cdate) -1
649 set c [incr vseedcount($view,$cdate)]
650 set cdate [expr {$cdate ^ 0xffffffff}]
651 set tok "s[strrep $cdate][strrep $c]"
652 } else {
653 set tok {}
655 set ka 0
656 if {[llength $children($vid)] > 0} {
657 set kid [lindex $children($vid) end]
658 set k $varcid($view,$kid)
659 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
660 set ki $kid
661 set ka $k
662 set tok [lindex $varctok($view) $k]
665 if {$ka != 0} {
666 set i [lsearch -exact $parents($view,$ki) $id]
667 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
668 append tok [strrep $j]
670 set c [lindex $vlastins($view) $ka]
671 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
672 set c $ka
673 set b [lindex $vdownptr($view) $ka]
674 } else {
675 set b [lindex $vleftptr($view) $c]
677 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
678 set c $b
679 set b [lindex $vleftptr($view) $c]
681 if {$c == $ka} {
682 lset vdownptr($view) $ka $a
683 lappend vbackptr($view) 0
684 } else {
685 lset vleftptr($view) $c $a
686 lappend vbackptr($view) $c
688 lset vlastins($view) $ka $a
689 lappend vupptr($view) $ka
690 lappend vleftptr($view) $b
691 if {$b != 0} {
692 lset vbackptr($view) $b $a
694 lappend varctok($view) $tok
695 lappend varcstart($view) $id
696 lappend vdownptr($view) 0
697 lappend varcrow($view) {}
698 lappend varcix($view) {}
699 set varccommits($view,$a) {}
700 lappend vlastins($view) 0
701 return $a
704 proc splitvarc {p v} {
705 global varcid varcstart varccommits varctok vtokmod
706 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
708 set oa $varcid($v,$p)
709 set otok [lindex $varctok($v) $oa]
710 set ac $varccommits($v,$oa)
711 set i [lsearch -exact $varccommits($v,$oa) $p]
712 if {$i <= 0} return
713 set na [llength $varctok($v)]
714 # "%" sorts before "0"...
715 set tok "$otok%[strrep $i]"
716 lappend varctok($v) $tok
717 lappend varcrow($v) {}
718 lappend varcix($v) {}
719 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
720 set varccommits($v,$na) [lrange $ac $i end]
721 lappend varcstart($v) $p
722 foreach id $varccommits($v,$na) {
723 set varcid($v,$id) $na
725 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
726 lappend vlastins($v) [lindex $vlastins($v) $oa]
727 lset vdownptr($v) $oa $na
728 lset vlastins($v) $oa 0
729 lappend vupptr($v) $oa
730 lappend vleftptr($v) 0
731 lappend vbackptr($v) 0
732 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
733 lset vupptr($v) $b $na
735 if {[string compare $otok $vtokmod($v)] <= 0} {
736 modify_arc $v $oa
740 proc renumbervarc {a v} {
741 global parents children varctok varcstart varccommits
742 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
744 set t1 [clock clicks -milliseconds]
745 set todo {}
746 set isrelated($a) 1
747 set kidchanged($a) 1
748 set ntot 0
749 while {$a != 0} {
750 if {[info exists isrelated($a)]} {
751 lappend todo $a
752 set id [lindex $varccommits($v,$a) end]
753 foreach p $parents($v,$id) {
754 if {[info exists varcid($v,$p)]} {
755 set isrelated($varcid($v,$p)) 1
759 incr ntot
760 set b [lindex $vdownptr($v) $a]
761 if {$b == 0} {
762 while {$a != 0} {
763 set b [lindex $vleftptr($v) $a]
764 if {$b != 0} break
765 set a [lindex $vupptr($v) $a]
768 set a $b
770 foreach a $todo {
771 if {![info exists kidchanged($a)]} continue
772 set id [lindex $varcstart($v) $a]
773 if {[llength $children($v,$id)] > 1} {
774 set children($v,$id) [lsort -command [list vtokcmp $v] \
775 $children($v,$id)]
777 set oldtok [lindex $varctok($v) $a]
778 if {!$vdatemode($v)} {
779 set tok {}
780 } else {
781 set tok $oldtok
783 set ka 0
784 set kid [last_real_child $v,$id]
785 if {$kid ne {}} {
786 set k $varcid($v,$kid)
787 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
788 set ki $kid
789 set ka $k
790 set tok [lindex $varctok($v) $k]
793 if {$ka != 0} {
794 set i [lsearch -exact $parents($v,$ki) $id]
795 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
796 append tok [strrep $j]
798 if {$tok eq $oldtok} {
799 continue
801 set id [lindex $varccommits($v,$a) end]
802 foreach p $parents($v,$id) {
803 if {[info exists varcid($v,$p)]} {
804 set kidchanged($varcid($v,$p)) 1
805 } else {
806 set sortkids($p) 1
809 lset varctok($v) $a $tok
810 set b [lindex $vupptr($v) $a]
811 if {$b != $ka} {
812 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
813 modify_arc $v $ka
815 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
816 modify_arc $v $b
818 set c [lindex $vbackptr($v) $a]
819 set d [lindex $vleftptr($v) $a]
820 if {$c == 0} {
821 lset vdownptr($v) $b $d
822 } else {
823 lset vleftptr($v) $c $d
825 if {$d != 0} {
826 lset vbackptr($v) $d $c
828 if {[lindex $vlastins($v) $b] == $a} {
829 lset vlastins($v) $b $c
831 lset vupptr($v) $a $ka
832 set c [lindex $vlastins($v) $ka]
833 if {$c == 0 || \
834 [string compare $tok [lindex $varctok($v) $c]] < 0} {
835 set c $ka
836 set b [lindex $vdownptr($v) $ka]
837 } else {
838 set b [lindex $vleftptr($v) $c]
840 while {$b != 0 && \
841 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
842 set c $b
843 set b [lindex $vleftptr($v) $c]
845 if {$c == $ka} {
846 lset vdownptr($v) $ka $a
847 lset vbackptr($v) $a 0
848 } else {
849 lset vleftptr($v) $c $a
850 lset vbackptr($v) $a $c
852 lset vleftptr($v) $a $b
853 if {$b != 0} {
854 lset vbackptr($v) $b $a
856 lset vlastins($v) $ka $a
859 foreach id [array names sortkids] {
860 if {[llength $children($v,$id)] > 1} {
861 set children($v,$id) [lsort -command [list vtokcmp $v] \
862 $children($v,$id)]
865 set t2 [clock clicks -milliseconds]
866 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
869 # Fix up the graph after we have found out that in view $v,
870 # $p (a commit that we have already seen) is actually the parent
871 # of the last commit in arc $a.
872 proc fix_reversal {p a v} {
873 global varcid varcstart varctok vupptr
875 set pa $varcid($v,$p)
876 if {$p ne [lindex $varcstart($v) $pa]} {
877 splitvarc $p $v
878 set pa $varcid($v,$p)
880 # seeds always need to be renumbered
881 if {[lindex $vupptr($v) $pa] == 0 ||
882 [string compare [lindex $varctok($v) $a] \
883 [lindex $varctok($v) $pa]] > 0} {
884 renumbervarc $pa $v
888 proc insertrow {id p v} {
889 global cmitlisted children parents varcid varctok vtokmod
890 global varccommits ordertok commitidx numcommits curview
891 global targetid targetrow
893 readcommit $id
894 set vid $v,$id
895 set cmitlisted($vid) 1
896 set children($vid) {}
897 set parents($vid) [list $p]
898 set a [newvarc $v $id]
899 set varcid($vid) $a
900 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
901 modify_arc $v $a
903 lappend varccommits($v,$a) $id
904 set vp $v,$p
905 if {[llength [lappend children($vp) $id]] > 1} {
906 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
907 catch {unset ordertok}
909 fix_reversal $p $a $v
910 incr commitidx($v)
911 if {$v == $curview} {
912 set numcommits $commitidx($v)
913 setcanvscroll
914 if {[info exists targetid]} {
915 if {![comes_before $targetid $p]} {
916 incr targetrow
922 proc insertfakerow {id p} {
923 global varcid varccommits parents children cmitlisted
924 global commitidx varctok vtokmod targetid targetrow curview numcommits
926 set v $curview
927 set a $varcid($v,$p)
928 set i [lsearch -exact $varccommits($v,$a) $p]
929 if {$i < 0} {
930 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
931 return
933 set children($v,$id) {}
934 set parents($v,$id) [list $p]
935 set varcid($v,$id) $a
936 lappend children($v,$p) $id
937 set cmitlisted($v,$id) 1
938 set numcommits [incr commitidx($v)]
939 # note we deliberately don't update varcstart($v) even if $i == 0
940 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
941 modify_arc $v $a $i
942 if {[info exists targetid]} {
943 if {![comes_before $targetid $p]} {
944 incr targetrow
947 setcanvscroll
948 drawvisible
951 proc removefakerow {id} {
952 global varcid varccommits parents children commitidx
953 global varctok vtokmod cmitlisted currentid selectedline
954 global targetid curview numcommits
956 set v $curview
957 if {[llength $parents($v,$id)] != 1} {
958 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
959 return
961 set p [lindex $parents($v,$id) 0]
962 set a $varcid($v,$id)
963 set i [lsearch -exact $varccommits($v,$a) $id]
964 if {$i < 0} {
965 puts "oops: removefakerow can't find [shortids $id] on arc $a"
966 return
968 unset varcid($v,$id)
969 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
970 unset parents($v,$id)
971 unset children($v,$id)
972 unset cmitlisted($v,$id)
973 set numcommits [incr commitidx($v) -1]
974 set j [lsearch -exact $children($v,$p) $id]
975 if {$j >= 0} {
976 set children($v,$p) [lreplace $children($v,$p) $j $j]
978 modify_arc $v $a $i
979 if {[info exist currentid] && $id eq $currentid} {
980 unset currentid
981 set selectedline {}
983 if {[info exists targetid] && $targetid eq $id} {
984 set targetid $p
986 setcanvscroll
987 drawvisible
990 proc first_real_child {vp} {
991 global children nullid nullid2
993 foreach id $children($vp) {
994 if {$id ne $nullid && $id ne $nullid2} {
995 return $id
998 return {}
1001 proc last_real_child {vp} {
1002 global children nullid nullid2
1004 set kids $children($vp)
1005 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1006 set id [lindex $kids $i]
1007 if {$id ne $nullid && $id ne $nullid2} {
1008 return $id
1011 return {}
1014 proc vtokcmp {v a b} {
1015 global varctok varcid
1017 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1018 [lindex $varctok($v) $varcid($v,$b)]]
1021 # This assumes that if lim is not given, the caller has checked that
1022 # arc a's token is less than $vtokmod($v)
1023 proc modify_arc {v a {lim {}}} {
1024 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1026 if {$lim ne {}} {
1027 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1028 if {$c > 0} return
1029 if {$c == 0} {
1030 set r [lindex $varcrow($v) $a]
1031 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1034 set vtokmod($v) [lindex $varctok($v) $a]
1035 set varcmod($v) $a
1036 if {$v == $curview} {
1037 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1038 set a [lindex $vupptr($v) $a]
1039 set lim {}
1041 set r 0
1042 if {$a != 0} {
1043 if {$lim eq {}} {
1044 set lim [llength $varccommits($v,$a)]
1046 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1048 set vrowmod($v) $r
1049 undolayout $r
1053 proc update_arcrows {v} {
1054 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1055 global varcid vrownum varcorder varcix varccommits
1056 global vupptr vdownptr vleftptr varctok
1057 global displayorder parentlist curview cached_commitrow
1059 if {$vrowmod($v) == $commitidx($v)} return
1060 if {$v == $curview} {
1061 if {[llength $displayorder] > $vrowmod($v)} {
1062 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1063 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1065 catch {unset cached_commitrow}
1067 set narctot [expr {[llength $varctok($v)] - 1}]
1068 set a $varcmod($v)
1069 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1070 # go up the tree until we find something that has a row number,
1071 # or we get to a seed
1072 set a [lindex $vupptr($v) $a]
1074 if {$a == 0} {
1075 set a [lindex $vdownptr($v) 0]
1076 if {$a == 0} return
1077 set vrownum($v) {0}
1078 set varcorder($v) [list $a]
1079 lset varcix($v) $a 0
1080 lset varcrow($v) $a 0
1081 set arcn 0
1082 set row 0
1083 } else {
1084 set arcn [lindex $varcix($v) $a]
1085 if {[llength $vrownum($v)] > $arcn + 1} {
1086 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1087 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1089 set row [lindex $varcrow($v) $a]
1091 while {1} {
1092 set p $a
1093 incr row [llength $varccommits($v,$a)]
1094 # go down if possible
1095 set b [lindex $vdownptr($v) $a]
1096 if {$b == 0} {
1097 # if not, go left, or go up until we can go left
1098 while {$a != 0} {
1099 set b [lindex $vleftptr($v) $a]
1100 if {$b != 0} break
1101 set a [lindex $vupptr($v) $a]
1103 if {$a == 0} break
1105 set a $b
1106 incr arcn
1107 lappend vrownum($v) $row
1108 lappend varcorder($v) $a
1109 lset varcix($v) $a $arcn
1110 lset varcrow($v) $a $row
1112 set vtokmod($v) [lindex $varctok($v) $p]
1113 set varcmod($v) $p
1114 set vrowmod($v) $row
1115 if {[info exists currentid]} {
1116 set selectedline [rowofcommit $currentid]
1120 # Test whether view $v contains commit $id
1121 proc commitinview {id v} {
1122 global varcid
1124 return [info exists varcid($v,$id)]
1127 # Return the row number for commit $id in the current view
1128 proc rowofcommit {id} {
1129 global varcid varccommits varcrow curview cached_commitrow
1130 global varctok vtokmod
1132 set v $curview
1133 if {![info exists varcid($v,$id)]} {
1134 puts "oops rowofcommit no arc for [shortids $id]"
1135 return {}
1137 set a $varcid($v,$id)
1138 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1139 update_arcrows $v
1141 if {[info exists cached_commitrow($id)]} {
1142 return $cached_commitrow($id)
1144 set i [lsearch -exact $varccommits($v,$a) $id]
1145 if {$i < 0} {
1146 puts "oops didn't find commit [shortids $id] in arc $a"
1147 return {}
1149 incr i [lindex $varcrow($v) $a]
1150 set cached_commitrow($id) $i
1151 return $i
1154 # Returns 1 if a is on an earlier row than b, otherwise 0
1155 proc comes_before {a b} {
1156 global varcid varctok curview
1158 set v $curview
1159 if {$a eq $b || ![info exists varcid($v,$a)] || \
1160 ![info exists varcid($v,$b)]} {
1161 return 0
1163 if {$varcid($v,$a) != $varcid($v,$b)} {
1164 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1165 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1167 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1170 proc bsearch {l elt} {
1171 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1172 return 0
1174 set lo 0
1175 set hi [llength $l]
1176 while {$hi - $lo > 1} {
1177 set mid [expr {int(($lo + $hi) / 2)}]
1178 set t [lindex $l $mid]
1179 if {$elt < $t} {
1180 set hi $mid
1181 } elseif {$elt > $t} {
1182 set lo $mid
1183 } else {
1184 return $mid
1187 return $lo
1190 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1191 proc make_disporder {start end} {
1192 global vrownum curview commitidx displayorder parentlist
1193 global varccommits varcorder parents vrowmod varcrow
1194 global d_valid_start d_valid_end
1196 if {$end > $vrowmod($curview)} {
1197 update_arcrows $curview
1199 set ai [bsearch $vrownum($curview) $start]
1200 set start [lindex $vrownum($curview) $ai]
1201 set narc [llength $vrownum($curview)]
1202 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1203 set a [lindex $varcorder($curview) $ai]
1204 set l [llength $displayorder]
1205 set al [llength $varccommits($curview,$a)]
1206 if {$l < $r + $al} {
1207 if {$l < $r} {
1208 set pad [ntimes [expr {$r - $l}] {}]
1209 set displayorder [concat $displayorder $pad]
1210 set parentlist [concat $parentlist $pad]
1211 } elseif {$l > $r} {
1212 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1213 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1215 foreach id $varccommits($curview,$a) {
1216 lappend displayorder $id
1217 lappend parentlist $parents($curview,$id)
1219 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1220 set i $r
1221 foreach id $varccommits($curview,$a) {
1222 lset displayorder $i $id
1223 lset parentlist $i $parents($curview,$id)
1224 incr i
1227 incr r $al
1231 proc commitonrow {row} {
1232 global displayorder
1234 set id [lindex $displayorder $row]
1235 if {$id eq {}} {
1236 make_disporder $row [expr {$row + 1}]
1237 set id [lindex $displayorder $row]
1239 return $id
1242 proc closevarcs {v} {
1243 global varctok varccommits varcid parents children
1244 global cmitlisted commitidx vtokmod
1246 set missing_parents 0
1247 set scripts {}
1248 set narcs [llength $varctok($v)]
1249 for {set a 1} {$a < $narcs} {incr a} {
1250 set id [lindex $varccommits($v,$a) end]
1251 foreach p $parents($v,$id) {
1252 if {[info exists varcid($v,$p)]} continue
1253 # add p as a new commit
1254 incr missing_parents
1255 set cmitlisted($v,$p) 0
1256 set parents($v,$p) {}
1257 if {[llength $children($v,$p)] == 1 &&
1258 [llength $parents($v,$id)] == 1} {
1259 set b $a
1260 } else {
1261 set b [newvarc $v $p]
1263 set varcid($v,$p) $b
1264 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1265 modify_arc $v $b
1267 lappend varccommits($v,$b) $p
1268 incr commitidx($v)
1269 set scripts [check_interest $p $scripts]
1272 if {$missing_parents > 0} {
1273 foreach s $scripts {
1274 eval $s
1279 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1280 # Assumes we already have an arc for $rwid.
1281 proc rewrite_commit {v id rwid} {
1282 global children parents varcid varctok vtokmod varccommits
1284 foreach ch $children($v,$id) {
1285 # make $rwid be $ch's parent in place of $id
1286 set i [lsearch -exact $parents($v,$ch) $id]
1287 if {$i < 0} {
1288 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1290 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1291 # add $ch to $rwid's children and sort the list if necessary
1292 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1293 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1294 $children($v,$rwid)]
1296 # fix the graph after joining $id to $rwid
1297 set a $varcid($v,$ch)
1298 fix_reversal $rwid $a $v
1299 # parentlist is wrong for the last element of arc $a
1300 # even if displayorder is right, hence the 3rd arg here
1301 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1305 # Mechanism for registering a command to be executed when we come
1306 # across a particular commit. To handle the case when only the
1307 # prefix of the commit is known, the commitinterest array is now
1308 # indexed by the first 4 characters of the ID. Each element is a
1309 # list of id, cmd pairs.
1310 proc interestedin {id cmd} {
1311 global commitinterest
1313 lappend commitinterest([string range $id 0 3]) $id $cmd
1316 proc check_interest {id scripts} {
1317 global commitinterest
1319 set prefix [string range $id 0 3]
1320 if {[info exists commitinterest($prefix)]} {
1321 set newlist {}
1322 foreach {i script} $commitinterest($prefix) {
1323 if {[string match "$i*" $id]} {
1324 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1325 } else {
1326 lappend newlist $i $script
1329 if {$newlist ne {}} {
1330 set commitinterest($prefix) $newlist
1331 } else {
1332 unset commitinterest($prefix)
1335 return $scripts
1338 proc getcommitlines {fd inst view updating} {
1339 global cmitlisted leftover
1340 global commitidx commitdata vdatemode
1341 global parents children curview hlview
1342 global idpending ordertok
1343 global varccommits varcid varctok vtokmod vfilelimit
1345 set stuff [read $fd 500000]
1346 # git log doesn't terminate the last commit with a null...
1347 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1348 set stuff "\0"
1350 if {$stuff == {}} {
1351 if {![eof $fd]} {
1352 return 1
1354 global commfd viewcomplete viewactive viewname
1355 global viewinstances
1356 unset commfd($inst)
1357 set i [lsearch -exact $viewinstances($view) $inst]
1358 if {$i >= 0} {
1359 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1361 # set it blocking so we wait for the process to terminate
1362 fconfigure $fd -blocking 1
1363 if {[catch {close $fd} err]} {
1364 set fv {}
1365 if {$view != $curview} {
1366 set fv " for the \"$viewname($view)\" view"
1368 if {[string range $err 0 4] == "usage"} {
1369 set err "Gitk: error reading commits$fv:\
1370 bad arguments to git log."
1371 if {$viewname($view) eq "Command line"} {
1372 append err \
1373 " (Note: arguments to gitk are passed to git log\
1374 to allow selection of commits to be displayed.)"
1376 } else {
1377 set err "Error reading commits$fv: $err"
1379 error_popup $err
1381 if {[incr viewactive($view) -1] <= 0} {
1382 set viewcomplete($view) 1
1383 # Check if we have seen any ids listed as parents that haven't
1384 # appeared in the list
1385 closevarcs $view
1386 notbusy $view
1388 if {$view == $curview} {
1389 run chewcommits
1391 return 0
1393 set start 0
1394 set gotsome 0
1395 set scripts {}
1396 while 1 {
1397 set i [string first "\0" $stuff $start]
1398 if {$i < 0} {
1399 append leftover($inst) [string range $stuff $start end]
1400 break
1402 if {$start == 0} {
1403 set cmit $leftover($inst)
1404 append cmit [string range $stuff 0 [expr {$i - 1}]]
1405 set leftover($inst) {}
1406 } else {
1407 set cmit [string range $stuff $start [expr {$i - 1}]]
1409 set start [expr {$i + 1}]
1410 set j [string first "\n" $cmit]
1411 set ok 0
1412 set listed 1
1413 if {$j >= 0 && [string match "commit *" $cmit]} {
1414 set ids [string range $cmit 7 [expr {$j - 1}]]
1415 if {[string match {[-^<>]*} $ids]} {
1416 switch -- [string index $ids 0] {
1417 "-" {set listed 0}
1418 "^" {set listed 2}
1419 "<" {set listed 3}
1420 ">" {set listed 4}
1422 set ids [string range $ids 1 end]
1424 set ok 1
1425 foreach id $ids {
1426 if {[string length $id] != 40} {
1427 set ok 0
1428 break
1432 if {!$ok} {
1433 set shortcmit $cmit
1434 if {[string length $shortcmit] > 80} {
1435 set shortcmit "[string range $shortcmit 0 80]..."
1437 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1438 exit 1
1440 set id [lindex $ids 0]
1441 set vid $view,$id
1443 if {!$listed && $updating && ![info exists varcid($vid)] &&
1444 $vfilelimit($view) ne {}} {
1445 # git log doesn't rewrite parents for unlisted commits
1446 # when doing path limiting, so work around that here
1447 # by working out the rewritten parent with git rev-list
1448 # and if we already know about it, using the rewritten
1449 # parent as a substitute parent for $id's children.
1450 if {![catch {
1451 set rwid [exec git rev-list --first-parent --max-count=1 \
1452 $id -- $vfilelimit($view)]
1453 }]} {
1454 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1455 # use $rwid in place of $id
1456 rewrite_commit $view $id $rwid
1457 continue
1462 set a 0
1463 if {[info exists varcid($vid)]} {
1464 if {$cmitlisted($vid) || !$listed} continue
1465 set a $varcid($vid)
1467 if {$listed} {
1468 set olds [lrange $ids 1 end]
1469 } else {
1470 set olds {}
1472 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1473 set cmitlisted($vid) $listed
1474 set parents($vid) $olds
1475 if {![info exists children($vid)]} {
1476 set children($vid) {}
1477 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1478 set k [lindex $children($vid) 0]
1479 if {[llength $parents($view,$k)] == 1 &&
1480 (!$vdatemode($view) ||
1481 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1482 set a $varcid($view,$k)
1485 if {$a == 0} {
1486 # new arc
1487 set a [newvarc $view $id]
1489 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1490 modify_arc $view $a
1492 if {![info exists varcid($vid)]} {
1493 set varcid($vid) $a
1494 lappend varccommits($view,$a) $id
1495 incr commitidx($view)
1498 set i 0
1499 foreach p $olds {
1500 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1501 set vp $view,$p
1502 if {[llength [lappend children($vp) $id]] > 1 &&
1503 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1504 set children($vp) [lsort -command [list vtokcmp $view] \
1505 $children($vp)]
1506 catch {unset ordertok}
1508 if {[info exists varcid($view,$p)]} {
1509 fix_reversal $p $a $view
1512 incr i
1515 set scripts [check_interest $id $scripts]
1516 set gotsome 1
1518 if {$gotsome} {
1519 global numcommits hlview
1521 if {$view == $curview} {
1522 set numcommits $commitidx($view)
1523 run chewcommits
1525 if {[info exists hlview] && $view == $hlview} {
1526 # we never actually get here...
1527 run vhighlightmore
1529 foreach s $scripts {
1530 eval $s
1533 return 2
1536 proc chewcommits {} {
1537 global curview hlview viewcomplete
1538 global pending_select
1540 layoutmore
1541 if {$viewcomplete($curview)} {
1542 global commitidx varctok
1543 global numcommits startmsecs
1545 if {[info exists pending_select]} {
1546 update
1547 reset_pending_select {}
1549 if {[commitinview $pending_select $curview]} {
1550 selectline [rowofcommit $pending_select] 1
1551 } else {
1552 set row [first_real_row]
1553 selectline $row 1
1556 if {$commitidx($curview) > 0} {
1557 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1558 #puts "overall $ms ms for $numcommits commits"
1559 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1560 } else {
1561 show_status [mc "No commits selected"]
1563 notbusy layout
1565 return 0
1568 proc do_readcommit {id} {
1569 global tclencoding
1571 # Invoke git-log to handle automatic encoding conversion
1572 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1573 # Read the results using i18n.logoutputencoding
1574 fconfigure $fd -translation lf -eofchar {}
1575 if {$tclencoding != {}} {
1576 fconfigure $fd -encoding $tclencoding
1578 set contents [read $fd]
1579 close $fd
1580 # Remove the heading line
1581 regsub {^commit [0-9a-f]+\n} $contents {} contents
1583 return $contents
1586 proc readcommit {id} {
1587 if {[catch {set contents [do_readcommit $id]}]} return
1588 parsecommit $id $contents 1
1591 proc parsecommit {id contents listed} {
1592 global commitinfo cdate
1594 set inhdr 1
1595 set comment {}
1596 set headline {}
1597 set auname {}
1598 set audate {}
1599 set comname {}
1600 set comdate {}
1601 set hdrend [string first "\n\n" $contents]
1602 if {$hdrend < 0} {
1603 # should never happen...
1604 set hdrend [string length $contents]
1606 set header [string range $contents 0 [expr {$hdrend - 1}]]
1607 set comment [string range $contents [expr {$hdrend + 2}] end]
1608 foreach line [split $header "\n"] {
1609 set line [split $line " "]
1610 set tag [lindex $line 0]
1611 if {$tag == "author"} {
1612 set audate [lindex $line end-1]
1613 set auname [join [lrange $line 1 end-2] " "]
1614 } elseif {$tag == "committer"} {
1615 set comdate [lindex $line end-1]
1616 set comname [join [lrange $line 1 end-2] " "]
1619 set headline {}
1620 # take the first non-blank line of the comment as the headline
1621 set headline [string trimleft $comment]
1622 set i [string first "\n" $headline]
1623 if {$i >= 0} {
1624 set headline [string range $headline 0 $i]
1626 set headline [string trimright $headline]
1627 set i [string first "\r" $headline]
1628 if {$i >= 0} {
1629 set headline [string trimright [string range $headline 0 $i]]
1631 if {!$listed} {
1632 # git log indents the comment by 4 spaces;
1633 # if we got this via git cat-file, add the indentation
1634 set newcomment {}
1635 foreach line [split $comment "\n"] {
1636 append newcomment " "
1637 append newcomment $line
1638 append newcomment "\n"
1640 set comment $newcomment
1642 if {$comdate != {}} {
1643 set cdate($id) $comdate
1645 set commitinfo($id) [list $headline $auname $audate \
1646 $comname $comdate $comment]
1649 proc getcommit {id} {
1650 global commitdata commitinfo
1652 if {[info exists commitdata($id)]} {
1653 parsecommit $id $commitdata($id) 1
1654 } else {
1655 readcommit $id
1656 if {![info exists commitinfo($id)]} {
1657 set commitinfo($id) [list [mc "No commit information available"]]
1660 return 1
1663 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1664 # and are present in the current view.
1665 # This is fairly slow...
1666 proc longid {prefix} {
1667 global varcid curview
1669 set ids {}
1670 foreach match [array names varcid "$curview,$prefix*"] {
1671 lappend ids [lindex [split $match ","] 1]
1673 return $ids
1676 proc readrefs {} {
1677 global tagids idtags headids idheads tagobjid
1678 global otherrefids idotherrefs mainhead mainheadid
1679 global selecthead selectheadid
1681 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1682 catch {unset $v}
1684 set refd [open [list | git show-ref -d] r]
1685 while {[gets $refd line] >= 0} {
1686 if {[string index $line 40] ne " "} continue
1687 set id [string range $line 0 39]
1688 set ref [string range $line 41 end]
1689 if {![string match "refs/*" $ref]} continue
1690 set name [string range $ref 5 end]
1691 if {[string match "remotes/*" $name]} {
1692 if {![string match "*/HEAD" $name]} {
1693 set headids($name) $id
1694 lappend idheads($id) $name
1696 } elseif {[string match "heads/*" $name]} {
1697 set name [string range $name 6 end]
1698 set headids($name) $id
1699 lappend idheads($id) $name
1700 } elseif {[string match "tags/*" $name]} {
1701 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1702 # which is what we want since the former is the commit ID
1703 set name [string range $name 5 end]
1704 if {[string match "*^{}" $name]} {
1705 set name [string range $name 0 end-3]
1706 } else {
1707 set tagobjid($name) $id
1709 set tagids($name) $id
1710 lappend idtags($id) $name
1711 } else {
1712 set otherrefids($name) $id
1713 lappend idotherrefs($id) $name
1716 catch {close $refd}
1717 set mainhead {}
1718 set mainheadid {}
1719 catch {
1720 set mainheadid [exec git rev-parse HEAD]
1721 set thehead [exec git symbolic-ref HEAD]
1722 if {[string match "refs/heads/*" $thehead]} {
1723 set mainhead [string range $thehead 11 end]
1726 set selectheadid {}
1727 if {$selecthead ne {}} {
1728 catch {
1729 set selectheadid [exec git rev-parse --verify $selecthead]
1734 # skip over fake commits
1735 proc first_real_row {} {
1736 global nullid nullid2 numcommits
1738 for {set row 0} {$row < $numcommits} {incr row} {
1739 set id [commitonrow $row]
1740 if {$id ne $nullid && $id ne $nullid2} {
1741 break
1744 return $row
1747 # update things for a head moved to a child of its previous location
1748 proc movehead {id name} {
1749 global headids idheads
1751 removehead $headids($name) $name
1752 set headids($name) $id
1753 lappend idheads($id) $name
1756 # update things when a head has been removed
1757 proc removehead {id name} {
1758 global headids idheads
1760 if {$idheads($id) eq $name} {
1761 unset idheads($id)
1762 } else {
1763 set i [lsearch -exact $idheads($id) $name]
1764 if {$i >= 0} {
1765 set idheads($id) [lreplace $idheads($id) $i $i]
1768 unset headids($name)
1771 proc make_transient {window origin} {
1772 global have_tk85
1774 # In MacOS Tk 8.4 transient appears to work by setting
1775 # overrideredirect, which is utterly useless, since the
1776 # windows get no border, and are not even kept above
1777 # the parent.
1778 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1780 wm transient $window $origin
1782 # Windows fails to place transient windows normally, so
1783 # schedule a callback to center them on the parent.
1784 if {[tk windowingsystem] eq {win32}} {
1785 after idle [list tk::PlaceWindow $window widget $origin]
1789 proc show_error {w top msg} {
1790 message $w.m -text $msg -justify center -aspect 400
1791 pack $w.m -side top -fill x -padx 20 -pady 20
1792 button $w.ok -text [mc OK] -command "destroy $top"
1793 pack $w.ok -side bottom -fill x
1794 bind $top <Visibility> "grab $top; focus $top"
1795 bind $top <Key-Return> "destroy $top"
1796 bind $top <Key-space> "destroy $top"
1797 bind $top <Key-Escape> "destroy $top"
1798 tkwait window $top
1801 proc error_popup {msg {owner .}} {
1802 set w .error
1803 toplevel $w
1804 make_transient $w $owner
1805 show_error $w $w $msg
1808 proc confirm_popup {msg {owner .}} {
1809 global confirm_ok
1810 set confirm_ok 0
1811 set w .confirm
1812 toplevel $w
1813 make_transient $w $owner
1814 message $w.m -text $msg -justify center -aspect 400
1815 pack $w.m -side top -fill x -padx 20 -pady 20
1816 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1817 pack $w.ok -side left -fill x
1818 button $w.cancel -text [mc Cancel] -command "destroy $w"
1819 pack $w.cancel -side right -fill x
1820 bind $w <Visibility> "grab $w; focus $w"
1821 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1822 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1823 bind $w <Key-Escape> "destroy $w"
1824 tkwait window $w
1825 return $confirm_ok
1828 proc setoptions {} {
1829 option add *Panedwindow.showHandle 1 startupFile
1830 option add *Panedwindow.sashRelief raised startupFile
1831 option add *Button.font uifont startupFile
1832 option add *Checkbutton.font uifont startupFile
1833 option add *Radiobutton.font uifont startupFile
1834 if {[tk windowingsystem] ne "aqua"} {
1835 option add *Menu.font uifont startupFile
1837 option add *Menubutton.font uifont startupFile
1838 option add *Label.font uifont startupFile
1839 option add *Message.font uifont startupFile
1840 option add *Entry.font uifont startupFile
1843 # Make a menu and submenus.
1844 # m is the window name for the menu, items is the list of menu items to add.
1845 # Each item is a list {mc label type description options...}
1846 # mc is ignored; it's so we can put mc there to alert xgettext
1847 # label is the string that appears in the menu
1848 # type is cascade, command or radiobutton (should add checkbutton)
1849 # description depends on type; it's the sublist for cascade, the
1850 # command to invoke for command, or {variable value} for radiobutton
1851 proc makemenu {m items} {
1852 menu $m
1853 if {[tk windowingsystem] eq {aqua}} {
1854 set Meta1 Cmd
1855 } else {
1856 set Meta1 Ctrl
1858 foreach i $items {
1859 set name [mc [lindex $i 1]]
1860 set type [lindex $i 2]
1861 set thing [lindex $i 3]
1862 set params [list $type]
1863 if {$name ne {}} {
1864 set u [string first "&" [string map {&& x} $name]]
1865 lappend params -label [string map {&& & & {}} $name]
1866 if {$u >= 0} {
1867 lappend params -underline $u
1870 switch -- $type {
1871 "cascade" {
1872 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1873 lappend params -menu $m.$submenu
1875 "command" {
1876 lappend params -command $thing
1878 "radiobutton" {
1879 lappend params -variable [lindex $thing 0] \
1880 -value [lindex $thing 1]
1883 set tail [lrange $i 4 end]
1884 regsub -all {\yMeta1\y} $tail $Meta1 tail
1885 eval $m add $params $tail
1886 if {$type eq "cascade"} {
1887 makemenu $m.$submenu $thing
1892 # translate string and remove ampersands
1893 proc mca {str} {
1894 return [string map {&& & & {}} [mc $str]]
1897 proc makewindow {} {
1898 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1899 global tabstop
1900 global findtype findtypemenu findloc findstring fstring geometry
1901 global entries sha1entry sha1string sha1but
1902 global diffcontextstring diffcontext
1903 global ignorespace
1904 global maincursor textcursor curtextcursor
1905 global rowctxmenu fakerowmenu mergemax wrapcomment
1906 global highlight_files gdttype
1907 global searchstring sstring
1908 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1909 global headctxmenu progresscanv progressitem progresscoords statusw
1910 global fprogitem fprogcoord lastprogupdate progupdatepending
1911 global rprogitem rprogcoord rownumsel numcommits
1912 global have_tk85
1914 # The "mc" arguments here are purely so that xgettext
1915 # sees the following string as needing to be translated
1916 set file {
1917 mc "File" cascade {
1918 {mc "Update" command updatecommits -accelerator F5}
1919 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1920 {mc "Reread references" command rereadrefs}
1921 {mc "List references" command showrefs -accelerator F2}
1922 {xx "" separator}
1923 {mc "Start git gui" command {exec git gui &}}
1924 {xx "" separator}
1925 {mc "Quit" command doquit -accelerator Meta1-Q}
1927 set edit {
1928 mc "Edit" cascade {
1929 {mc "Preferences" command doprefs}
1931 set view {
1932 mc "View" cascade {
1933 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1934 {mc "Edit view..." command editview -state disabled -accelerator F4}
1935 {mc "Delete view" command delview -state disabled}
1936 {xx "" separator}
1937 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1939 if {[tk windowingsystem] ne "aqua"} {
1940 set help {
1941 mc "Help" cascade {
1942 {mc "About gitk" command about}
1943 {mc "Key bindings" command keys}
1945 set bar [list $file $edit $view $help]
1946 } else {
1947 proc ::tk::mac::ShowPreferences {} {doprefs}
1948 proc ::tk::mac::Quit {} {doquit}
1949 lset file end [lreplace [lindex $file end] end-1 end]
1950 set apple {
1951 xx "Apple" cascade {
1952 {mc "About gitk" command about}
1953 {xx "" separator}
1955 set help {
1956 mc "Help" cascade {
1957 {mc "Key bindings" command keys}
1959 set bar [list $apple $file $view $help]
1961 makemenu .bar $bar
1962 . configure -menu .bar
1964 # the gui has upper and lower half, parts of a paned window.
1965 panedwindow .ctop -orient vertical
1967 # possibly use assumed geometry
1968 if {![info exists geometry(pwsash0)]} {
1969 set geometry(topheight) [expr {15 * $linespc}]
1970 set geometry(topwidth) [expr {80 * $charspc}]
1971 set geometry(botheight) [expr {15 * $linespc}]
1972 set geometry(botwidth) [expr {50 * $charspc}]
1973 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1974 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1977 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1978 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1979 frame .tf.histframe
1980 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1982 # create three canvases
1983 set cscroll .tf.histframe.csb
1984 set canv .tf.histframe.pwclist.canv
1985 canvas $canv \
1986 -selectbackground $selectbgcolor \
1987 -background $bgcolor -bd 0 \
1988 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1989 .tf.histframe.pwclist add $canv
1990 set canv2 .tf.histframe.pwclist.canv2
1991 canvas $canv2 \
1992 -selectbackground $selectbgcolor \
1993 -background $bgcolor -bd 0 -yscrollincr $linespc
1994 .tf.histframe.pwclist add $canv2
1995 set canv3 .tf.histframe.pwclist.canv3
1996 canvas $canv3 \
1997 -selectbackground $selectbgcolor \
1998 -background $bgcolor -bd 0 -yscrollincr $linespc
1999 .tf.histframe.pwclist add $canv3
2000 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2001 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2003 # a scroll bar to rule them
2004 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
2005 pack $cscroll -side right -fill y
2006 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2007 lappend bglist $canv $canv2 $canv3
2008 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2010 # we have two button bars at bottom of top frame. Bar 1
2011 frame .tf.bar
2012 frame .tf.lbar -height 15
2014 set sha1entry .tf.bar.sha1
2015 set entries $sha1entry
2016 set sha1but .tf.bar.sha1label
2017 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2018 -command gotocommit -width 8
2019 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2020 pack .tf.bar.sha1label -side left
2021 entry $sha1entry -width 40 -font textfont -textvariable sha1string
2022 trace add variable sha1string write sha1change
2023 pack $sha1entry -side left -pady 2
2025 image create bitmap bm-left -data {
2026 #define left_width 16
2027 #define left_height 16
2028 static unsigned char left_bits[] = {
2029 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2030 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2031 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2033 image create bitmap bm-right -data {
2034 #define right_width 16
2035 #define right_height 16
2036 static unsigned char right_bits[] = {
2037 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2038 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2039 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2041 button .tf.bar.leftbut -image bm-left -command goback \
2042 -state disabled -width 26
2043 pack .tf.bar.leftbut -side left -fill y
2044 button .tf.bar.rightbut -image bm-right -command goforw \
2045 -state disabled -width 26
2046 pack .tf.bar.rightbut -side left -fill y
2048 label .tf.bar.rowlabel -text [mc "Row"]
2049 set rownumsel {}
2050 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2051 -relief sunken -anchor e
2052 label .tf.bar.rowlabel2 -text "/"
2053 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2054 -relief sunken -anchor e
2055 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2056 -side left
2057 global selectedline
2058 trace add variable selectedline write selectedline_change
2060 # Status label and progress bar
2061 set statusw .tf.bar.status
2062 label $statusw -width 15 -relief sunken
2063 pack $statusw -side left -padx 5
2064 set h [expr {[font metrics uifont -linespace] + 2}]
2065 set progresscanv .tf.bar.progress
2066 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2067 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2068 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2069 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2070 pack $progresscanv -side right -expand 1 -fill x
2071 set progresscoords {0 0}
2072 set fprogcoord 0
2073 set rprogcoord 0
2074 bind $progresscanv <Configure> adjustprogress
2075 set lastprogupdate [clock clicks -milliseconds]
2076 set progupdatepending 0
2078 # build up the bottom bar of upper window
2079 label .tf.lbar.flabel -text "[mc "Find"] "
2080 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2081 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2082 label .tf.lbar.flab2 -text " [mc "commit"] "
2083 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2084 -side left -fill y
2085 set gdttype [mc "containing:"]
2086 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2087 [mc "containing:"] \
2088 [mc "touching paths:"] \
2089 [mc "adding/removing string:"]]
2090 trace add variable gdttype write gdttype_change
2091 pack .tf.lbar.gdttype -side left -fill y
2093 set findstring {}
2094 set fstring .tf.lbar.findstring
2095 lappend entries $fstring
2096 entry $fstring -width 30 -font textfont -textvariable findstring
2097 trace add variable findstring write find_change
2098 set findtype [mc "Exact"]
2099 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2100 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2101 trace add variable findtype write findcom_change
2102 set findloc [mc "All fields"]
2103 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2104 [mc "Comments"] [mc "Author"] [mc "Committer"]
2105 trace add variable findloc write find_change
2106 pack .tf.lbar.findloc -side right
2107 pack .tf.lbar.findtype -side right
2108 pack $fstring -side left -expand 1 -fill x
2110 # Finish putting the upper half of the viewer together
2111 pack .tf.lbar -in .tf -side bottom -fill x
2112 pack .tf.bar -in .tf -side bottom -fill x
2113 pack .tf.histframe -fill both -side top -expand 1
2114 .ctop add .tf
2115 .ctop paneconfigure .tf -height $geometry(topheight)
2116 .ctop paneconfigure .tf -width $geometry(topwidth)
2118 # now build up the bottom
2119 panedwindow .pwbottom -orient horizontal
2121 # lower left, a text box over search bar, scroll bar to the right
2122 # if we know window height, then that will set the lower text height, otherwise
2123 # we set lower text height which will drive window height
2124 if {[info exists geometry(main)]} {
2125 frame .bleft -width $geometry(botwidth)
2126 } else {
2127 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2129 frame .bleft.top
2130 frame .bleft.mid
2131 frame .bleft.bottom
2133 button .bleft.top.search -text [mc "Search"] -command dosearch
2134 pack .bleft.top.search -side left -padx 5
2135 set sstring .bleft.top.sstring
2136 entry $sstring -width 20 -font textfont -textvariable searchstring
2137 lappend entries $sstring
2138 trace add variable searchstring write incrsearch
2139 pack $sstring -side left -expand 1 -fill x
2140 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2141 -command changediffdisp -variable diffelide -value {0 0}
2142 radiobutton .bleft.mid.old -text [mc "Old version"] \
2143 -command changediffdisp -variable diffelide -value {0 1}
2144 radiobutton .bleft.mid.new -text [mc "New version"] \
2145 -command changediffdisp -variable diffelide -value {1 0}
2146 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2147 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2148 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2149 -from 0 -increment 1 -to 10000000 \
2150 -validate all -validatecommand "diffcontextvalidate %P" \
2151 -textvariable diffcontextstring
2152 .bleft.mid.diffcontext set $diffcontext
2153 trace add variable diffcontextstring write diffcontextchange
2154 lappend entries .bleft.mid.diffcontext
2155 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2156 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2157 -command changeignorespace -variable ignorespace
2158 pack .bleft.mid.ignspace -side left -padx 5
2159 set ctext .bleft.bottom.ctext
2160 text $ctext -background $bgcolor -foreground $fgcolor \
2161 -state disabled -font textfont \
2162 -yscrollcommand scrolltext -wrap none \
2163 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2164 if {$have_tk85} {
2165 $ctext conf -tabstyle wordprocessor
2167 scrollbar .bleft.bottom.sb -command "$ctext yview"
2168 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2169 -width 10
2170 pack .bleft.top -side top -fill x
2171 pack .bleft.mid -side top -fill x
2172 grid $ctext .bleft.bottom.sb -sticky nsew
2173 grid .bleft.bottom.sbhorizontal -sticky ew
2174 grid columnconfigure .bleft.bottom 0 -weight 1
2175 grid rowconfigure .bleft.bottom 0 -weight 1
2176 grid rowconfigure .bleft.bottom 1 -weight 0
2177 pack .bleft.bottom -side top -fill both -expand 1
2178 lappend bglist $ctext
2179 lappend fglist $ctext
2181 $ctext tag conf comment -wrap $wrapcomment
2182 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2183 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2184 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2185 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2186 $ctext tag conf m0 -fore red
2187 $ctext tag conf m1 -fore blue
2188 $ctext tag conf m2 -fore green
2189 $ctext tag conf m3 -fore purple
2190 $ctext tag conf m4 -fore brown
2191 $ctext tag conf m5 -fore "#009090"
2192 $ctext tag conf m6 -fore magenta
2193 $ctext tag conf m7 -fore "#808000"
2194 $ctext tag conf m8 -fore "#009000"
2195 $ctext tag conf m9 -fore "#ff0080"
2196 $ctext tag conf m10 -fore cyan
2197 $ctext tag conf m11 -fore "#b07070"
2198 $ctext tag conf m12 -fore "#70b0f0"
2199 $ctext tag conf m13 -fore "#70f0b0"
2200 $ctext tag conf m14 -fore "#f0b070"
2201 $ctext tag conf m15 -fore "#ff70b0"
2202 $ctext tag conf mmax -fore darkgrey
2203 set mergemax 16
2204 $ctext tag conf mresult -font textfontbold
2205 $ctext tag conf msep -font textfontbold
2206 $ctext tag conf found -back yellow
2208 .pwbottom add .bleft
2209 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2211 # lower right
2212 frame .bright
2213 frame .bright.mode
2214 radiobutton .bright.mode.patch -text [mc "Patch"] \
2215 -command reselectline -variable cmitmode -value "patch"
2216 radiobutton .bright.mode.tree -text [mc "Tree"] \
2217 -command reselectline -variable cmitmode -value "tree"
2218 grid .bright.mode.patch .bright.mode.tree -sticky ew
2219 pack .bright.mode -side top -fill x
2220 set cflist .bright.cfiles
2221 set indent [font measure mainfont "nn"]
2222 text $cflist \
2223 -selectbackground $selectbgcolor \
2224 -background $bgcolor -foreground $fgcolor \
2225 -font mainfont \
2226 -tabs [list $indent [expr {2 * $indent}]] \
2227 -yscrollcommand ".bright.sb set" \
2228 -cursor [. cget -cursor] \
2229 -spacing1 1 -spacing3 1
2230 lappend bglist $cflist
2231 lappend fglist $cflist
2232 scrollbar .bright.sb -command "$cflist yview"
2233 pack .bright.sb -side right -fill y
2234 pack $cflist -side left -fill both -expand 1
2235 $cflist tag configure highlight \
2236 -background [$cflist cget -selectbackground]
2237 $cflist tag configure bold -font mainfontbold
2239 .pwbottom add .bright
2240 .ctop add .pwbottom
2242 # restore window width & height if known
2243 if {[info exists geometry(main)]} {
2244 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2245 if {$w > [winfo screenwidth .]} {
2246 set w [winfo screenwidth .]
2248 if {$h > [winfo screenheight .]} {
2249 set h [winfo screenheight .]
2251 wm geometry . "${w}x$h"
2255 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2256 wm state . $geometry(state)
2259 if {[tk windowingsystem] eq {aqua}} {
2260 set M1B M1
2261 set ::BM "3"
2262 } else {
2263 set M1B Control
2264 set ::BM "2"
2267 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2268 pack .ctop -fill both -expand 1
2269 bindall <1> {selcanvline %W %x %y}
2270 #bindall <B1-Motion> {selcanvline %W %x %y}
2271 if {[tk windowingsystem] == "win32"} {
2272 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2273 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2274 } else {
2275 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2276 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2277 if {[tk windowingsystem] eq "aqua"} {
2278 bindall <MouseWheel> {
2279 set delta [expr {- (%D)}]
2280 allcanvs yview scroll $delta units
2282 bindall <Shift-MouseWheel> {
2283 set delta [expr {- (%D)}]
2284 $canv xview scroll $delta units
2288 bindall <$::BM> "canvscan mark %W %x %y"
2289 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2290 bindkey <Home> selfirstline
2291 bindkey <End> sellastline
2292 bind . <Key-Up> "selnextline -1"
2293 bind . <Key-Down> "selnextline 1"
2294 bind . <Shift-Key-Up> "dofind -1 0"
2295 bind . <Shift-Key-Down> "dofind 1 0"
2296 bindkey <Key-Right> "goforw"
2297 bindkey <Key-Left> "goback"
2298 bind . <Key-Prior> "selnextpage -1"
2299 bind . <Key-Next> "selnextpage 1"
2300 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2301 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2302 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2303 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2304 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2305 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2306 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2307 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2308 bindkey <Key-space> "$ctext yview scroll 1 pages"
2309 bindkey p "selnextline -1"
2310 bindkey n "selnextline 1"
2311 bindkey z "goback"
2312 bindkey x "goforw"
2313 bindkey i "selnextline -1"
2314 bindkey k "selnextline 1"
2315 bindkey j "goback"
2316 bindkey l "goforw"
2317 bindkey b prevfile
2318 bindkey d "$ctext yview scroll 18 units"
2319 bindkey u "$ctext yview scroll -18 units"
2320 bindkey / {focus $fstring}
2321 bindkey <Key-KP_Divide> {focus $fstring}
2322 bindkey <Key-Return> {dofind 1 1}
2323 bindkey ? {dofind -1 1}
2324 bindkey f nextfile
2325 bind . <F5> updatecommits
2326 bind . <$M1B-F5> reloadcommits
2327 bind . <F2> showrefs
2328 bind . <Shift-F4> {newview 0}
2329 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2330 bind . <F4> edit_or_newview
2331 bind . <$M1B-q> doquit
2332 bind . <$M1B-f> {dofind 1 1}
2333 bind . <$M1B-g> {dofind 1 0}
2334 bind . <$M1B-r> dosearchback
2335 bind . <$M1B-s> dosearch
2336 bind . <$M1B-equal> {incrfont 1}
2337 bind . <$M1B-plus> {incrfont 1}
2338 bind . <$M1B-KP_Add> {incrfont 1}
2339 bind . <$M1B-minus> {incrfont -1}
2340 bind . <$M1B-KP_Subtract> {incrfont -1}
2341 wm protocol . WM_DELETE_WINDOW doquit
2342 bind . <Destroy> {stop_backends}
2343 bind . <Button-1> "click %W"
2344 bind $fstring <Key-Return> {dofind 1 1}
2345 bind $sha1entry <Key-Return> {gotocommit; break}
2346 bind $sha1entry <<PasteSelection>> clearsha1
2347 bind $cflist <1> {sel_flist %W %x %y; break}
2348 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2349 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2350 global ctxbut
2351 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2352 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2354 set maincursor [. cget -cursor]
2355 set textcursor [$ctext cget -cursor]
2356 set curtextcursor $textcursor
2358 set rowctxmenu .rowctxmenu
2359 makemenu $rowctxmenu {
2360 {mc "Diff this -> selected" command {diffvssel 0}}
2361 {mc "Diff selected -> this" command {diffvssel 1}}
2362 {mc "Make patch" command mkpatch}
2363 {mc "Create tag" command mktag}
2364 {mc "Write commit to file" command writecommit}
2365 {mc "Create new branch" command mkbranch}
2366 {mc "Cherry-pick this commit" command cherrypick}
2367 {mc "Reset HEAD branch to here" command resethead}
2368 {mc "Mark this commit" command markhere}
2369 {mc "Return to mark" command gotomark}
2370 {mc "Find descendant of this and mark" command find_common_desc}
2371 {mc "Compare with marked commit" command compare_commits}
2373 $rowctxmenu configure -tearoff 0
2375 set fakerowmenu .fakerowmenu
2376 makemenu $fakerowmenu {
2377 {mc "Diff this -> selected" command {diffvssel 0}}
2378 {mc "Diff selected -> this" command {diffvssel 1}}
2379 {mc "Make patch" command mkpatch}
2381 $fakerowmenu configure -tearoff 0
2383 set headctxmenu .headctxmenu
2384 makemenu $headctxmenu {
2385 {mc "Check out this branch" command cobranch}
2386 {mc "Remove this branch" command rmbranch}
2388 $headctxmenu configure -tearoff 0
2390 global flist_menu
2391 set flist_menu .flistctxmenu
2392 makemenu $flist_menu {
2393 {mc "Highlight this too" command {flist_hl 0}}
2394 {mc "Highlight this only" command {flist_hl 1}}
2395 {mc "External diff" command {external_diff}}
2396 {mc "Blame parent commit" command {external_blame 1}}
2398 $flist_menu configure -tearoff 0
2400 global diff_menu
2401 set diff_menu .diffctxmenu
2402 makemenu $diff_menu {
2403 {mc "Show origin of this line" command show_line_source}
2404 {mc "Run git gui blame on this line" command {external_blame_diff}}
2406 $diff_menu configure -tearoff 0
2409 # Windows sends all mouse wheel events to the current focused window, not
2410 # the one where the mouse hovers, so bind those events here and redirect
2411 # to the correct window
2412 proc windows_mousewheel_redirector {W X Y D} {
2413 global canv canv2 canv3
2414 set w [winfo containing -displayof $W $X $Y]
2415 if {$w ne ""} {
2416 set u [expr {$D < 0 ? 5 : -5}]
2417 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2418 allcanvs yview scroll $u units
2419 } else {
2420 catch {
2421 $w yview scroll $u units
2427 # Update row number label when selectedline changes
2428 proc selectedline_change {n1 n2 op} {
2429 global selectedline rownumsel
2431 if {$selectedline eq {}} {
2432 set rownumsel {}
2433 } else {
2434 set rownumsel [expr {$selectedline + 1}]
2438 # mouse-2 makes all windows scan vertically, but only the one
2439 # the cursor is in scans horizontally
2440 proc canvscan {op w x y} {
2441 global canv canv2 canv3
2442 foreach c [list $canv $canv2 $canv3] {
2443 if {$c == $w} {
2444 $c scan $op $x $y
2445 } else {
2446 $c scan $op 0 $y
2451 proc scrollcanv {cscroll f0 f1} {
2452 $cscroll set $f0 $f1
2453 drawvisible
2454 flushhighlights
2457 # when we make a key binding for the toplevel, make sure
2458 # it doesn't get triggered when that key is pressed in the
2459 # find string entry widget.
2460 proc bindkey {ev script} {
2461 global entries
2462 bind . $ev $script
2463 set escript [bind Entry $ev]
2464 if {$escript == {}} {
2465 set escript [bind Entry <Key>]
2467 foreach e $entries {
2468 bind $e $ev "$escript; break"
2472 # set the focus back to the toplevel for any click outside
2473 # the entry widgets
2474 proc click {w} {
2475 global ctext entries
2476 foreach e [concat $entries $ctext] {
2477 if {$w == $e} return
2479 focus .
2482 # Adjust the progress bar for a change in requested extent or canvas size
2483 proc adjustprogress {} {
2484 global progresscanv progressitem progresscoords
2485 global fprogitem fprogcoord lastprogupdate progupdatepending
2486 global rprogitem rprogcoord
2488 set w [expr {[winfo width $progresscanv] - 4}]
2489 set x0 [expr {$w * [lindex $progresscoords 0]}]
2490 set x1 [expr {$w * [lindex $progresscoords 1]}]
2491 set h [winfo height $progresscanv]
2492 $progresscanv coords $progressitem $x0 0 $x1 $h
2493 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2494 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2495 set now [clock clicks -milliseconds]
2496 if {$now >= $lastprogupdate + 100} {
2497 set progupdatepending 0
2498 update
2499 } elseif {!$progupdatepending} {
2500 set progupdatepending 1
2501 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2505 proc doprogupdate {} {
2506 global lastprogupdate progupdatepending
2508 if {$progupdatepending} {
2509 set progupdatepending 0
2510 set lastprogupdate [clock clicks -milliseconds]
2511 update
2515 proc savestuff {w} {
2516 global canv canv2 canv3 mainfont textfont uifont tabstop
2517 global stuffsaved findmergefiles maxgraphpct
2518 global maxwidth showneartags showlocalchanges
2519 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2520 global cmitmode wrapcomment datetimeformat limitdiffs
2521 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2522 global autoselect extdifftool perfile_attrs markbgcolor
2524 if {$stuffsaved} return
2525 if {![winfo viewable .]} return
2526 catch {
2527 set f [open "~/.gitk-new" w]
2528 if {$::tcl_platform(platform) eq {windows}} {
2529 file attributes "~/.gitk-new" -hidden true
2531 puts $f [list set mainfont $mainfont]
2532 puts $f [list set textfont $textfont]
2533 puts $f [list set uifont $uifont]
2534 puts $f [list set tabstop $tabstop]
2535 puts $f [list set findmergefiles $findmergefiles]
2536 puts $f [list set maxgraphpct $maxgraphpct]
2537 puts $f [list set maxwidth $maxwidth]
2538 puts $f [list set cmitmode $cmitmode]
2539 puts $f [list set wrapcomment $wrapcomment]
2540 puts $f [list set autoselect $autoselect]
2541 puts $f [list set showneartags $showneartags]
2542 puts $f [list set showlocalchanges $showlocalchanges]
2543 puts $f [list set datetimeformat $datetimeformat]
2544 puts $f [list set limitdiffs $limitdiffs]
2545 puts $f [list set bgcolor $bgcolor]
2546 puts $f [list set fgcolor $fgcolor]
2547 puts $f [list set colors $colors]
2548 puts $f [list set diffcolors $diffcolors]
2549 puts $f [list set markbgcolor $markbgcolor]
2550 puts $f [list set diffcontext $diffcontext]
2551 puts $f [list set selectbgcolor $selectbgcolor]
2552 puts $f [list set extdifftool $extdifftool]
2553 puts $f [list set perfile_attrs $perfile_attrs]
2555 puts $f "set geometry(main) [wm geometry .]"
2556 puts $f "set geometry(state) [wm state .]"
2557 puts $f "set geometry(topwidth) [winfo width .tf]"
2558 puts $f "set geometry(topheight) [winfo height .tf]"
2559 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2560 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2561 puts $f "set geometry(botwidth) [winfo width .bleft]"
2562 puts $f "set geometry(botheight) [winfo height .bleft]"
2564 puts -nonewline $f "set permviews {"
2565 for {set v 0} {$v < $nextviewnum} {incr v} {
2566 if {$viewperm($v)} {
2567 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2570 puts $f "}"
2571 close $f
2572 file rename -force "~/.gitk-new" "~/.gitk"
2574 set stuffsaved 1
2577 proc resizeclistpanes {win w} {
2578 global oldwidth
2579 if {[info exists oldwidth($win)]} {
2580 set s0 [$win sash coord 0]
2581 set s1 [$win sash coord 1]
2582 if {$w < 60} {
2583 set sash0 [expr {int($w/2 - 2)}]
2584 set sash1 [expr {int($w*5/6 - 2)}]
2585 } else {
2586 set factor [expr {1.0 * $w / $oldwidth($win)}]
2587 set sash0 [expr {int($factor * [lindex $s0 0])}]
2588 set sash1 [expr {int($factor * [lindex $s1 0])}]
2589 if {$sash0 < 30} {
2590 set sash0 30
2592 if {$sash1 < $sash0 + 20} {
2593 set sash1 [expr {$sash0 + 20}]
2595 if {$sash1 > $w - 10} {
2596 set sash1 [expr {$w - 10}]
2597 if {$sash0 > $sash1 - 20} {
2598 set sash0 [expr {$sash1 - 20}]
2602 $win sash place 0 $sash0 [lindex $s0 1]
2603 $win sash place 1 $sash1 [lindex $s1 1]
2605 set oldwidth($win) $w
2608 proc resizecdetpanes {win w} {
2609 global oldwidth
2610 if {[info exists oldwidth($win)]} {
2611 set s0 [$win sash coord 0]
2612 if {$w < 60} {
2613 set sash0 [expr {int($w*3/4 - 2)}]
2614 } else {
2615 set factor [expr {1.0 * $w / $oldwidth($win)}]
2616 set sash0 [expr {int($factor * [lindex $s0 0])}]
2617 if {$sash0 < 45} {
2618 set sash0 45
2620 if {$sash0 > $w - 15} {
2621 set sash0 [expr {$w - 15}]
2624 $win sash place 0 $sash0 [lindex $s0 1]
2626 set oldwidth($win) $w
2629 proc allcanvs args {
2630 global canv canv2 canv3
2631 eval $canv $args
2632 eval $canv2 $args
2633 eval $canv3 $args
2636 proc bindall {event action} {
2637 global canv canv2 canv3
2638 bind $canv $event $action
2639 bind $canv2 $event $action
2640 bind $canv3 $event $action
2643 proc about {} {
2644 global uifont
2645 set w .about
2646 if {[winfo exists $w]} {
2647 raise $w
2648 return
2650 toplevel $w
2651 wm title $w [mc "About gitk"]
2652 make_transient $w .
2653 message $w.m -text [mc "
2654 Gitk - a commit viewer for git
2656 Copyright © 2005-2008 Paul Mackerras
2658 Use and redistribute under the terms of the GNU General Public License"] \
2659 -justify center -aspect 400 -border 2 -bg white -relief groove
2660 pack $w.m -side top -fill x -padx 2 -pady 2
2661 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2662 pack $w.ok -side bottom
2663 bind $w <Visibility> "focus $w.ok"
2664 bind $w <Key-Escape> "destroy $w"
2665 bind $w <Key-Return> "destroy $w"
2668 proc keys {} {
2669 set w .keys
2670 if {[winfo exists $w]} {
2671 raise $w
2672 return
2674 if {[tk windowingsystem] eq {aqua}} {
2675 set M1T Cmd
2676 } else {
2677 set M1T Ctrl
2679 toplevel $w
2680 wm title $w [mc "Gitk key bindings"]
2681 make_transient $w .
2682 message $w.m -text "
2683 [mc "Gitk key bindings:"]
2685 [mc "<%s-Q> Quit" $M1T]
2686 [mc "<Home> Move to first commit"]
2687 [mc "<End> Move to last commit"]
2688 [mc "<Up>, p, i Move up one commit"]
2689 [mc "<Down>, n, k Move down one commit"]
2690 [mc "<Left>, z, j Go back in history list"]
2691 [mc "<Right>, x, l Go forward in history list"]
2692 [mc "<PageUp> Move up one page in commit list"]
2693 [mc "<PageDown> Move down one page in commit list"]
2694 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2695 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2696 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2697 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2698 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2699 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2700 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2701 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2702 [mc "<Delete>, b Scroll diff view up one page"]
2703 [mc "<Backspace> Scroll diff view up one page"]
2704 [mc "<Space> Scroll diff view down one page"]
2705 [mc "u Scroll diff view up 18 lines"]
2706 [mc "d Scroll diff view down 18 lines"]
2707 [mc "<%s-F> Find" $M1T]
2708 [mc "<%s-G> Move to next find hit" $M1T]
2709 [mc "<Return> Move to next find hit"]
2710 [mc "/ Focus the search box"]
2711 [mc "? Move to previous find hit"]
2712 [mc "f Scroll diff view to next file"]
2713 [mc "<%s-S> Search for next hit in diff view" $M1T]
2714 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2715 [mc "<%s-KP+> Increase font size" $M1T]
2716 [mc "<%s-plus> Increase font size" $M1T]
2717 [mc "<%s-KP-> Decrease font size" $M1T]
2718 [mc "<%s-minus> Decrease font size" $M1T]
2719 [mc "<F5> Update"]
2721 -justify left -bg white -border 2 -relief groove
2722 pack $w.m -side top -fill both -padx 2 -pady 2
2723 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2724 bind $w <Key-Escape> [list destroy $w]
2725 pack $w.ok -side bottom
2726 bind $w <Visibility> "focus $w.ok"
2727 bind $w <Key-Escape> "destroy $w"
2728 bind $w <Key-Return> "destroy $w"
2731 # Procedures for manipulating the file list window at the
2732 # bottom right of the overall window.
2734 proc treeview {w l openlevs} {
2735 global treecontents treediropen treeheight treeparent treeindex
2737 set ix 0
2738 set treeindex() 0
2739 set lev 0
2740 set prefix {}
2741 set prefixend -1
2742 set prefendstack {}
2743 set htstack {}
2744 set ht 0
2745 set treecontents() {}
2746 $w conf -state normal
2747 foreach f $l {
2748 while {[string range $f 0 $prefixend] ne $prefix} {
2749 if {$lev <= $openlevs} {
2750 $w mark set e:$treeindex($prefix) "end -1c"
2751 $w mark gravity e:$treeindex($prefix) left
2753 set treeheight($prefix) $ht
2754 incr ht [lindex $htstack end]
2755 set htstack [lreplace $htstack end end]
2756 set prefixend [lindex $prefendstack end]
2757 set prefendstack [lreplace $prefendstack end end]
2758 set prefix [string range $prefix 0 $prefixend]
2759 incr lev -1
2761 set tail [string range $f [expr {$prefixend+1}] end]
2762 while {[set slash [string first "/" $tail]] >= 0} {
2763 lappend htstack $ht
2764 set ht 0
2765 lappend prefendstack $prefixend
2766 incr prefixend [expr {$slash + 1}]
2767 set d [string range $tail 0 $slash]
2768 lappend treecontents($prefix) $d
2769 set oldprefix $prefix
2770 append prefix $d
2771 set treecontents($prefix) {}
2772 set treeindex($prefix) [incr ix]
2773 set treeparent($prefix) $oldprefix
2774 set tail [string range $tail [expr {$slash+1}] end]
2775 if {$lev <= $openlevs} {
2776 set ht 1
2777 set treediropen($prefix) [expr {$lev < $openlevs}]
2778 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2779 $w mark set d:$ix "end -1c"
2780 $w mark gravity d:$ix left
2781 set str "\n"
2782 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2783 $w insert end $str
2784 $w image create end -align center -image $bm -padx 1 \
2785 -name a:$ix
2786 $w insert end $d [highlight_tag $prefix]
2787 $w mark set s:$ix "end -1c"
2788 $w mark gravity s:$ix left
2790 incr lev
2792 if {$tail ne {}} {
2793 if {$lev <= $openlevs} {
2794 incr ht
2795 set str "\n"
2796 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2797 $w insert end $str
2798 $w insert end $tail [highlight_tag $f]
2800 lappend treecontents($prefix) $tail
2803 while {$htstack ne {}} {
2804 set treeheight($prefix) $ht
2805 incr ht [lindex $htstack end]
2806 set htstack [lreplace $htstack end end]
2807 set prefixend [lindex $prefendstack end]
2808 set prefendstack [lreplace $prefendstack end end]
2809 set prefix [string range $prefix 0 $prefixend]
2811 $w conf -state disabled
2814 proc linetoelt {l} {
2815 global treeheight treecontents
2817 set y 2
2818 set prefix {}
2819 while {1} {
2820 foreach e $treecontents($prefix) {
2821 if {$y == $l} {
2822 return "$prefix$e"
2824 set n 1
2825 if {[string index $e end] eq "/"} {
2826 set n $treeheight($prefix$e)
2827 if {$y + $n > $l} {
2828 append prefix $e
2829 incr y
2830 break
2833 incr y $n
2838 proc highlight_tree {y prefix} {
2839 global treeheight treecontents cflist
2841 foreach e $treecontents($prefix) {
2842 set path $prefix$e
2843 if {[highlight_tag $path] ne {}} {
2844 $cflist tag add bold $y.0 "$y.0 lineend"
2846 incr y
2847 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2848 set y [highlight_tree $y $path]
2851 return $y
2854 proc treeclosedir {w dir} {
2855 global treediropen treeheight treeparent treeindex
2857 set ix $treeindex($dir)
2858 $w conf -state normal
2859 $w delete s:$ix e:$ix
2860 set treediropen($dir) 0
2861 $w image configure a:$ix -image tri-rt
2862 $w conf -state disabled
2863 set n [expr {1 - $treeheight($dir)}]
2864 while {$dir ne {}} {
2865 incr treeheight($dir) $n
2866 set dir $treeparent($dir)
2870 proc treeopendir {w dir} {
2871 global treediropen treeheight treeparent treecontents treeindex
2873 set ix $treeindex($dir)
2874 $w conf -state normal
2875 $w image configure a:$ix -image tri-dn
2876 $w mark set e:$ix s:$ix
2877 $w mark gravity e:$ix right
2878 set lev 0
2879 set str "\n"
2880 set n [llength $treecontents($dir)]
2881 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2882 incr lev
2883 append str "\t"
2884 incr treeheight($x) $n
2886 foreach e $treecontents($dir) {
2887 set de $dir$e
2888 if {[string index $e end] eq "/"} {
2889 set iy $treeindex($de)
2890 $w mark set d:$iy e:$ix
2891 $w mark gravity d:$iy left
2892 $w insert e:$ix $str
2893 set treediropen($de) 0
2894 $w image create e:$ix -align center -image tri-rt -padx 1 \
2895 -name a:$iy
2896 $w insert e:$ix $e [highlight_tag $de]
2897 $w mark set s:$iy e:$ix
2898 $w mark gravity s:$iy left
2899 set treeheight($de) 1
2900 } else {
2901 $w insert e:$ix $str
2902 $w insert e:$ix $e [highlight_tag $de]
2905 $w mark gravity e:$ix right
2906 $w conf -state disabled
2907 set treediropen($dir) 1
2908 set top [lindex [split [$w index @0,0] .] 0]
2909 set ht [$w cget -height]
2910 set l [lindex [split [$w index s:$ix] .] 0]
2911 if {$l < $top} {
2912 $w yview $l.0
2913 } elseif {$l + $n + 1 > $top + $ht} {
2914 set top [expr {$l + $n + 2 - $ht}]
2915 if {$l < $top} {
2916 set top $l
2918 $w yview $top.0
2922 proc treeclick {w x y} {
2923 global treediropen cmitmode ctext cflist cflist_top
2925 if {$cmitmode ne "tree"} return
2926 if {![info exists cflist_top]} return
2927 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2928 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2929 $cflist tag add highlight $l.0 "$l.0 lineend"
2930 set cflist_top $l
2931 if {$l == 1} {
2932 $ctext yview 1.0
2933 return
2935 set e [linetoelt $l]
2936 if {[string index $e end] ne "/"} {
2937 showfile $e
2938 } elseif {$treediropen($e)} {
2939 treeclosedir $w $e
2940 } else {
2941 treeopendir $w $e
2945 proc setfilelist {id} {
2946 global treefilelist cflist jump_to_here
2948 treeview $cflist $treefilelist($id) 0
2949 if {$jump_to_here ne {}} {
2950 set f [lindex $jump_to_here 0]
2951 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2952 showfile $f
2957 image create bitmap tri-rt -background black -foreground blue -data {
2958 #define tri-rt_width 13
2959 #define tri-rt_height 13
2960 static unsigned char tri-rt_bits[] = {
2961 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2962 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2963 0x00, 0x00};
2964 } -maskdata {
2965 #define tri-rt-mask_width 13
2966 #define tri-rt-mask_height 13
2967 static unsigned char tri-rt-mask_bits[] = {
2968 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2969 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2970 0x08, 0x00};
2972 image create bitmap tri-dn -background black -foreground blue -data {
2973 #define tri-dn_width 13
2974 #define tri-dn_height 13
2975 static unsigned char tri-dn_bits[] = {
2976 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2977 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2978 0x00, 0x00};
2979 } -maskdata {
2980 #define tri-dn-mask_width 13
2981 #define tri-dn-mask_height 13
2982 static unsigned char tri-dn-mask_bits[] = {
2983 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2984 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2985 0x00, 0x00};
2988 image create bitmap reficon-T -background black -foreground yellow -data {
2989 #define tagicon_width 13
2990 #define tagicon_height 9
2991 static unsigned char tagicon_bits[] = {
2992 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2993 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2994 } -maskdata {
2995 #define tagicon-mask_width 13
2996 #define tagicon-mask_height 9
2997 static unsigned char tagicon-mask_bits[] = {
2998 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2999 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3001 set rectdata {
3002 #define headicon_width 13
3003 #define headicon_height 9
3004 static unsigned char headicon_bits[] = {
3005 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3006 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3008 set rectmask {
3009 #define headicon-mask_width 13
3010 #define headicon-mask_height 9
3011 static unsigned char headicon-mask_bits[] = {
3012 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3013 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3015 image create bitmap reficon-H -background black -foreground green \
3016 -data $rectdata -maskdata $rectmask
3017 image create bitmap reficon-o -background black -foreground "#ddddff" \
3018 -data $rectdata -maskdata $rectmask
3020 proc init_flist {first} {
3021 global cflist cflist_top difffilestart
3023 $cflist conf -state normal
3024 $cflist delete 0.0 end
3025 if {$first ne {}} {
3026 $cflist insert end $first
3027 set cflist_top 1
3028 $cflist tag add highlight 1.0 "1.0 lineend"
3029 } else {
3030 catch {unset cflist_top}
3032 $cflist conf -state disabled
3033 set difffilestart {}
3036 proc highlight_tag {f} {
3037 global highlight_paths
3039 foreach p $highlight_paths {
3040 if {[string match $p $f]} {
3041 return "bold"
3044 return {}
3047 proc highlight_filelist {} {
3048 global cmitmode cflist
3050 $cflist conf -state normal
3051 if {$cmitmode ne "tree"} {
3052 set end [lindex [split [$cflist index end] .] 0]
3053 for {set l 2} {$l < $end} {incr l} {
3054 set line [$cflist get $l.0 "$l.0 lineend"]
3055 if {[highlight_tag $line] ne {}} {
3056 $cflist tag add bold $l.0 "$l.0 lineend"
3059 } else {
3060 highlight_tree 2 {}
3062 $cflist conf -state disabled
3065 proc unhighlight_filelist {} {
3066 global cflist
3068 $cflist conf -state normal
3069 $cflist tag remove bold 1.0 end
3070 $cflist conf -state disabled
3073 proc add_flist {fl} {
3074 global cflist
3076 $cflist conf -state normal
3077 foreach f $fl {
3078 $cflist insert end "\n"
3079 $cflist insert end $f [highlight_tag $f]
3081 $cflist conf -state disabled
3084 proc sel_flist {w x y} {
3085 global ctext difffilestart cflist cflist_top cmitmode
3087 if {$cmitmode eq "tree"} return
3088 if {![info exists cflist_top]} return
3089 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3090 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3091 $cflist tag add highlight $l.0 "$l.0 lineend"
3092 set cflist_top $l
3093 if {$l == 1} {
3094 $ctext yview 1.0
3095 } else {
3096 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3100 proc pop_flist_menu {w X Y x y} {
3101 global ctext cflist cmitmode flist_menu flist_menu_file
3102 global treediffs diffids
3104 stopfinding
3105 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3106 if {$l <= 1} return
3107 if {$cmitmode eq "tree"} {
3108 set e [linetoelt $l]
3109 if {[string index $e end] eq "/"} return
3110 } else {
3111 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3113 set flist_menu_file $e
3114 set xdiffstate "normal"
3115 if {$cmitmode eq "tree"} {
3116 set xdiffstate "disabled"
3118 # Disable "External diff" item in tree mode
3119 $flist_menu entryconf 2 -state $xdiffstate
3120 tk_popup $flist_menu $X $Y
3123 proc find_ctext_fileinfo {line} {
3124 global ctext_file_names ctext_file_lines
3126 set ok [bsearch $ctext_file_lines $line]
3127 set tline [lindex $ctext_file_lines $ok]
3129 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3130 return {}
3131 } else {
3132 return [list [lindex $ctext_file_names $ok] $tline]
3136 proc pop_diff_menu {w X Y x y} {
3137 global ctext diff_menu flist_menu_file
3138 global diff_menu_txtpos diff_menu_line
3139 global diff_menu_filebase
3141 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3142 set diff_menu_line [lindex $diff_menu_txtpos 0]
3143 # don't pop up the menu on hunk-separator or file-separator lines
3144 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3145 return
3147 stopfinding
3148 set f [find_ctext_fileinfo $diff_menu_line]
3149 if {$f eq {}} return
3150 set flist_menu_file [lindex $f 0]
3151 set diff_menu_filebase [lindex $f 1]
3152 tk_popup $diff_menu $X $Y
3155 proc flist_hl {only} {
3156 global flist_menu_file findstring gdttype
3158 set x [shellquote $flist_menu_file]
3159 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3160 set findstring $x
3161 } else {
3162 append findstring " " $x
3164 set gdttype [mc "touching paths:"]
3167 proc save_file_from_commit {filename output what} {
3168 global nullfile
3170 if {[catch {exec git show $filename -- > $output} err]} {
3171 if {[string match "fatal: bad revision *" $err]} {
3172 return $nullfile
3174 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3175 return {}
3177 return $output
3180 proc external_diff_get_one_file {diffid filename diffdir} {
3181 global nullid nullid2 nullfile
3182 global gitdir
3184 if {$diffid == $nullid} {
3185 set difffile [file join [file dirname $gitdir] $filename]
3186 if {[file exists $difffile]} {
3187 return $difffile
3189 return $nullfile
3191 if {$diffid == $nullid2} {
3192 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3193 return [save_file_from_commit :$filename $difffile index]
3195 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3196 return [save_file_from_commit $diffid:$filename $difffile \
3197 "revision $diffid"]
3200 proc external_diff {} {
3201 global gitktmpdir nullid nullid2
3202 global flist_menu_file
3203 global diffids
3204 global diffnum
3205 global gitdir extdifftool
3207 if {[llength $diffids] == 1} {
3208 # no reference commit given
3209 set diffidto [lindex $diffids 0]
3210 if {$diffidto eq $nullid} {
3211 # diffing working copy with index
3212 set diffidfrom $nullid2
3213 } elseif {$diffidto eq $nullid2} {
3214 # diffing index with HEAD
3215 set diffidfrom "HEAD"
3216 } else {
3217 # use first parent commit
3218 global parentlist selectedline
3219 set diffidfrom [lindex $parentlist $selectedline 0]
3221 } else {
3222 set diffidfrom [lindex $diffids 0]
3223 set diffidto [lindex $diffids 1]
3226 # make sure that several diffs wont collide
3227 if {![info exists gitktmpdir]} {
3228 set gitktmpdir [file join [file dirname $gitdir] \
3229 [format ".gitk-tmp.%s" [pid]]]
3230 if {[catch {file mkdir $gitktmpdir} err]} {
3231 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3232 unset gitktmpdir
3233 return
3235 set diffnum 0
3237 incr diffnum
3238 set diffdir [file join $gitktmpdir $diffnum]
3239 if {[catch {file mkdir $diffdir} err]} {
3240 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3241 return
3244 # gather files to diff
3245 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3246 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3248 if {$difffromfile ne {} && $difftofile ne {}} {
3249 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3250 if {[catch {set fl [open |$cmd r]} err]} {
3251 file delete -force $diffdir
3252 error_popup "$extdifftool: [mc "command failed:"] $err"
3253 } else {
3254 fconfigure $fl -blocking 0
3255 filerun $fl [list delete_at_eof $fl $diffdir]
3260 proc find_hunk_blamespec {base line} {
3261 global ctext
3263 # Find and parse the hunk header
3264 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3265 if {$s_lix eq {}} return
3267 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3268 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3269 s_line old_specs osz osz1 new_line nsz]} {
3270 return
3273 # base lines for the parents
3274 set base_lines [list $new_line]
3275 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3276 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3277 old_spec old_line osz]} {
3278 return
3280 lappend base_lines $old_line
3283 # Now scan the lines to determine offset within the hunk
3284 set max_parent [expr {[llength $base_lines]-2}]
3285 set dline 0
3286 set s_lno [lindex [split $s_lix "."] 0]
3288 # Determine if the line is removed
3289 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3290 if {[string match {[-+ ]*} $chunk]} {
3291 set removed_idx [string first "-" $chunk]
3292 # Choose a parent index
3293 if {$removed_idx >= 0} {
3294 set parent $removed_idx
3295 } else {
3296 set unchanged_idx [string first " " $chunk]
3297 if {$unchanged_idx >= 0} {
3298 set parent $unchanged_idx
3299 } else {
3300 # blame the current commit
3301 set parent -1
3304 # then count other lines that belong to it
3305 for {set i $line} {[incr i -1] > $s_lno} {} {
3306 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3307 # Determine if the line is removed
3308 set removed_idx [string first "-" $chunk]
3309 if {$parent >= 0} {
3310 set code [string index $chunk $parent]
3311 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3312 incr dline
3314 } else {
3315 if {$removed_idx < 0} {
3316 incr dline
3320 incr parent
3321 } else {
3322 set parent 0
3325 incr dline [lindex $base_lines $parent]
3326 return [list $parent $dline]
3329 proc external_blame_diff {} {
3330 global currentid cmitmode
3331 global diff_menu_txtpos diff_menu_line
3332 global diff_menu_filebase flist_menu_file
3334 if {$cmitmode eq "tree"} {
3335 set parent_idx 0
3336 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3337 } else {
3338 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3339 if {$hinfo ne {}} {
3340 set parent_idx [lindex $hinfo 0]
3341 set line [lindex $hinfo 1]
3342 } else {
3343 set parent_idx 0
3344 set line 0
3348 external_blame $parent_idx $line
3351 # Find the SHA1 ID of the blob for file $fname in the index
3352 # at stage 0 or 2
3353 proc index_sha1 {fname} {
3354 set f [open [list | git ls-files -s $fname] r]
3355 while {[gets $f line] >= 0} {
3356 set info [lindex [split $line "\t"] 0]
3357 set stage [lindex $info 2]
3358 if {$stage eq "0" || $stage eq "2"} {
3359 close $f
3360 return [lindex $info 1]
3363 close $f
3364 return {}
3367 # Turn an absolute path into one relative to the current directory
3368 proc make_relative {f} {
3369 set elts [file split $f]
3370 set here [file split [pwd]]
3371 set ei 0
3372 set hi 0
3373 set res {}
3374 foreach d $here {
3375 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3376 lappend res ".."
3377 } else {
3378 incr ei
3380 incr hi
3382 set elts [concat $res [lrange $elts $ei end]]
3383 return [eval file join $elts]
3386 proc external_blame {parent_idx {line {}}} {
3387 global flist_menu_file gitdir
3388 global nullid nullid2
3389 global parentlist selectedline currentid
3391 if {$parent_idx > 0} {
3392 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3393 } else {
3394 set base_commit $currentid
3397 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3398 error_popup [mc "No such commit"]
3399 return
3402 set cmdline [list git gui blame]
3403 if {$line ne {} && $line > 1} {
3404 lappend cmdline "--line=$line"
3406 set f [file join [file dirname $gitdir] $flist_menu_file]
3407 # Unfortunately it seems git gui blame doesn't like
3408 # being given an absolute path...
3409 set f [make_relative $f]
3410 lappend cmdline $base_commit $f
3411 if {[catch {eval exec $cmdline &} err]} {
3412 error_popup "[mc "git gui blame: command failed:"] $err"
3416 proc show_line_source {} {
3417 global cmitmode currentid parents curview blamestuff blameinst
3418 global diff_menu_line diff_menu_filebase flist_menu_file
3419 global nullid nullid2 gitdir
3421 set from_index {}
3422 if {$cmitmode eq "tree"} {
3423 set id $currentid
3424 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3425 } else {
3426 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3427 if {$h eq {}} return
3428 set pi [lindex $h 0]
3429 if {$pi == 0} {
3430 mark_ctext_line $diff_menu_line
3431 return
3433 incr pi -1
3434 if {$currentid eq $nullid} {
3435 if {$pi > 0} {
3436 # must be a merge in progress...
3437 if {[catch {
3438 # get the last line from .git/MERGE_HEAD
3439 set f [open [file join $gitdir MERGE_HEAD] r]
3440 set id [lindex [split [read $f] "\n"] end-1]
3441 close $f
3442 } err]} {
3443 error_popup [mc "Couldn't read merge head: %s" $err]
3444 return
3446 } elseif {$parents($curview,$currentid) eq $nullid2} {
3447 # need to do the blame from the index
3448 if {[catch {
3449 set from_index [index_sha1 $flist_menu_file]
3450 } err]} {
3451 error_popup [mc "Error reading index: %s" $err]
3452 return
3454 } else {
3455 set id $parents($curview,$currentid)
3457 } else {
3458 set id [lindex $parents($curview,$currentid) $pi]
3460 set line [lindex $h 1]
3462 set blameargs {}
3463 if {$from_index ne {}} {
3464 lappend blameargs | git cat-file blob $from_index
3466 lappend blameargs | git blame -p -L$line,+1
3467 if {$from_index ne {}} {
3468 lappend blameargs --contents -
3469 } else {
3470 lappend blameargs $id
3472 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3473 if {[catch {
3474 set f [open $blameargs r]
3475 } err]} {
3476 error_popup [mc "Couldn't start git blame: %s" $err]
3477 return
3479 nowbusy blaming [mc "Searching"]
3480 fconfigure $f -blocking 0
3481 set i [reg_instance $f]
3482 set blamestuff($i) {}
3483 set blameinst $i
3484 filerun $f [list read_line_source $f $i]
3487 proc stopblaming {} {
3488 global blameinst
3490 if {[info exists blameinst]} {
3491 stop_instance $blameinst
3492 unset blameinst
3493 notbusy blaming
3497 proc read_line_source {fd inst} {
3498 global blamestuff curview commfd blameinst nullid nullid2
3500 while {[gets $fd line] >= 0} {
3501 lappend blamestuff($inst) $line
3503 if {![eof $fd]} {
3504 return 1
3506 unset commfd($inst)
3507 unset blameinst
3508 notbusy blaming
3509 fconfigure $fd -blocking 1
3510 if {[catch {close $fd} err]} {
3511 error_popup [mc "Error running git blame: %s" $err]
3512 return 0
3515 set fname {}
3516 set line [split [lindex $blamestuff($inst) 0] " "]
3517 set id [lindex $line 0]
3518 set lnum [lindex $line 1]
3519 if {[string length $id] == 40 && [string is xdigit $id] &&
3520 [string is digit -strict $lnum]} {
3521 # look for "filename" line
3522 foreach l $blamestuff($inst) {
3523 if {[string match "filename *" $l]} {
3524 set fname [string range $l 9 end]
3525 break
3529 if {$fname ne {}} {
3530 # all looks good, select it
3531 if {$id eq $nullid} {
3532 # blame uses all-zeroes to mean not committed,
3533 # which would mean a change in the index
3534 set id $nullid2
3536 if {[commitinview $id $curview]} {
3537 selectline [rowofcommit $id] 1 [list $fname $lnum]
3538 } else {
3539 error_popup [mc "That line comes from commit %s, \
3540 which is not in this view" [shortids $id]]
3542 } else {
3543 puts "oops couldn't parse git blame output"
3545 return 0
3548 # delete $dir when we see eof on $f (presumably because the child has exited)
3549 proc delete_at_eof {f dir} {
3550 while {[gets $f line] >= 0} {}
3551 if {[eof $f]} {
3552 if {[catch {close $f} err]} {
3553 error_popup "[mc "External diff viewer failed:"] $err"
3555 file delete -force $dir
3556 return 0
3558 return 1
3561 # Functions for adding and removing shell-type quoting
3563 proc shellquote {str} {
3564 if {![string match "*\['\"\\ \t]*" $str]} {
3565 return $str
3567 if {![string match "*\['\"\\]*" $str]} {
3568 return "\"$str\""
3570 if {![string match "*'*" $str]} {
3571 return "'$str'"
3573 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3576 proc shellarglist {l} {
3577 set str {}
3578 foreach a $l {
3579 if {$str ne {}} {
3580 append str " "
3582 append str [shellquote $a]
3584 return $str
3587 proc shelldequote {str} {
3588 set ret {}
3589 set used -1
3590 while {1} {
3591 incr used
3592 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3593 append ret [string range $str $used end]
3594 set used [string length $str]
3595 break
3597 set first [lindex $first 0]
3598 set ch [string index $str $first]
3599 if {$first > $used} {
3600 append ret [string range $str $used [expr {$first - 1}]]
3601 set used $first
3603 if {$ch eq " " || $ch eq "\t"} break
3604 incr used
3605 if {$ch eq "'"} {
3606 set first [string first "'" $str $used]
3607 if {$first < 0} {
3608 error "unmatched single-quote"
3610 append ret [string range $str $used [expr {$first - 1}]]
3611 set used $first
3612 continue
3614 if {$ch eq "\\"} {
3615 if {$used >= [string length $str]} {
3616 error "trailing backslash"
3618 append ret [string index $str $used]
3619 continue
3621 # here ch == "\""
3622 while {1} {
3623 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3624 error "unmatched double-quote"
3626 set first [lindex $first 0]
3627 set ch [string index $str $first]
3628 if {$first > $used} {
3629 append ret [string range $str $used [expr {$first - 1}]]
3630 set used $first
3632 if {$ch eq "\""} break
3633 incr used
3634 append ret [string index $str $used]
3635 incr used
3638 return [list $used $ret]
3641 proc shellsplit {str} {
3642 set l {}
3643 while {1} {
3644 set str [string trimleft $str]
3645 if {$str eq {}} break
3646 set dq [shelldequote $str]
3647 set n [lindex $dq 0]
3648 set word [lindex $dq 1]
3649 set str [string range $str $n end]
3650 lappend l $word
3652 return $l
3655 # Code to implement multiple views
3657 proc newview {ishighlight} {
3658 global nextviewnum newviewname newishighlight
3659 global revtreeargs viewargscmd newviewopts curview
3661 set newishighlight $ishighlight
3662 set top .gitkview
3663 if {[winfo exists $top]} {
3664 raise $top
3665 return
3667 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3668 set newviewopts($nextviewnum,perm) 0
3669 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3670 decode_view_opts $nextviewnum $revtreeargs
3671 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3674 set known_view_options {
3675 {perm b . {} {mc "Remember this view"}}
3676 {reflabel l + {} {mc "References (space separated list):"}}
3677 {refs t15 .. {} {mc "Branches & tags:"}}
3678 {allrefs b *. "--all" {mc "All refs"}}
3679 {branches b . "--branches" {mc "All (local) branches"}}
3680 {tags b . "--tags" {mc "All tags"}}
3681 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3682 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3683 {author t15 .. "--author=*" {mc "Author:"}}
3684 {committer t15 . "--committer=*" {mc "Committer:"}}
3685 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3686 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3687 {changes_l l + {} {mc "Changes to Files:"}}
3688 {pickaxe_s r0 . {} {mc "Fixed String"}}
3689 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3690 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3691 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3692 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3693 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3694 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3695 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3696 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3697 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3698 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3699 {lright b . "--left-right" {mc "Mark branch sides"}}
3700 {first b . "--first-parent" {mc "Limit to first parent"}}
3701 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3702 {args t50 *. {} {mc "Additional arguments to git log:"}}
3703 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3704 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3707 proc encode_view_opts {n} {
3708 global known_view_options newviewopts
3710 set rargs [list]
3711 foreach opt $known_view_options {
3712 set patterns [lindex $opt 3]
3713 if {$patterns eq {}} continue
3714 set pattern [lindex $patterns 0]
3716 if {[lindex $opt 1] eq "b"} {
3717 set val $newviewopts($n,[lindex $opt 0])
3718 if {$val} {
3719 lappend rargs $pattern
3721 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3722 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3723 set val $newviewopts($n,$button_id)
3724 if {$val eq $value} {
3725 lappend rargs $pattern
3727 } else {
3728 set val $newviewopts($n,[lindex $opt 0])
3729 set val [string trim $val]
3730 if {$val ne {}} {
3731 set pfix [string range $pattern 0 end-1]
3732 lappend rargs $pfix$val
3736 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3737 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3740 proc decode_view_opts {n view_args} {
3741 global known_view_options newviewopts
3743 foreach opt $known_view_options {
3744 set id [lindex $opt 0]
3745 if {[lindex $opt 1] eq "b"} {
3746 # Checkboxes
3747 set val 0
3748 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3749 # Radiobuttons
3750 regexp {^(.*_)} $id uselessvar id
3751 set val 0
3752 } else {
3753 # Text fields
3754 set val {}
3756 set newviewopts($n,$id) $val
3758 set oargs [list]
3759 set refargs [list]
3760 foreach arg $view_args {
3761 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3762 && ![info exists found(limit)]} {
3763 set newviewopts($n,limit) $cnt
3764 set found(limit) 1
3765 continue
3767 catch { unset val }
3768 foreach opt $known_view_options {
3769 set id [lindex $opt 0]
3770 if {[info exists found($id)]} continue
3771 foreach pattern [lindex $opt 3] {
3772 if {![string match $pattern $arg]} continue
3773 if {[lindex $opt 1] eq "b"} {
3774 # Check buttons
3775 set val 1
3776 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3777 # Radio buttons
3778 regexp {^(.*_)} $id uselessvar id
3779 set val $num
3780 } else {
3781 # Text input fields
3782 set size [string length $pattern]
3783 set val [string range $arg [expr {$size-1}] end]
3785 set newviewopts($n,$id) $val
3786 set found($id) 1
3787 break
3789 if {[info exists val]} break
3791 if {[info exists val]} continue
3792 if {[regexp {^-} $arg]} {
3793 lappend oargs $arg
3794 } else {
3795 lappend refargs $arg
3798 set newviewopts($n,refs) [shellarglist $refargs]
3799 set newviewopts($n,args) [shellarglist $oargs]
3802 proc edit_or_newview {} {
3803 global curview
3805 if {$curview > 0} {
3806 editview
3807 } else {
3808 newview 0
3812 proc editview {} {
3813 global curview
3814 global viewname viewperm newviewname newviewopts
3815 global viewargs viewargscmd
3817 set top .gitkvedit-$curview
3818 if {[winfo exists $top]} {
3819 raise $top
3820 return
3822 set newviewname($curview) $viewname($curview)
3823 set newviewopts($curview,perm) $viewperm($curview)
3824 set newviewopts($curview,cmd) $viewargscmd($curview)
3825 decode_view_opts $curview $viewargs($curview)
3826 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3829 proc vieweditor {top n title} {
3830 global newviewname newviewopts viewfiles bgcolor
3831 global known_view_options
3833 toplevel $top
3834 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3835 make_transient $top .
3837 # View name
3838 frame $top.nfr
3839 label $top.nl -text [mc "View Name:"]
3840 entry $top.name -width 20 -textvariable newviewname($n)
3841 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3842 pack $top.nl -in $top.nfr -side left -padx {0 5}
3843 pack $top.name -in $top.nfr -side left -padx {0 25}
3845 # View options
3846 set cframe $top.nfr
3847 set cexpand 0
3848 set cnt 0
3849 foreach opt $known_view_options {
3850 set id [lindex $opt 0]
3851 set type [lindex $opt 1]
3852 set flags [lindex $opt 2]
3853 set title [eval [lindex $opt 4]]
3854 set lxpad 0
3856 if {$flags eq "+" || $flags eq "*"} {
3857 set cframe $top.fr$cnt
3858 incr cnt
3859 frame $cframe
3860 pack $cframe -in $top -fill x -pady 3 -padx 3
3861 set cexpand [expr {$flags eq "*"}]
3862 } elseif {$flags eq ".." || $flags eq "*."} {
3863 set cframe $top.fr$cnt
3864 incr cnt
3865 frame $cframe
3866 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
3867 set cexpand [expr {$flags eq "*."}]
3868 } else {
3869 set lxpad 5
3872 if {$type eq "l"} {
3873 label $cframe.l_$id -text $title
3874 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
3875 } elseif {$type eq "b"} {
3876 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3877 pack $cframe.c_$id -in $cframe -side left \
3878 -padx [list $lxpad 0] -expand $cexpand -anchor w
3879 } elseif {[regexp {^r(\d+)$} $type type sz]} {
3880 regexp {^(.*_)} $id uselessvar button_id
3881 radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
3882 pack $cframe.c_$id -in $cframe -side left \
3883 -padx [list $lxpad 0] -expand $cexpand -anchor w
3884 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3885 message $cframe.l_$id -aspect 1500 -text $title
3886 entry $cframe.e_$id -width $sz -background $bgcolor \
3887 -textvariable newviewopts($n,$id)
3888 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3889 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3890 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3891 message $cframe.l_$id -aspect 1500 -text $title
3892 entry $cframe.e_$id -width $sz -background $bgcolor \
3893 -textvariable newviewopts($n,$id)
3894 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3895 pack $cframe.e_$id -in $cframe -side top -fill x
3896 } elseif {$type eq "path"} {
3897 message $top.l -aspect 1500 -text $title
3898 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
3899 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3900 if {[info exists viewfiles($n)]} {
3901 foreach f $viewfiles($n) {
3902 $top.t insert end $f
3903 $top.t insert end "\n"
3905 $top.t delete {end - 1c} end
3906 $top.t mark set insert 0.0
3908 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3912 frame $top.buts
3913 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3914 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3915 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3916 bind $top <Control-Return> [list newviewok $top $n]
3917 bind $top <F5> [list newviewok $top $n 1]
3918 bind $top <Escape> [list destroy $top]
3919 grid $top.buts.ok $top.buts.apply $top.buts.can
3920 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3921 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3922 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3923 pack $top.buts -in $top -side top -fill x
3924 focus $top.t
3927 proc doviewmenu {m first cmd op argv} {
3928 set nmenu [$m index end]
3929 for {set i $first} {$i <= $nmenu} {incr i} {
3930 if {[$m entrycget $i -command] eq $cmd} {
3931 eval $m $op $i $argv
3932 break
3937 proc allviewmenus {n op args} {
3938 # global viewhlmenu
3940 doviewmenu .bar.view 5 [list showview $n] $op $args
3941 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3944 proc newviewok {top n {apply 0}} {
3945 global nextviewnum newviewperm newviewname newishighlight
3946 global viewname viewfiles viewperm selectedview curview
3947 global viewargs viewargscmd newviewopts viewhlmenu
3949 if {[catch {
3950 set newargs [encode_view_opts $n]
3951 } err]} {
3952 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3953 return
3955 set files {}
3956 foreach f [split [$top.t get 0.0 end] "\n"] {
3957 set ft [string trim $f]
3958 if {$ft ne {}} {
3959 lappend files $ft
3962 if {![info exists viewfiles($n)]} {
3963 # creating a new view
3964 incr nextviewnum
3965 set viewname($n) $newviewname($n)
3966 set viewperm($n) $newviewopts($n,perm)
3967 set viewfiles($n) $files
3968 set viewargs($n) $newargs
3969 set viewargscmd($n) $newviewopts($n,cmd)
3970 addviewmenu $n
3971 if {!$newishighlight} {
3972 run showview $n
3973 } else {
3974 run addvhighlight $n
3976 } else {
3977 # editing an existing view
3978 set viewperm($n) $newviewopts($n,perm)
3979 if {$newviewname($n) ne $viewname($n)} {
3980 set viewname($n) $newviewname($n)
3981 doviewmenu .bar.view 5 [list showview $n] \
3982 entryconf [list -label $viewname($n)]
3983 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3984 # entryconf [list -label $viewname($n) -value $viewname($n)]
3986 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3987 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3988 set viewfiles($n) $files
3989 set viewargs($n) $newargs
3990 set viewargscmd($n) $newviewopts($n,cmd)
3991 if {$curview == $n} {
3992 run reloadcommits
3996 if {$apply} return
3997 catch {destroy $top}
4000 proc delview {} {
4001 global curview viewperm hlview selectedhlview
4003 if {$curview == 0} return
4004 if {[info exists hlview] && $hlview == $curview} {
4005 set selectedhlview [mc "None"]
4006 unset hlview
4008 allviewmenus $curview delete
4009 set viewperm($curview) 0
4010 showview 0
4013 proc addviewmenu {n} {
4014 global viewname viewhlmenu
4016 .bar.view add radiobutton -label $viewname($n) \
4017 -command [list showview $n] -variable selectedview -value $n
4018 #$viewhlmenu add radiobutton -label $viewname($n) \
4019 # -command [list addvhighlight $n] -variable selectedhlview
4022 proc showview {n} {
4023 global curview cached_commitrow ordertok
4024 global displayorder parentlist rowidlist rowisopt rowfinal
4025 global colormap rowtextx nextcolor canvxmax
4026 global numcommits viewcomplete
4027 global selectedline currentid canv canvy0
4028 global treediffs
4029 global pending_select mainheadid
4030 global commitidx
4031 global selectedview
4032 global hlview selectedhlview commitinterest
4034 if {$n == $curview} return
4035 set selid {}
4036 set ymax [lindex [$canv cget -scrollregion] 3]
4037 set span [$canv yview]
4038 set ytop [expr {[lindex $span 0] * $ymax}]
4039 set ybot [expr {[lindex $span 1] * $ymax}]
4040 set yscreen [expr {($ybot - $ytop) / 2}]
4041 if {$selectedline ne {}} {
4042 set selid $currentid
4043 set y [yc $selectedline]
4044 if {$ytop < $y && $y < $ybot} {
4045 set yscreen [expr {$y - $ytop}]
4047 } elseif {[info exists pending_select]} {
4048 set selid $pending_select
4049 unset pending_select
4051 unselectline
4052 normalline
4053 catch {unset treediffs}
4054 clear_display
4055 if {[info exists hlview] && $hlview == $n} {
4056 unset hlview
4057 set selectedhlview [mc "None"]
4059 catch {unset commitinterest}
4060 catch {unset cached_commitrow}
4061 catch {unset ordertok}
4063 set curview $n
4064 set selectedview $n
4065 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4066 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4068 run refill_reflist
4069 if {![info exists viewcomplete($n)]} {
4070 getcommits $selid
4071 return
4074 set displayorder {}
4075 set parentlist {}
4076 set rowidlist {}
4077 set rowisopt {}
4078 set rowfinal {}
4079 set numcommits $commitidx($n)
4081 catch {unset colormap}
4082 catch {unset rowtextx}
4083 set nextcolor 0
4084 set canvxmax [$canv cget -width]
4085 set curview $n
4086 set row 0
4087 setcanvscroll
4088 set yf 0
4089 set row {}
4090 if {$selid ne {} && [commitinview $selid $n]} {
4091 set row [rowofcommit $selid]
4092 # try to get the selected row in the same position on the screen
4093 set ymax [lindex [$canv cget -scrollregion] 3]
4094 set ytop [expr {[yc $row] - $yscreen}]
4095 if {$ytop < 0} {
4096 set ytop 0
4098 set yf [expr {$ytop * 1.0 / $ymax}]
4100 allcanvs yview moveto $yf
4101 drawvisible
4102 if {$row ne {}} {
4103 selectline $row 0
4104 } elseif {!$viewcomplete($n)} {
4105 reset_pending_select $selid
4106 } else {
4107 reset_pending_select {}
4109 if {[commitinview $pending_select $curview]} {
4110 selectline [rowofcommit $pending_select] 1
4111 } else {
4112 set row [first_real_row]
4113 if {$row < $numcommits} {
4114 selectline $row 0
4118 if {!$viewcomplete($n)} {
4119 if {$numcommits == 0} {
4120 show_status [mc "Reading commits..."]
4122 } elseif {$numcommits == 0} {
4123 show_status [mc "No commits selected"]
4127 # Stuff relating to the highlighting facility
4129 proc ishighlighted {id} {
4130 global vhighlights fhighlights nhighlights rhighlights
4132 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4133 return $nhighlights($id)
4135 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4136 return $vhighlights($id)
4138 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4139 return $fhighlights($id)
4141 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4142 return $rhighlights($id)
4144 return 0
4147 proc bolden {id font} {
4148 global canv linehtag currentid boldids need_redisplay markedid
4150 # need_redisplay = 1 means the display is stale and about to be redrawn
4151 if {$need_redisplay} return
4152 lappend boldids $id
4153 $canv itemconf $linehtag($id) -font $font
4154 if {[info exists currentid] && $id eq $currentid} {
4155 $canv delete secsel
4156 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4157 -outline {{}} -tags secsel \
4158 -fill [$canv cget -selectbackground]]
4159 $canv lower $t
4161 if {[info exists markedid] && $id eq $markedid} {
4162 make_idmark $id
4166 proc bolden_name {id font} {
4167 global canv2 linentag currentid boldnameids need_redisplay
4169 if {$need_redisplay} return
4170 lappend boldnameids $id
4171 $canv2 itemconf $linentag($id) -font $font
4172 if {[info exists currentid] && $id eq $currentid} {
4173 $canv2 delete secsel
4174 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4175 -outline {{}} -tags secsel \
4176 -fill [$canv2 cget -selectbackground]]
4177 $canv2 lower $t
4181 proc unbolden {} {
4182 global boldids
4184 set stillbold {}
4185 foreach id $boldids {
4186 if {![ishighlighted $id]} {
4187 bolden $id mainfont
4188 } else {
4189 lappend stillbold $id
4192 set boldids $stillbold
4195 proc addvhighlight {n} {
4196 global hlview viewcomplete curview vhl_done commitidx
4198 if {[info exists hlview]} {
4199 delvhighlight
4201 set hlview $n
4202 if {$n != $curview && ![info exists viewcomplete($n)]} {
4203 start_rev_list $n
4205 set vhl_done $commitidx($hlview)
4206 if {$vhl_done > 0} {
4207 drawvisible
4211 proc delvhighlight {} {
4212 global hlview vhighlights
4214 if {![info exists hlview]} return
4215 unset hlview
4216 catch {unset vhighlights}
4217 unbolden
4220 proc vhighlightmore {} {
4221 global hlview vhl_done commitidx vhighlights curview
4223 set max $commitidx($hlview)
4224 set vr [visiblerows]
4225 set r0 [lindex $vr 0]
4226 set r1 [lindex $vr 1]
4227 for {set i $vhl_done} {$i < $max} {incr i} {
4228 set id [commitonrow $i $hlview]
4229 if {[commitinview $id $curview]} {
4230 set row [rowofcommit $id]
4231 if {$r0 <= $row && $row <= $r1} {
4232 if {![highlighted $row]} {
4233 bolden $id mainfontbold
4235 set vhighlights($id) 1
4239 set vhl_done $max
4240 return 0
4243 proc askvhighlight {row id} {
4244 global hlview vhighlights iddrawn
4246 if {[commitinview $id $hlview]} {
4247 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4248 bolden $id mainfontbold
4250 set vhighlights($id) 1
4251 } else {
4252 set vhighlights($id) 0
4256 proc hfiles_change {} {
4257 global highlight_files filehighlight fhighlights fh_serial
4258 global highlight_paths
4260 if {[info exists filehighlight]} {
4261 # delete previous highlights
4262 catch {close $filehighlight}
4263 unset filehighlight
4264 catch {unset fhighlights}
4265 unbolden
4266 unhighlight_filelist
4268 set highlight_paths {}
4269 after cancel do_file_hl $fh_serial
4270 incr fh_serial
4271 if {$highlight_files ne {}} {
4272 after 300 do_file_hl $fh_serial
4276 proc gdttype_change {name ix op} {
4277 global gdttype highlight_files findstring findpattern
4279 stopfinding
4280 if {$findstring ne {}} {
4281 if {$gdttype eq [mc "containing:"]} {
4282 if {$highlight_files ne {}} {
4283 set highlight_files {}
4284 hfiles_change
4286 findcom_change
4287 } else {
4288 if {$findpattern ne {}} {
4289 set findpattern {}
4290 findcom_change
4292 set highlight_files $findstring
4293 hfiles_change
4295 drawvisible
4297 # enable/disable findtype/findloc menus too
4300 proc find_change {name ix op} {
4301 global gdttype findstring highlight_files
4303 stopfinding
4304 if {$gdttype eq [mc "containing:"]} {
4305 findcom_change
4306 } else {
4307 if {$highlight_files ne $findstring} {
4308 set highlight_files $findstring
4309 hfiles_change
4312 drawvisible
4315 proc findcom_change args {
4316 global nhighlights boldnameids
4317 global findpattern findtype findstring gdttype
4319 stopfinding
4320 # delete previous highlights, if any
4321 foreach id $boldnameids {
4322 bolden_name $id mainfont
4324 set boldnameids {}
4325 catch {unset nhighlights}
4326 unbolden
4327 unmarkmatches
4328 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4329 set findpattern {}
4330 } elseif {$findtype eq [mc "Regexp"]} {
4331 set findpattern $findstring
4332 } else {
4333 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4334 $findstring]
4335 set findpattern "*$e*"
4339 proc makepatterns {l} {
4340 set ret {}
4341 foreach e $l {
4342 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4343 if {[string index $ee end] eq "/"} {
4344 lappend ret "$ee*"
4345 } else {
4346 lappend ret $ee
4347 lappend ret "$ee/*"
4350 return $ret
4353 proc do_file_hl {serial} {
4354 global highlight_files filehighlight highlight_paths gdttype fhl_list
4356 if {$gdttype eq [mc "touching paths:"]} {
4357 if {[catch {set paths [shellsplit $highlight_files]}]} return
4358 set highlight_paths [makepatterns $paths]
4359 highlight_filelist
4360 set gdtargs [concat -- $paths]
4361 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4362 set gdtargs [list "-S$highlight_files"]
4363 } else {
4364 # must be "containing:", i.e. we're searching commit info
4365 return
4367 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4368 set filehighlight [open $cmd r+]
4369 fconfigure $filehighlight -blocking 0
4370 filerun $filehighlight readfhighlight
4371 set fhl_list {}
4372 drawvisible
4373 flushhighlights
4376 proc flushhighlights {} {
4377 global filehighlight fhl_list
4379 if {[info exists filehighlight]} {
4380 lappend fhl_list {}
4381 puts $filehighlight ""
4382 flush $filehighlight
4386 proc askfilehighlight {row id} {
4387 global filehighlight fhighlights fhl_list
4389 lappend fhl_list $id
4390 set fhighlights($id) -1
4391 puts $filehighlight $id
4394 proc readfhighlight {} {
4395 global filehighlight fhighlights curview iddrawn
4396 global fhl_list find_dirn
4398 if {![info exists filehighlight]} {
4399 return 0
4401 set nr 0
4402 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4403 set line [string trim $line]
4404 set i [lsearch -exact $fhl_list $line]
4405 if {$i < 0} continue
4406 for {set j 0} {$j < $i} {incr j} {
4407 set id [lindex $fhl_list $j]
4408 set fhighlights($id) 0
4410 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4411 if {$line eq {}} continue
4412 if {![commitinview $line $curview]} continue
4413 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4414 bolden $line mainfontbold
4416 set fhighlights($line) 1
4418 if {[eof $filehighlight]} {
4419 # strange...
4420 puts "oops, git diff-tree died"
4421 catch {close $filehighlight}
4422 unset filehighlight
4423 return 0
4425 if {[info exists find_dirn]} {
4426 run findmore
4428 return 1
4431 proc doesmatch {f} {
4432 global findtype findpattern
4434 if {$findtype eq [mc "Regexp"]} {
4435 return [regexp $findpattern $f]
4436 } elseif {$findtype eq [mc "IgnCase"]} {
4437 return [string match -nocase $findpattern $f]
4438 } else {
4439 return [string match $findpattern $f]
4443 proc askfindhighlight {row id} {
4444 global nhighlights commitinfo iddrawn
4445 global findloc
4446 global markingmatches
4448 if {![info exists commitinfo($id)]} {
4449 getcommit $id
4451 set info $commitinfo($id)
4452 set isbold 0
4453 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4454 foreach f $info ty $fldtypes {
4455 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4456 [doesmatch $f]} {
4457 if {$ty eq [mc "Author"]} {
4458 set isbold 2
4459 break
4461 set isbold 1
4464 if {$isbold && [info exists iddrawn($id)]} {
4465 if {![ishighlighted $id]} {
4466 bolden $id mainfontbold
4467 if {$isbold > 1} {
4468 bolden_name $id mainfontbold
4471 if {$markingmatches} {
4472 markrowmatches $row $id
4475 set nhighlights($id) $isbold
4478 proc markrowmatches {row id} {
4479 global canv canv2 linehtag linentag commitinfo findloc
4481 set headline [lindex $commitinfo($id) 0]
4482 set author [lindex $commitinfo($id) 1]
4483 $canv delete match$row
4484 $canv2 delete match$row
4485 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4486 set m [findmatches $headline]
4487 if {$m ne {}} {
4488 markmatches $canv $row $headline $linehtag($id) $m \
4489 [$canv itemcget $linehtag($id) -font] $row
4492 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4493 set m [findmatches $author]
4494 if {$m ne {}} {
4495 markmatches $canv2 $row $author $linentag($id) $m \
4496 [$canv2 itemcget $linentag($id) -font] $row
4501 proc vrel_change {name ix op} {
4502 global highlight_related
4504 rhighlight_none
4505 if {$highlight_related ne [mc "None"]} {
4506 run drawvisible
4510 # prepare for testing whether commits are descendents or ancestors of a
4511 proc rhighlight_sel {a} {
4512 global descendent desc_todo ancestor anc_todo
4513 global highlight_related
4515 catch {unset descendent}
4516 set desc_todo [list $a]
4517 catch {unset ancestor}
4518 set anc_todo [list $a]
4519 if {$highlight_related ne [mc "None"]} {
4520 rhighlight_none
4521 run drawvisible
4525 proc rhighlight_none {} {
4526 global rhighlights
4528 catch {unset rhighlights}
4529 unbolden
4532 proc is_descendent {a} {
4533 global curview children descendent desc_todo
4535 set v $curview
4536 set la [rowofcommit $a]
4537 set todo $desc_todo
4538 set leftover {}
4539 set done 0
4540 for {set i 0} {$i < [llength $todo]} {incr i} {
4541 set do [lindex $todo $i]
4542 if {[rowofcommit $do] < $la} {
4543 lappend leftover $do
4544 continue
4546 foreach nk $children($v,$do) {
4547 if {![info exists descendent($nk)]} {
4548 set descendent($nk) 1
4549 lappend todo $nk
4550 if {$nk eq $a} {
4551 set done 1
4555 if {$done} {
4556 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4557 return
4560 set descendent($a) 0
4561 set desc_todo $leftover
4564 proc is_ancestor {a} {
4565 global curview parents ancestor anc_todo
4567 set v $curview
4568 set la [rowofcommit $a]
4569 set todo $anc_todo
4570 set leftover {}
4571 set done 0
4572 for {set i 0} {$i < [llength $todo]} {incr i} {
4573 set do [lindex $todo $i]
4574 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4575 lappend leftover $do
4576 continue
4578 foreach np $parents($v,$do) {
4579 if {![info exists ancestor($np)]} {
4580 set ancestor($np) 1
4581 lappend todo $np
4582 if {$np eq $a} {
4583 set done 1
4587 if {$done} {
4588 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4589 return
4592 set ancestor($a) 0
4593 set anc_todo $leftover
4596 proc askrelhighlight {row id} {
4597 global descendent highlight_related iddrawn rhighlights
4598 global selectedline ancestor
4600 if {$selectedline eq {}} return
4601 set isbold 0
4602 if {$highlight_related eq [mc "Descendant"] ||
4603 $highlight_related eq [mc "Not descendant"]} {
4604 if {![info exists descendent($id)]} {
4605 is_descendent $id
4607 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4608 set isbold 1
4610 } elseif {$highlight_related eq [mc "Ancestor"] ||
4611 $highlight_related eq [mc "Not ancestor"]} {
4612 if {![info exists ancestor($id)]} {
4613 is_ancestor $id
4615 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4616 set isbold 1
4619 if {[info exists iddrawn($id)]} {
4620 if {$isbold && ![ishighlighted $id]} {
4621 bolden $id mainfontbold
4624 set rhighlights($id) $isbold
4627 # Graph layout functions
4629 proc shortids {ids} {
4630 set res {}
4631 foreach id $ids {
4632 if {[llength $id] > 1} {
4633 lappend res [shortids $id]
4634 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4635 lappend res [string range $id 0 7]
4636 } else {
4637 lappend res $id
4640 return $res
4643 proc ntimes {n o} {
4644 set ret {}
4645 set o [list $o]
4646 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4647 if {($n & $mask) != 0} {
4648 set ret [concat $ret $o]
4650 set o [concat $o $o]
4652 return $ret
4655 proc ordertoken {id} {
4656 global ordertok curview varcid varcstart varctok curview parents children
4657 global nullid nullid2
4659 if {[info exists ordertok($id)]} {
4660 return $ordertok($id)
4662 set origid $id
4663 set todo {}
4664 while {1} {
4665 if {[info exists varcid($curview,$id)]} {
4666 set a $varcid($curview,$id)
4667 set p [lindex $varcstart($curview) $a]
4668 } else {
4669 set p [lindex $children($curview,$id) 0]
4671 if {[info exists ordertok($p)]} {
4672 set tok $ordertok($p)
4673 break
4675 set id [first_real_child $curview,$p]
4676 if {$id eq {}} {
4677 # it's a root
4678 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4679 break
4681 if {[llength $parents($curview,$id)] == 1} {
4682 lappend todo [list $p {}]
4683 } else {
4684 set j [lsearch -exact $parents($curview,$id) $p]
4685 if {$j < 0} {
4686 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4688 lappend todo [list $p [strrep $j]]
4691 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4692 set p [lindex $todo $i 0]
4693 append tok [lindex $todo $i 1]
4694 set ordertok($p) $tok
4696 set ordertok($origid) $tok
4697 return $tok
4700 # Work out where id should go in idlist so that order-token
4701 # values increase from left to right
4702 proc idcol {idlist id {i 0}} {
4703 set t [ordertoken $id]
4704 if {$i < 0} {
4705 set i 0
4707 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4708 if {$i > [llength $idlist]} {
4709 set i [llength $idlist]
4711 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4712 incr i
4713 } else {
4714 if {$t > [ordertoken [lindex $idlist $i]]} {
4715 while {[incr i] < [llength $idlist] &&
4716 $t >= [ordertoken [lindex $idlist $i]]} {}
4719 return $i
4722 proc initlayout {} {
4723 global rowidlist rowisopt rowfinal displayorder parentlist
4724 global numcommits canvxmax canv
4725 global nextcolor
4726 global colormap rowtextx
4728 set numcommits 0
4729 set displayorder {}
4730 set parentlist {}
4731 set nextcolor 0
4732 set rowidlist {}
4733 set rowisopt {}
4734 set rowfinal {}
4735 set canvxmax [$canv cget -width]
4736 catch {unset colormap}
4737 catch {unset rowtextx}
4738 setcanvscroll
4741 proc setcanvscroll {} {
4742 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4743 global lastscrollset lastscrollrows
4745 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4746 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4747 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4748 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4749 set lastscrollset [clock clicks -milliseconds]
4750 set lastscrollrows $numcommits
4753 proc visiblerows {} {
4754 global canv numcommits linespc
4756 set ymax [lindex [$canv cget -scrollregion] 3]
4757 if {$ymax eq {} || $ymax == 0} return
4758 set f [$canv yview]
4759 set y0 [expr {int([lindex $f 0] * $ymax)}]
4760 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4761 if {$r0 < 0} {
4762 set r0 0
4764 set y1 [expr {int([lindex $f 1] * $ymax)}]
4765 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4766 if {$r1 >= $numcommits} {
4767 set r1 [expr {$numcommits - 1}]
4769 return [list $r0 $r1]
4772 proc layoutmore {} {
4773 global commitidx viewcomplete curview
4774 global numcommits pending_select curview
4775 global lastscrollset lastscrollrows
4777 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4778 [clock clicks -milliseconds] - $lastscrollset > 500} {
4779 setcanvscroll
4781 if {[info exists pending_select] &&
4782 [commitinview $pending_select $curview]} {
4783 update
4784 selectline [rowofcommit $pending_select] 1
4786 drawvisible
4789 # With path limiting, we mightn't get the actual HEAD commit,
4790 # so ask git rev-list what is the first ancestor of HEAD that
4791 # touches a file in the path limit.
4792 proc get_viewmainhead {view} {
4793 global viewmainheadid vfilelimit viewinstances mainheadid
4795 catch {
4796 set rfd [open [concat | git rev-list -1 $mainheadid \
4797 -- $vfilelimit($view)] r]
4798 set j [reg_instance $rfd]
4799 lappend viewinstances($view) $j
4800 fconfigure $rfd -blocking 0
4801 filerun $rfd [list getviewhead $rfd $j $view]
4802 set viewmainheadid($curview) {}
4806 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4807 proc getviewhead {fd inst view} {
4808 global viewmainheadid commfd curview viewinstances showlocalchanges
4810 set id {}
4811 if {[gets $fd line] < 0} {
4812 if {![eof $fd]} {
4813 return 1
4815 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4816 set id $line
4818 set viewmainheadid($view) $id
4819 close $fd
4820 unset commfd($inst)
4821 set i [lsearch -exact $viewinstances($view) $inst]
4822 if {$i >= 0} {
4823 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4825 if {$showlocalchanges && $id ne {} && $view == $curview} {
4826 doshowlocalchanges
4828 return 0
4831 proc doshowlocalchanges {} {
4832 global curview viewmainheadid
4834 if {$viewmainheadid($curview) eq {}} return
4835 if {[commitinview $viewmainheadid($curview) $curview]} {
4836 dodiffindex
4837 } else {
4838 interestedin $viewmainheadid($curview) dodiffindex
4842 proc dohidelocalchanges {} {
4843 global nullid nullid2 lserial curview
4845 if {[commitinview $nullid $curview]} {
4846 removefakerow $nullid
4848 if {[commitinview $nullid2 $curview]} {
4849 removefakerow $nullid2
4851 incr lserial
4854 # spawn off a process to do git diff-index --cached HEAD
4855 proc dodiffindex {} {
4856 global lserial showlocalchanges vfilelimit curview
4857 global isworktree
4859 if {!$showlocalchanges || !$isworktree} return
4860 incr lserial
4861 set cmd "|git diff-index --cached HEAD"
4862 if {$vfilelimit($curview) ne {}} {
4863 set cmd [concat $cmd -- $vfilelimit($curview)]
4865 set fd [open $cmd r]
4866 fconfigure $fd -blocking 0
4867 set i [reg_instance $fd]
4868 filerun $fd [list readdiffindex $fd $lserial $i]
4871 proc readdiffindex {fd serial inst} {
4872 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4873 global vfilelimit
4875 set isdiff 1
4876 if {[gets $fd line] < 0} {
4877 if {![eof $fd]} {
4878 return 1
4880 set isdiff 0
4882 # we only need to see one line and we don't really care what it says...
4883 stop_instance $inst
4885 if {$serial != $lserial} {
4886 return 0
4889 # now see if there are any local changes not checked in to the index
4890 set cmd "|git diff-files"
4891 if {$vfilelimit($curview) ne {}} {
4892 set cmd [concat $cmd -- $vfilelimit($curview)]
4894 set fd [open $cmd r]
4895 fconfigure $fd -blocking 0
4896 set i [reg_instance $fd]
4897 filerun $fd [list readdifffiles $fd $serial $i]
4899 if {$isdiff && ![commitinview $nullid2 $curview]} {
4900 # add the line for the changes in the index to the graph
4901 set hl [mc "Local changes checked in to index but not committed"]
4902 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4903 set commitdata($nullid2) "\n $hl\n"
4904 if {[commitinview $nullid $curview]} {
4905 removefakerow $nullid
4907 insertfakerow $nullid2 $viewmainheadid($curview)
4908 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4909 if {[commitinview $nullid $curview]} {
4910 removefakerow $nullid
4912 removefakerow $nullid2
4914 return 0
4917 proc readdifffiles {fd serial inst} {
4918 global viewmainheadid nullid nullid2 curview
4919 global commitinfo commitdata lserial
4921 set isdiff 1
4922 if {[gets $fd line] < 0} {
4923 if {![eof $fd]} {
4924 return 1
4926 set isdiff 0
4928 # we only need to see one line and we don't really care what it says...
4929 stop_instance $inst
4931 if {$serial != $lserial} {
4932 return 0
4935 if {$isdiff && ![commitinview $nullid $curview]} {
4936 # add the line for the local diff to the graph
4937 set hl [mc "Local uncommitted changes, not checked in to index"]
4938 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4939 set commitdata($nullid) "\n $hl\n"
4940 if {[commitinview $nullid2 $curview]} {
4941 set p $nullid2
4942 } else {
4943 set p $viewmainheadid($curview)
4945 insertfakerow $nullid $p
4946 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4947 removefakerow $nullid
4949 return 0
4952 proc nextuse {id row} {
4953 global curview children
4955 if {[info exists children($curview,$id)]} {
4956 foreach kid $children($curview,$id) {
4957 if {![commitinview $kid $curview]} {
4958 return -1
4960 if {[rowofcommit $kid] > $row} {
4961 return [rowofcommit $kid]
4965 if {[commitinview $id $curview]} {
4966 return [rowofcommit $id]
4968 return -1
4971 proc prevuse {id row} {
4972 global curview children
4974 set ret -1
4975 if {[info exists children($curview,$id)]} {
4976 foreach kid $children($curview,$id) {
4977 if {![commitinview $kid $curview]} break
4978 if {[rowofcommit $kid] < $row} {
4979 set ret [rowofcommit $kid]
4983 return $ret
4986 proc make_idlist {row} {
4987 global displayorder parentlist uparrowlen downarrowlen mingaplen
4988 global commitidx curview children
4990 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4991 if {$r < 0} {
4992 set r 0
4994 set ra [expr {$row - $downarrowlen}]
4995 if {$ra < 0} {
4996 set ra 0
4998 set rb [expr {$row + $uparrowlen}]
4999 if {$rb > $commitidx($curview)} {
5000 set rb $commitidx($curview)
5002 make_disporder $r [expr {$rb + 1}]
5003 set ids {}
5004 for {} {$r < $ra} {incr r} {
5005 set nextid [lindex $displayorder [expr {$r + 1}]]
5006 foreach p [lindex $parentlist $r] {
5007 if {$p eq $nextid} continue
5008 set rn [nextuse $p $r]
5009 if {$rn >= $row &&
5010 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5011 lappend ids [list [ordertoken $p] $p]
5015 for {} {$r < $row} {incr r} {
5016 set nextid [lindex $displayorder [expr {$r + 1}]]
5017 foreach p [lindex $parentlist $r] {
5018 if {$p eq $nextid} continue
5019 set rn [nextuse $p $r]
5020 if {$rn < 0 || $rn >= $row} {
5021 lappend ids [list [ordertoken $p] $p]
5025 set id [lindex $displayorder $row]
5026 lappend ids [list [ordertoken $id] $id]
5027 while {$r < $rb} {
5028 foreach p [lindex $parentlist $r] {
5029 set firstkid [lindex $children($curview,$p) 0]
5030 if {[rowofcommit $firstkid] < $row} {
5031 lappend ids [list [ordertoken $p] $p]
5034 incr r
5035 set id [lindex $displayorder $r]
5036 if {$id ne {}} {
5037 set firstkid [lindex $children($curview,$id) 0]
5038 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5039 lappend ids [list [ordertoken $id] $id]
5043 set idlist {}
5044 foreach idx [lsort -unique $ids] {
5045 lappend idlist [lindex $idx 1]
5047 return $idlist
5050 proc rowsequal {a b} {
5051 while {[set i [lsearch -exact $a {}]] >= 0} {
5052 set a [lreplace $a $i $i]
5054 while {[set i [lsearch -exact $b {}]] >= 0} {
5055 set b [lreplace $b $i $i]
5057 return [expr {$a eq $b}]
5060 proc makeupline {id row rend col} {
5061 global rowidlist uparrowlen downarrowlen mingaplen
5063 for {set r $rend} {1} {set r $rstart} {
5064 set rstart [prevuse $id $r]
5065 if {$rstart < 0} return
5066 if {$rstart < $row} break
5068 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5069 set rstart [expr {$rend - $uparrowlen - 1}]
5071 for {set r $rstart} {[incr r] <= $row} {} {
5072 set idlist [lindex $rowidlist $r]
5073 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5074 set col [idcol $idlist $id $col]
5075 lset rowidlist $r [linsert $idlist $col $id]
5076 changedrow $r
5081 proc layoutrows {row endrow} {
5082 global rowidlist rowisopt rowfinal displayorder
5083 global uparrowlen downarrowlen maxwidth mingaplen
5084 global children parentlist
5085 global commitidx viewcomplete curview
5087 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5088 set idlist {}
5089 if {$row > 0} {
5090 set rm1 [expr {$row - 1}]
5091 foreach id [lindex $rowidlist $rm1] {
5092 if {$id ne {}} {
5093 lappend idlist $id
5096 set final [lindex $rowfinal $rm1]
5098 for {} {$row < $endrow} {incr row} {
5099 set rm1 [expr {$row - 1}]
5100 if {$rm1 < 0 || $idlist eq {}} {
5101 set idlist [make_idlist $row]
5102 set final 1
5103 } else {
5104 set id [lindex $displayorder $rm1]
5105 set col [lsearch -exact $idlist $id]
5106 set idlist [lreplace $idlist $col $col]
5107 foreach p [lindex $parentlist $rm1] {
5108 if {[lsearch -exact $idlist $p] < 0} {
5109 set col [idcol $idlist $p $col]
5110 set idlist [linsert $idlist $col $p]
5111 # if not the first child, we have to insert a line going up
5112 if {$id ne [lindex $children($curview,$p) 0]} {
5113 makeupline $p $rm1 $row $col
5117 set id [lindex $displayorder $row]
5118 if {$row > $downarrowlen} {
5119 set termrow [expr {$row - $downarrowlen - 1}]
5120 foreach p [lindex $parentlist $termrow] {
5121 set i [lsearch -exact $idlist $p]
5122 if {$i < 0} continue
5123 set nr [nextuse $p $termrow]
5124 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5125 set idlist [lreplace $idlist $i $i]
5129 set col [lsearch -exact $idlist $id]
5130 if {$col < 0} {
5131 set col [idcol $idlist $id]
5132 set idlist [linsert $idlist $col $id]
5133 if {$children($curview,$id) ne {}} {
5134 makeupline $id $rm1 $row $col
5137 set r [expr {$row + $uparrowlen - 1}]
5138 if {$r < $commitidx($curview)} {
5139 set x $col
5140 foreach p [lindex $parentlist $r] {
5141 if {[lsearch -exact $idlist $p] >= 0} continue
5142 set fk [lindex $children($curview,$p) 0]
5143 if {[rowofcommit $fk] < $row} {
5144 set x [idcol $idlist $p $x]
5145 set idlist [linsert $idlist $x $p]
5148 if {[incr r] < $commitidx($curview)} {
5149 set p [lindex $displayorder $r]
5150 if {[lsearch -exact $idlist $p] < 0} {
5151 set fk [lindex $children($curview,$p) 0]
5152 if {$fk ne {} && [rowofcommit $fk] < $row} {
5153 set x [idcol $idlist $p $x]
5154 set idlist [linsert $idlist $x $p]
5160 if {$final && !$viewcomplete($curview) &&
5161 $row + $uparrowlen + $mingaplen + $downarrowlen
5162 >= $commitidx($curview)} {
5163 set final 0
5165 set l [llength $rowidlist]
5166 if {$row == $l} {
5167 lappend rowidlist $idlist
5168 lappend rowisopt 0
5169 lappend rowfinal $final
5170 } elseif {$row < $l} {
5171 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5172 lset rowidlist $row $idlist
5173 changedrow $row
5175 lset rowfinal $row $final
5176 } else {
5177 set pad [ntimes [expr {$row - $l}] {}]
5178 set rowidlist [concat $rowidlist $pad]
5179 lappend rowidlist $idlist
5180 set rowfinal [concat $rowfinal $pad]
5181 lappend rowfinal $final
5182 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5185 return $row
5188 proc changedrow {row} {
5189 global displayorder iddrawn rowisopt need_redisplay
5191 set l [llength $rowisopt]
5192 if {$row < $l} {
5193 lset rowisopt $row 0
5194 if {$row + 1 < $l} {
5195 lset rowisopt [expr {$row + 1}] 0
5196 if {$row + 2 < $l} {
5197 lset rowisopt [expr {$row + 2}] 0
5201 set id [lindex $displayorder $row]
5202 if {[info exists iddrawn($id)]} {
5203 set need_redisplay 1
5207 proc insert_pad {row col npad} {
5208 global rowidlist
5210 set pad [ntimes $npad {}]
5211 set idlist [lindex $rowidlist $row]
5212 set bef [lrange $idlist 0 [expr {$col - 1}]]
5213 set aft [lrange $idlist $col end]
5214 set i [lsearch -exact $aft {}]
5215 if {$i > 0} {
5216 set aft [lreplace $aft $i $i]
5218 lset rowidlist $row [concat $bef $pad $aft]
5219 changedrow $row
5222 proc optimize_rows {row col endrow} {
5223 global rowidlist rowisopt displayorder curview children
5225 if {$row < 1} {
5226 set row 1
5228 for {} {$row < $endrow} {incr row; set col 0} {
5229 if {[lindex $rowisopt $row]} continue
5230 set haspad 0
5231 set y0 [expr {$row - 1}]
5232 set ym [expr {$row - 2}]
5233 set idlist [lindex $rowidlist $row]
5234 set previdlist [lindex $rowidlist $y0]
5235 if {$idlist eq {} || $previdlist eq {}} continue
5236 if {$ym >= 0} {
5237 set pprevidlist [lindex $rowidlist $ym]
5238 if {$pprevidlist eq {}} continue
5239 } else {
5240 set pprevidlist {}
5242 set x0 -1
5243 set xm -1
5244 for {} {$col < [llength $idlist]} {incr col} {
5245 set id [lindex $idlist $col]
5246 if {[lindex $previdlist $col] eq $id} continue
5247 if {$id eq {}} {
5248 set haspad 1
5249 continue
5251 set x0 [lsearch -exact $previdlist $id]
5252 if {$x0 < 0} continue
5253 set z [expr {$x0 - $col}]
5254 set isarrow 0
5255 set z0 {}
5256 if {$ym >= 0} {
5257 set xm [lsearch -exact $pprevidlist $id]
5258 if {$xm >= 0} {
5259 set z0 [expr {$xm - $x0}]
5262 if {$z0 eq {}} {
5263 # if row y0 is the first child of $id then it's not an arrow
5264 if {[lindex $children($curview,$id) 0] ne
5265 [lindex $displayorder $y0]} {
5266 set isarrow 1
5269 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5270 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5271 set isarrow 1
5273 # Looking at lines from this row to the previous row,
5274 # make them go straight up if they end in an arrow on
5275 # the previous row; otherwise make them go straight up
5276 # or at 45 degrees.
5277 if {$z < -1 || ($z < 0 && $isarrow)} {
5278 # Line currently goes left too much;
5279 # insert pads in the previous row, then optimize it
5280 set npad [expr {-1 - $z + $isarrow}]
5281 insert_pad $y0 $x0 $npad
5282 if {$y0 > 0} {
5283 optimize_rows $y0 $x0 $row
5285 set previdlist [lindex $rowidlist $y0]
5286 set x0 [lsearch -exact $previdlist $id]
5287 set z [expr {$x0 - $col}]
5288 if {$z0 ne {}} {
5289 set pprevidlist [lindex $rowidlist $ym]
5290 set xm [lsearch -exact $pprevidlist $id]
5291 set z0 [expr {$xm - $x0}]
5293 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5294 # Line currently goes right too much;
5295 # insert pads in this line
5296 set npad [expr {$z - 1 + $isarrow}]
5297 insert_pad $row $col $npad
5298 set idlist [lindex $rowidlist $row]
5299 incr col $npad
5300 set z [expr {$x0 - $col}]
5301 set haspad 1
5303 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5304 # this line links to its first child on row $row-2
5305 set id [lindex $displayorder $ym]
5306 set xc [lsearch -exact $pprevidlist $id]
5307 if {$xc >= 0} {
5308 set z0 [expr {$xc - $x0}]
5311 # avoid lines jigging left then immediately right
5312 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5313 insert_pad $y0 $x0 1
5314 incr x0
5315 optimize_rows $y0 $x0 $row
5316 set previdlist [lindex $rowidlist $y0]
5319 if {!$haspad} {
5320 # Find the first column that doesn't have a line going right
5321 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5322 set id [lindex $idlist $col]
5323 if {$id eq {}} break
5324 set x0 [lsearch -exact $previdlist $id]
5325 if {$x0 < 0} {
5326 # check if this is the link to the first child
5327 set kid [lindex $displayorder $y0]
5328 if {[lindex $children($curview,$id) 0] eq $kid} {
5329 # it is, work out offset to child
5330 set x0 [lsearch -exact $previdlist $kid]
5333 if {$x0 <= $col} break
5335 # Insert a pad at that column as long as it has a line and
5336 # isn't the last column
5337 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5338 set idlist [linsert $idlist $col {}]
5339 lset rowidlist $row $idlist
5340 changedrow $row
5346 proc xc {row col} {
5347 global canvx0 linespc
5348 return [expr {$canvx0 + $col * $linespc}]
5351 proc yc {row} {
5352 global canvy0 linespc
5353 return [expr {$canvy0 + $row * $linespc}]
5356 proc linewidth {id} {
5357 global thickerline lthickness
5359 set wid $lthickness
5360 if {[info exists thickerline] && $id eq $thickerline} {
5361 set wid [expr {2 * $lthickness}]
5363 return $wid
5366 proc rowranges {id} {
5367 global curview children uparrowlen downarrowlen
5368 global rowidlist
5370 set kids $children($curview,$id)
5371 if {$kids eq {}} {
5372 return {}
5374 set ret {}
5375 lappend kids $id
5376 foreach child $kids {
5377 if {![commitinview $child $curview]} break
5378 set row [rowofcommit $child]
5379 if {![info exists prev]} {
5380 lappend ret [expr {$row + 1}]
5381 } else {
5382 if {$row <= $prevrow} {
5383 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5385 # see if the line extends the whole way from prevrow to row
5386 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5387 [lsearch -exact [lindex $rowidlist \
5388 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5389 # it doesn't, see where it ends
5390 set r [expr {$prevrow + $downarrowlen}]
5391 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5392 while {[incr r -1] > $prevrow &&
5393 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5394 } else {
5395 while {[incr r] <= $row &&
5396 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5397 incr r -1
5399 lappend ret $r
5400 # see where it starts up again
5401 set r [expr {$row - $uparrowlen}]
5402 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5403 while {[incr r] < $row &&
5404 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5405 } else {
5406 while {[incr r -1] >= $prevrow &&
5407 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5408 incr r
5410 lappend ret $r
5413 if {$child eq $id} {
5414 lappend ret $row
5416 set prev $child
5417 set prevrow $row
5419 return $ret
5422 proc drawlineseg {id row endrow arrowlow} {
5423 global rowidlist displayorder iddrawn linesegs
5424 global canv colormap linespc curview maxlinelen parentlist
5426 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5427 set le [expr {$row + 1}]
5428 set arrowhigh 1
5429 while {1} {
5430 set c [lsearch -exact [lindex $rowidlist $le] $id]
5431 if {$c < 0} {
5432 incr le -1
5433 break
5435 lappend cols $c
5436 set x [lindex $displayorder $le]
5437 if {$x eq $id} {
5438 set arrowhigh 0
5439 break
5441 if {[info exists iddrawn($x)] || $le == $endrow} {
5442 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5443 if {$c >= 0} {
5444 lappend cols $c
5445 set arrowhigh 0
5447 break
5449 incr le
5451 if {$le <= $row} {
5452 return $row
5455 set lines {}
5456 set i 0
5457 set joinhigh 0
5458 if {[info exists linesegs($id)]} {
5459 set lines $linesegs($id)
5460 foreach li $lines {
5461 set r0 [lindex $li 0]
5462 if {$r0 > $row} {
5463 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5464 set joinhigh 1
5466 break
5468 incr i
5471 set joinlow 0
5472 if {$i > 0} {
5473 set li [lindex $lines [expr {$i-1}]]
5474 set r1 [lindex $li 1]
5475 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5476 set joinlow 1
5480 set x [lindex $cols [expr {$le - $row}]]
5481 set xp [lindex $cols [expr {$le - 1 - $row}]]
5482 set dir [expr {$xp - $x}]
5483 if {$joinhigh} {
5484 set ith [lindex $lines $i 2]
5485 set coords [$canv coords $ith]
5486 set ah [$canv itemcget $ith -arrow]
5487 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5488 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5489 if {$x2 ne {} && $x - $x2 == $dir} {
5490 set coords [lrange $coords 0 end-2]
5492 } else {
5493 set coords [list [xc $le $x] [yc $le]]
5495 if {$joinlow} {
5496 set itl [lindex $lines [expr {$i-1}] 2]
5497 set al [$canv itemcget $itl -arrow]
5498 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5499 } elseif {$arrowlow} {
5500 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5501 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5502 set arrowlow 0
5505 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5506 for {set y $le} {[incr y -1] > $row} {} {
5507 set x $xp
5508 set xp [lindex $cols [expr {$y - 1 - $row}]]
5509 set ndir [expr {$xp - $x}]
5510 if {$dir != $ndir || $xp < 0} {
5511 lappend coords [xc $y $x] [yc $y]
5513 set dir $ndir
5515 if {!$joinlow} {
5516 if {$xp < 0} {
5517 # join parent line to first child
5518 set ch [lindex $displayorder $row]
5519 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5520 if {$xc < 0} {
5521 puts "oops: drawlineseg: child $ch not on row $row"
5522 } elseif {$xc != $x} {
5523 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5524 set d [expr {int(0.5 * $linespc)}]
5525 set x1 [xc $row $x]
5526 if {$xc < $x} {
5527 set x2 [expr {$x1 - $d}]
5528 } else {
5529 set x2 [expr {$x1 + $d}]
5531 set y2 [yc $row]
5532 set y1 [expr {$y2 + $d}]
5533 lappend coords $x1 $y1 $x2 $y2
5534 } elseif {$xc < $x - 1} {
5535 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5536 } elseif {$xc > $x + 1} {
5537 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5539 set x $xc
5541 lappend coords [xc $row $x] [yc $row]
5542 } else {
5543 set xn [xc $row $xp]
5544 set yn [yc $row]
5545 lappend coords $xn $yn
5547 if {!$joinhigh} {
5548 assigncolor $id
5549 set t [$canv create line $coords -width [linewidth $id] \
5550 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5551 $canv lower $t
5552 bindline $t $id
5553 set lines [linsert $lines $i [list $row $le $t]]
5554 } else {
5555 $canv coords $ith $coords
5556 if {$arrow ne $ah} {
5557 $canv itemconf $ith -arrow $arrow
5559 lset lines $i 0 $row
5561 } else {
5562 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5563 set ndir [expr {$xo - $xp}]
5564 set clow [$canv coords $itl]
5565 if {$dir == $ndir} {
5566 set clow [lrange $clow 2 end]
5568 set coords [concat $coords $clow]
5569 if {!$joinhigh} {
5570 lset lines [expr {$i-1}] 1 $le
5571 } else {
5572 # coalesce two pieces
5573 $canv delete $ith
5574 set b [lindex $lines [expr {$i-1}] 0]
5575 set e [lindex $lines $i 1]
5576 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5578 $canv coords $itl $coords
5579 if {$arrow ne $al} {
5580 $canv itemconf $itl -arrow $arrow
5584 set linesegs($id) $lines
5585 return $le
5588 proc drawparentlinks {id row} {
5589 global rowidlist canv colormap curview parentlist
5590 global idpos linespc
5592 set rowids [lindex $rowidlist $row]
5593 set col [lsearch -exact $rowids $id]
5594 if {$col < 0} return
5595 set olds [lindex $parentlist $row]
5596 set row2 [expr {$row + 1}]
5597 set x [xc $row $col]
5598 set y [yc $row]
5599 set y2 [yc $row2]
5600 set d [expr {int(0.5 * $linespc)}]
5601 set ymid [expr {$y + $d}]
5602 set ids [lindex $rowidlist $row2]
5603 # rmx = right-most X coord used
5604 set rmx 0
5605 foreach p $olds {
5606 set i [lsearch -exact $ids $p]
5607 if {$i < 0} {
5608 puts "oops, parent $p of $id not in list"
5609 continue
5611 set x2 [xc $row2 $i]
5612 if {$x2 > $rmx} {
5613 set rmx $x2
5615 set j [lsearch -exact $rowids $p]
5616 if {$j < 0} {
5617 # drawlineseg will do this one for us
5618 continue
5620 assigncolor $p
5621 # should handle duplicated parents here...
5622 set coords [list $x $y]
5623 if {$i != $col} {
5624 # if attaching to a vertical segment, draw a smaller
5625 # slant for visual distinctness
5626 if {$i == $j} {
5627 if {$i < $col} {
5628 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5629 } else {
5630 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5632 } elseif {$i < $col && $i < $j} {
5633 # segment slants towards us already
5634 lappend coords [xc $row $j] $y
5635 } else {
5636 if {$i < $col - 1} {
5637 lappend coords [expr {$x2 + $linespc}] $y
5638 } elseif {$i > $col + 1} {
5639 lappend coords [expr {$x2 - $linespc}] $y
5641 lappend coords $x2 $y2
5643 } else {
5644 lappend coords $x2 $y2
5646 set t [$canv create line $coords -width [linewidth $p] \
5647 -fill $colormap($p) -tags lines.$p]
5648 $canv lower $t
5649 bindline $t $p
5651 if {$rmx > [lindex $idpos($id) 1]} {
5652 lset idpos($id) 1 $rmx
5653 redrawtags $id
5657 proc drawlines {id} {
5658 global canv
5660 $canv itemconf lines.$id -width [linewidth $id]
5663 proc drawcmittext {id row col} {
5664 global linespc canv canv2 canv3 fgcolor curview
5665 global cmitlisted commitinfo rowidlist parentlist
5666 global rowtextx idpos idtags idheads idotherrefs
5667 global linehtag linentag linedtag selectedline
5668 global canvxmax boldids boldnameids fgcolor markedid
5669 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5671 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5672 set listed $cmitlisted($curview,$id)
5673 if {$id eq $nullid} {
5674 set ofill red
5675 } elseif {$id eq $nullid2} {
5676 set ofill green
5677 } elseif {$id eq $mainheadid} {
5678 set ofill yellow
5679 } else {
5680 set ofill [lindex $circlecolors $listed]
5682 set x [xc $row $col]
5683 set y [yc $row]
5684 set orad [expr {$linespc / 3}]
5685 if {$listed <= 2} {
5686 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5687 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5688 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5689 } elseif {$listed == 3} {
5690 # triangle pointing left for left-side commits
5691 set t [$canv create polygon \
5692 [expr {$x - $orad}] $y \
5693 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5694 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5695 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5696 } else {
5697 # triangle pointing right for right-side commits
5698 set t [$canv create polygon \
5699 [expr {$x + $orad - 1}] $y \
5700 [expr {$x - $orad}] [expr {$y - $orad}] \
5701 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5702 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5704 set circleitem($row) $t
5705 $canv raise $t
5706 $canv bind $t <1> {selcanvline {} %x %y}
5707 set rmx [llength [lindex $rowidlist $row]]
5708 set olds [lindex $parentlist $row]
5709 if {$olds ne {}} {
5710 set nextids [lindex $rowidlist [expr {$row + 1}]]
5711 foreach p $olds {
5712 set i [lsearch -exact $nextids $p]
5713 if {$i > $rmx} {
5714 set rmx $i
5718 set xt [xc $row $rmx]
5719 set rowtextx($row) $xt
5720 set idpos($id) [list $x $xt $y]
5721 if {[info exists idtags($id)] || [info exists idheads($id)]
5722 || [info exists idotherrefs($id)]} {
5723 set xt [drawtags $id $x $xt $y]
5725 set headline [lindex $commitinfo($id) 0]
5726 set name [lindex $commitinfo($id) 1]
5727 set date [lindex $commitinfo($id) 2]
5728 set date [formatdate $date]
5729 set font mainfont
5730 set nfont mainfont
5731 set isbold [ishighlighted $id]
5732 if {$isbold > 0} {
5733 lappend boldids $id
5734 set font mainfontbold
5735 if {$isbold > 1} {
5736 lappend boldnameids $id
5737 set nfont mainfontbold
5740 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5741 -text $headline -font $font -tags text]
5742 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5743 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5744 -text $name -font $nfont -tags text]
5745 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5746 -text $date -font mainfont -tags text]
5747 if {$selectedline == $row} {
5748 make_secsel $id
5750 if {[info exists markedid] && $markedid eq $id} {
5751 make_idmark $id
5753 set xr [expr {$xt + [font measure $font $headline]}]
5754 if {$xr > $canvxmax} {
5755 set canvxmax $xr
5756 setcanvscroll
5760 proc drawcmitrow {row} {
5761 global displayorder rowidlist nrows_drawn
5762 global iddrawn markingmatches
5763 global commitinfo numcommits
5764 global filehighlight fhighlights findpattern nhighlights
5765 global hlview vhighlights
5766 global highlight_related rhighlights
5768 if {$row >= $numcommits} return
5770 set id [lindex $displayorder $row]
5771 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5772 askvhighlight $row $id
5774 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5775 askfilehighlight $row $id
5777 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5778 askfindhighlight $row $id
5780 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5781 askrelhighlight $row $id
5783 if {![info exists iddrawn($id)]} {
5784 set col [lsearch -exact [lindex $rowidlist $row] $id]
5785 if {$col < 0} {
5786 puts "oops, row $row id $id not in list"
5787 return
5789 if {![info exists commitinfo($id)]} {
5790 getcommit $id
5792 assigncolor $id
5793 drawcmittext $id $row $col
5794 set iddrawn($id) 1
5795 incr nrows_drawn
5797 if {$markingmatches} {
5798 markrowmatches $row $id
5802 proc drawcommits {row {endrow {}}} {
5803 global numcommits iddrawn displayorder curview need_redisplay
5804 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5806 if {$row < 0} {
5807 set row 0
5809 if {$endrow eq {}} {
5810 set endrow $row
5812 if {$endrow >= $numcommits} {
5813 set endrow [expr {$numcommits - 1}]
5816 set rl1 [expr {$row - $downarrowlen - 3}]
5817 if {$rl1 < 0} {
5818 set rl1 0
5820 set ro1 [expr {$row - 3}]
5821 if {$ro1 < 0} {
5822 set ro1 0
5824 set r2 [expr {$endrow + $uparrowlen + 3}]
5825 if {$r2 > $numcommits} {
5826 set r2 $numcommits
5828 for {set r $rl1} {$r < $r2} {incr r} {
5829 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5830 if {$rl1 < $r} {
5831 layoutrows $rl1 $r
5833 set rl1 [expr {$r + 1}]
5836 if {$rl1 < $r} {
5837 layoutrows $rl1 $r
5839 optimize_rows $ro1 0 $r2
5840 if {$need_redisplay || $nrows_drawn > 2000} {
5841 clear_display
5844 # make the lines join to already-drawn rows either side
5845 set r [expr {$row - 1}]
5846 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5847 set r $row
5849 set er [expr {$endrow + 1}]
5850 if {$er >= $numcommits ||
5851 ![info exists iddrawn([lindex $displayorder $er])]} {
5852 set er $endrow
5854 for {} {$r <= $er} {incr r} {
5855 set id [lindex $displayorder $r]
5856 set wasdrawn [info exists iddrawn($id)]
5857 drawcmitrow $r
5858 if {$r == $er} break
5859 set nextid [lindex $displayorder [expr {$r + 1}]]
5860 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5861 drawparentlinks $id $r
5863 set rowids [lindex $rowidlist $r]
5864 foreach lid $rowids {
5865 if {$lid eq {}} continue
5866 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5867 if {$lid eq $id} {
5868 # see if this is the first child of any of its parents
5869 foreach p [lindex $parentlist $r] {
5870 if {[lsearch -exact $rowids $p] < 0} {
5871 # make this line extend up to the child
5872 set lineend($p) [drawlineseg $p $r $er 0]
5875 } else {
5876 set lineend($lid) [drawlineseg $lid $r $er 1]
5882 proc undolayout {row} {
5883 global uparrowlen mingaplen downarrowlen
5884 global rowidlist rowisopt rowfinal need_redisplay
5886 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5887 if {$r < 0} {
5888 set r 0
5890 if {[llength $rowidlist] > $r} {
5891 incr r -1
5892 set rowidlist [lrange $rowidlist 0 $r]
5893 set rowfinal [lrange $rowfinal 0 $r]
5894 set rowisopt [lrange $rowisopt 0 $r]
5895 set need_redisplay 1
5896 run drawvisible
5900 proc drawvisible {} {
5901 global canv linespc curview vrowmod selectedline targetrow targetid
5902 global need_redisplay cscroll numcommits
5904 set fs [$canv yview]
5905 set ymax [lindex [$canv cget -scrollregion] 3]
5906 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5907 set f0 [lindex $fs 0]
5908 set f1 [lindex $fs 1]
5909 set y0 [expr {int($f0 * $ymax)}]
5910 set y1 [expr {int($f1 * $ymax)}]
5912 if {[info exists targetid]} {
5913 if {[commitinview $targetid $curview]} {
5914 set r [rowofcommit $targetid]
5915 if {$r != $targetrow} {
5916 # Fix up the scrollregion and change the scrolling position
5917 # now that our target row has moved.
5918 set diff [expr {($r - $targetrow) * $linespc}]
5919 set targetrow $r
5920 setcanvscroll
5921 set ymax [lindex [$canv cget -scrollregion] 3]
5922 incr y0 $diff
5923 incr y1 $diff
5924 set f0 [expr {$y0 / $ymax}]
5925 set f1 [expr {$y1 / $ymax}]
5926 allcanvs yview moveto $f0
5927 $cscroll set $f0 $f1
5928 set need_redisplay 1
5930 } else {
5931 unset targetid
5935 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5936 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5937 if {$endrow >= $vrowmod($curview)} {
5938 update_arcrows $curview
5940 if {$selectedline ne {} &&
5941 $row <= $selectedline && $selectedline <= $endrow} {
5942 set targetrow $selectedline
5943 } elseif {[info exists targetid]} {
5944 set targetrow [expr {int(($row + $endrow) / 2)}]
5946 if {[info exists targetrow]} {
5947 if {$targetrow >= $numcommits} {
5948 set targetrow [expr {$numcommits - 1}]
5950 set targetid [commitonrow $targetrow]
5952 drawcommits $row $endrow
5955 proc clear_display {} {
5956 global iddrawn linesegs need_redisplay nrows_drawn
5957 global vhighlights fhighlights nhighlights rhighlights
5958 global linehtag linentag linedtag boldids boldnameids
5960 allcanvs delete all
5961 catch {unset iddrawn}
5962 catch {unset linesegs}
5963 catch {unset linehtag}
5964 catch {unset linentag}
5965 catch {unset linedtag}
5966 set boldids {}
5967 set boldnameids {}
5968 catch {unset vhighlights}
5969 catch {unset fhighlights}
5970 catch {unset nhighlights}
5971 catch {unset rhighlights}
5972 set need_redisplay 0
5973 set nrows_drawn 0
5976 proc findcrossings {id} {
5977 global rowidlist parentlist numcommits displayorder
5979 set cross {}
5980 set ccross {}
5981 foreach {s e} [rowranges $id] {
5982 if {$e >= $numcommits} {
5983 set e [expr {$numcommits - 1}]
5985 if {$e <= $s} continue
5986 for {set row $e} {[incr row -1] >= $s} {} {
5987 set x [lsearch -exact [lindex $rowidlist $row] $id]
5988 if {$x < 0} break
5989 set olds [lindex $parentlist $row]
5990 set kid [lindex $displayorder $row]
5991 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5992 if {$kidx < 0} continue
5993 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5994 foreach p $olds {
5995 set px [lsearch -exact $nextrow $p]
5996 if {$px < 0} continue
5997 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5998 if {[lsearch -exact $ccross $p] >= 0} continue
5999 if {$x == $px + ($kidx < $px? -1: 1)} {
6000 lappend ccross $p
6001 } elseif {[lsearch -exact $cross $p] < 0} {
6002 lappend cross $p
6008 return [concat $ccross {{}} $cross]
6011 proc assigncolor {id} {
6012 global colormap colors nextcolor
6013 global parents children children curview
6015 if {[info exists colormap($id)]} return
6016 set ncolors [llength $colors]
6017 if {[info exists children($curview,$id)]} {
6018 set kids $children($curview,$id)
6019 } else {
6020 set kids {}
6022 if {[llength $kids] == 1} {
6023 set child [lindex $kids 0]
6024 if {[info exists colormap($child)]
6025 && [llength $parents($curview,$child)] == 1} {
6026 set colormap($id) $colormap($child)
6027 return
6030 set badcolors {}
6031 set origbad {}
6032 foreach x [findcrossings $id] {
6033 if {$x eq {}} {
6034 # delimiter between corner crossings and other crossings
6035 if {[llength $badcolors] >= $ncolors - 1} break
6036 set origbad $badcolors
6038 if {[info exists colormap($x)]
6039 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6040 lappend badcolors $colormap($x)
6043 if {[llength $badcolors] >= $ncolors} {
6044 set badcolors $origbad
6046 set origbad $badcolors
6047 if {[llength $badcolors] < $ncolors - 1} {
6048 foreach child $kids {
6049 if {[info exists colormap($child)]
6050 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6051 lappend badcolors $colormap($child)
6053 foreach p $parents($curview,$child) {
6054 if {[info exists colormap($p)]
6055 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6056 lappend badcolors $colormap($p)
6060 if {[llength $badcolors] >= $ncolors} {
6061 set badcolors $origbad
6064 for {set i 0} {$i <= $ncolors} {incr i} {
6065 set c [lindex $colors $nextcolor]
6066 if {[incr nextcolor] >= $ncolors} {
6067 set nextcolor 0
6069 if {[lsearch -exact $badcolors $c]} break
6071 set colormap($id) $c
6074 proc bindline {t id} {
6075 global canv
6077 $canv bind $t <Enter> "lineenter %x %y $id"
6078 $canv bind $t <Motion> "linemotion %x %y $id"
6079 $canv bind $t <Leave> "lineleave $id"
6080 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6083 proc drawtags {id x xt y1} {
6084 global idtags idheads idotherrefs mainhead
6085 global linespc lthickness
6086 global canv rowtextx curview fgcolor bgcolor ctxbut
6088 set marks {}
6089 set ntags 0
6090 set nheads 0
6091 if {[info exists idtags($id)]} {
6092 set marks $idtags($id)
6093 set ntags [llength $marks]
6095 if {[info exists idheads($id)]} {
6096 set marks [concat $marks $idheads($id)]
6097 set nheads [llength $idheads($id)]
6099 if {[info exists idotherrefs($id)]} {
6100 set marks [concat $marks $idotherrefs($id)]
6102 if {$marks eq {}} {
6103 return $xt
6106 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6107 set yt [expr {$y1 - 0.5 * $linespc}]
6108 set yb [expr {$yt + $linespc - 1}]
6109 set xvals {}
6110 set wvals {}
6111 set i -1
6112 foreach tag $marks {
6113 incr i
6114 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6115 set wid [font measure mainfontbold $tag]
6116 } else {
6117 set wid [font measure mainfont $tag]
6119 lappend xvals $xt
6120 lappend wvals $wid
6121 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6123 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6124 -width $lthickness -fill black -tags tag.$id]
6125 $canv lower $t
6126 foreach tag $marks x $xvals wid $wvals {
6127 set xl [expr {$x + $delta}]
6128 set xr [expr {$x + $delta + $wid + $lthickness}]
6129 set font mainfont
6130 if {[incr ntags -1] >= 0} {
6131 # draw a tag
6132 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6133 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6134 -width 1 -outline black -fill yellow -tags tag.$id]
6135 $canv bind $t <1> [list showtag $tag 1]
6136 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6137 } else {
6138 # draw a head or other ref
6139 if {[incr nheads -1] >= 0} {
6140 set col green
6141 if {$tag eq $mainhead} {
6142 set font mainfontbold
6144 } else {
6145 set col "#ddddff"
6147 set xl [expr {$xl - $delta/2}]
6148 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6149 -width 1 -outline black -fill $col -tags tag.$id
6150 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6151 set rwid [font measure mainfont $remoteprefix]
6152 set xi [expr {$x + 1}]
6153 set yti [expr {$yt + 1}]
6154 set xri [expr {$x + $rwid}]
6155 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6156 -width 0 -fill "#ffddaa" -tags tag.$id
6159 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6160 -font $font -tags [list tag.$id text]]
6161 if {$ntags >= 0} {
6162 $canv bind $t <1> [list showtag $tag 1]
6163 } elseif {$nheads >= 0} {
6164 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6167 return $xt
6170 proc xcoord {i level ln} {
6171 global canvx0 xspc1 xspc2
6173 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6174 if {$i > 0 && $i == $level} {
6175 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6176 } elseif {$i > $level} {
6177 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6179 return $x
6182 proc show_status {msg} {
6183 global canv fgcolor
6185 clear_display
6186 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6187 -tags text -fill $fgcolor
6190 # Don't change the text pane cursor if it is currently the hand cursor,
6191 # showing that we are over a sha1 ID link.
6192 proc settextcursor {c} {
6193 global ctext curtextcursor
6195 if {[$ctext cget -cursor] == $curtextcursor} {
6196 $ctext config -cursor $c
6198 set curtextcursor $c
6201 proc nowbusy {what {name {}}} {
6202 global isbusy busyname statusw
6204 if {[array names isbusy] eq {}} {
6205 . config -cursor watch
6206 settextcursor watch
6208 set isbusy($what) 1
6209 set busyname($what) $name
6210 if {$name ne {}} {
6211 $statusw conf -text $name
6215 proc notbusy {what} {
6216 global isbusy maincursor textcursor busyname statusw
6218 catch {
6219 unset isbusy($what)
6220 if {$busyname($what) ne {} &&
6221 [$statusw cget -text] eq $busyname($what)} {
6222 $statusw conf -text {}
6225 if {[array names isbusy] eq {}} {
6226 . config -cursor $maincursor
6227 settextcursor $textcursor
6231 proc findmatches {f} {
6232 global findtype findstring
6233 if {$findtype == [mc "Regexp"]} {
6234 set matches [regexp -indices -all -inline $findstring $f]
6235 } else {
6236 set fs $findstring
6237 if {$findtype == [mc "IgnCase"]} {
6238 set f [string tolower $f]
6239 set fs [string tolower $fs]
6241 set matches {}
6242 set i 0
6243 set l [string length $fs]
6244 while {[set j [string first $fs $f $i]] >= 0} {
6245 lappend matches [list $j [expr {$j+$l-1}]]
6246 set i [expr {$j + $l}]
6249 return $matches
6252 proc dofind {{dirn 1} {wrap 1}} {
6253 global findstring findstartline findcurline selectedline numcommits
6254 global gdttype filehighlight fh_serial find_dirn findallowwrap
6256 if {[info exists find_dirn]} {
6257 if {$find_dirn == $dirn} return
6258 stopfinding
6260 focus .
6261 if {$findstring eq {} || $numcommits == 0} return
6262 if {$selectedline eq {}} {
6263 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6264 } else {
6265 set findstartline $selectedline
6267 set findcurline $findstartline
6268 nowbusy finding [mc "Searching"]
6269 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6270 after cancel do_file_hl $fh_serial
6271 do_file_hl $fh_serial
6273 set find_dirn $dirn
6274 set findallowwrap $wrap
6275 run findmore
6278 proc stopfinding {} {
6279 global find_dirn findcurline fprogcoord
6281 if {[info exists find_dirn]} {
6282 unset find_dirn
6283 unset findcurline
6284 notbusy finding
6285 set fprogcoord 0
6286 adjustprogress
6288 stopblaming
6291 proc findmore {} {
6292 global commitdata commitinfo numcommits findpattern findloc
6293 global findstartline findcurline findallowwrap
6294 global find_dirn gdttype fhighlights fprogcoord
6295 global curview varcorder vrownum varccommits vrowmod
6297 if {![info exists find_dirn]} {
6298 return 0
6300 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6301 set l $findcurline
6302 set moretodo 0
6303 if {$find_dirn > 0} {
6304 incr l
6305 if {$l >= $numcommits} {
6306 set l 0
6308 if {$l <= $findstartline} {
6309 set lim [expr {$findstartline + 1}]
6310 } else {
6311 set lim $numcommits
6312 set moretodo $findallowwrap
6314 } else {
6315 if {$l == 0} {
6316 set l $numcommits
6318 incr l -1
6319 if {$l >= $findstartline} {
6320 set lim [expr {$findstartline - 1}]
6321 } else {
6322 set lim -1
6323 set moretodo $findallowwrap
6326 set n [expr {($lim - $l) * $find_dirn}]
6327 if {$n > 500} {
6328 set n 500
6329 set moretodo 1
6331 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6332 update_arcrows $curview
6334 set found 0
6335 set domore 1
6336 set ai [bsearch $vrownum($curview) $l]
6337 set a [lindex $varcorder($curview) $ai]
6338 set arow [lindex $vrownum($curview) $ai]
6339 set ids [lindex $varccommits($curview,$a)]
6340 set arowend [expr {$arow + [llength $ids]}]
6341 if {$gdttype eq [mc "containing:"]} {
6342 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6343 if {$l < $arow || $l >= $arowend} {
6344 incr ai $find_dirn
6345 set a [lindex $varcorder($curview) $ai]
6346 set arow [lindex $vrownum($curview) $ai]
6347 set ids [lindex $varccommits($curview,$a)]
6348 set arowend [expr {$arow + [llength $ids]}]
6350 set id [lindex $ids [expr {$l - $arow}]]
6351 # shouldn't happen unless git log doesn't give all the commits...
6352 if {![info exists commitdata($id)] ||
6353 ![doesmatch $commitdata($id)]} {
6354 continue
6356 if {![info exists commitinfo($id)]} {
6357 getcommit $id
6359 set info $commitinfo($id)
6360 foreach f $info ty $fldtypes {
6361 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6362 [doesmatch $f]} {
6363 set found 1
6364 break
6367 if {$found} break
6369 } else {
6370 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6371 if {$l < $arow || $l >= $arowend} {
6372 incr ai $find_dirn
6373 set a [lindex $varcorder($curview) $ai]
6374 set arow [lindex $vrownum($curview) $ai]
6375 set ids [lindex $varccommits($curview,$a)]
6376 set arowend [expr {$arow + [llength $ids]}]
6378 set id [lindex $ids [expr {$l - $arow}]]
6379 if {![info exists fhighlights($id)]} {
6380 # this sets fhighlights($id) to -1
6381 askfilehighlight $l $id
6383 if {$fhighlights($id) > 0} {
6384 set found $domore
6385 break
6387 if {$fhighlights($id) < 0} {
6388 if {$domore} {
6389 set domore 0
6390 set findcurline [expr {$l - $find_dirn}]
6395 if {$found || ($domore && !$moretodo)} {
6396 unset findcurline
6397 unset find_dirn
6398 notbusy finding
6399 set fprogcoord 0
6400 adjustprogress
6401 if {$found} {
6402 findselectline $l
6403 } else {
6404 bell
6406 return 0
6408 if {!$domore} {
6409 flushhighlights
6410 } else {
6411 set findcurline [expr {$l - $find_dirn}]
6413 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6414 if {$n < 0} {
6415 incr n $numcommits
6417 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6418 adjustprogress
6419 return $domore
6422 proc findselectline {l} {
6423 global findloc commentend ctext findcurline markingmatches gdttype
6425 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6426 set findcurline $l
6427 selectline $l 1
6428 if {$markingmatches &&
6429 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6430 # highlight the matches in the comments
6431 set f [$ctext get 1.0 $commentend]
6432 set matches [findmatches $f]
6433 foreach match $matches {
6434 set start [lindex $match 0]
6435 set end [expr {[lindex $match 1] + 1}]
6436 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6439 drawvisible
6442 # mark the bits of a headline or author that match a find string
6443 proc markmatches {canv l str tag matches font row} {
6444 global selectedline
6446 set bbox [$canv bbox $tag]
6447 set x0 [lindex $bbox 0]
6448 set y0 [lindex $bbox 1]
6449 set y1 [lindex $bbox 3]
6450 foreach match $matches {
6451 set start [lindex $match 0]
6452 set end [lindex $match 1]
6453 if {$start > $end} continue
6454 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6455 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6456 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6457 [expr {$x0+$xlen+2}] $y1 \
6458 -outline {} -tags [list match$l matches] -fill yellow]
6459 $canv lower $t
6460 if {$row == $selectedline} {
6461 $canv raise $t secsel
6466 proc unmarkmatches {} {
6467 global markingmatches
6469 allcanvs delete matches
6470 set markingmatches 0
6471 stopfinding
6474 proc selcanvline {w x y} {
6475 global canv canvy0 ctext linespc
6476 global rowtextx
6477 set ymax [lindex [$canv cget -scrollregion] 3]
6478 if {$ymax == {}} return
6479 set yfrac [lindex [$canv yview] 0]
6480 set y [expr {$y + $yfrac * $ymax}]
6481 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6482 if {$l < 0} {
6483 set l 0
6485 if {$w eq $canv} {
6486 set xmax [lindex [$canv cget -scrollregion] 2]
6487 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6488 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6490 unmarkmatches
6491 selectline $l 1
6494 proc commit_descriptor {p} {
6495 global commitinfo
6496 if {![info exists commitinfo($p)]} {
6497 getcommit $p
6499 set l "..."
6500 if {[llength $commitinfo($p)] > 1} {
6501 set l [lindex $commitinfo($p) 0]
6503 return "$p ($l)\n"
6506 # append some text to the ctext widget, and make any SHA1 ID
6507 # that we know about be a clickable link.
6508 proc appendwithlinks {text tags} {
6509 global ctext linknum curview
6511 set start [$ctext index "end - 1c"]
6512 $ctext insert end $text $tags
6513 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6514 foreach l $links {
6515 set s [lindex $l 0]
6516 set e [lindex $l 1]
6517 set linkid [string range $text $s $e]
6518 incr e
6519 $ctext tag delete link$linknum
6520 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6521 setlink $linkid link$linknum
6522 incr linknum
6526 proc setlink {id lk} {
6527 global curview ctext pendinglinks
6529 set known 0
6530 if {[string length $id] < 40} {
6531 set matches [longid $id]
6532 if {[llength $matches] > 0} {
6533 if {[llength $matches] > 1} return
6534 set known 1
6535 set id [lindex $matches 0]
6537 } else {
6538 set known [commitinview $id $curview]
6540 if {$known} {
6541 $ctext tag conf $lk -foreground blue -underline 1
6542 $ctext tag bind $lk <1> [list selbyid $id]
6543 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6544 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6545 } else {
6546 lappend pendinglinks($id) $lk
6547 interestedin $id {makelink %P}
6551 proc appendshortlink {id {pre {}} {post {}}} {
6552 global ctext linknum
6554 $ctext insert end $pre
6555 $ctext tag delete link$linknum
6556 $ctext insert end [string range $id 0 7] link$linknum
6557 $ctext insert end $post
6558 setlink $id link$linknum
6559 incr linknum
6562 proc makelink {id} {
6563 global pendinglinks
6565 if {![info exists pendinglinks($id)]} return
6566 foreach lk $pendinglinks($id) {
6567 setlink $id $lk
6569 unset pendinglinks($id)
6572 proc linkcursor {w inc} {
6573 global linkentercount curtextcursor
6575 if {[incr linkentercount $inc] > 0} {
6576 $w configure -cursor hand2
6577 } else {
6578 $w configure -cursor $curtextcursor
6579 if {$linkentercount < 0} {
6580 set linkentercount 0
6585 proc viewnextline {dir} {
6586 global canv linespc
6588 $canv delete hover
6589 set ymax [lindex [$canv cget -scrollregion] 3]
6590 set wnow [$canv yview]
6591 set wtop [expr {[lindex $wnow 0] * $ymax}]
6592 set newtop [expr {$wtop + $dir * $linespc}]
6593 if {$newtop < 0} {
6594 set newtop 0
6595 } elseif {$newtop > $ymax} {
6596 set newtop $ymax
6598 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6601 # add a list of tag or branch names at position pos
6602 # returns the number of names inserted
6603 proc appendrefs {pos ids var} {
6604 global ctext linknum curview $var maxrefs
6606 if {[catch {$ctext index $pos}]} {
6607 return 0
6609 $ctext conf -state normal
6610 $ctext delete $pos "$pos lineend"
6611 set tags {}
6612 foreach id $ids {
6613 foreach tag [set $var\($id\)] {
6614 lappend tags [list $tag $id]
6617 if {[llength $tags] > $maxrefs} {
6618 $ctext insert $pos "[mc "many"] ([llength $tags])"
6619 } else {
6620 set tags [lsort -index 0 -decreasing $tags]
6621 set sep {}
6622 foreach ti $tags {
6623 set id [lindex $ti 1]
6624 set lk link$linknum
6625 incr linknum
6626 $ctext tag delete $lk
6627 $ctext insert $pos $sep
6628 $ctext insert $pos [lindex $ti 0] $lk
6629 setlink $id $lk
6630 set sep ", "
6633 $ctext conf -state disabled
6634 return [llength $tags]
6637 # called when we have finished computing the nearby tags
6638 proc dispneartags {delay} {
6639 global selectedline currentid showneartags tagphase
6641 if {$selectedline eq {} || !$showneartags} return
6642 after cancel dispnexttag
6643 if {$delay} {
6644 after 200 dispnexttag
6645 set tagphase -1
6646 } else {
6647 after idle dispnexttag
6648 set tagphase 0
6652 proc dispnexttag {} {
6653 global selectedline currentid showneartags tagphase ctext
6655 if {$selectedline eq {} || !$showneartags} return
6656 switch -- $tagphase {
6658 set dtags [desctags $currentid]
6659 if {$dtags ne {}} {
6660 appendrefs precedes $dtags idtags
6664 set atags [anctags $currentid]
6665 if {$atags ne {}} {
6666 appendrefs follows $atags idtags
6670 set dheads [descheads $currentid]
6671 if {$dheads ne {}} {
6672 if {[appendrefs branch $dheads idheads] > 1
6673 && [$ctext get "branch -3c"] eq "h"} {
6674 # turn "Branch" into "Branches"
6675 $ctext conf -state normal
6676 $ctext insert "branch -2c" "es"
6677 $ctext conf -state disabled
6682 if {[incr tagphase] <= 2} {
6683 after idle dispnexttag
6687 proc make_secsel {id} {
6688 global linehtag linentag linedtag canv canv2 canv3
6690 if {![info exists linehtag($id)]} return
6691 $canv delete secsel
6692 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6693 -tags secsel -fill [$canv cget -selectbackground]]
6694 $canv lower $t
6695 $canv2 delete secsel
6696 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6697 -tags secsel -fill [$canv2 cget -selectbackground]]
6698 $canv2 lower $t
6699 $canv3 delete secsel
6700 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6701 -tags secsel -fill [$canv3 cget -selectbackground]]
6702 $canv3 lower $t
6705 proc make_idmark {id} {
6706 global linehtag canv fgcolor
6708 if {![info exists linehtag($id)]} return
6709 $canv delete markid
6710 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6711 -tags markid -outline $fgcolor]
6712 $canv raise $t
6715 proc selectline {l isnew {desired_loc {}}} {
6716 global canv ctext commitinfo selectedline
6717 global canvy0 linespc parents children curview
6718 global currentid sha1entry
6719 global commentend idtags linknum
6720 global mergemax numcommits pending_select
6721 global cmitmode showneartags allcommits
6722 global targetrow targetid lastscrollrows
6723 global autoselect jump_to_here
6725 catch {unset pending_select}
6726 $canv delete hover
6727 normalline
6728 unsel_reflist
6729 stopfinding
6730 if {$l < 0 || $l >= $numcommits} return
6731 set id [commitonrow $l]
6732 set targetid $id
6733 set targetrow $l
6734 set selectedline $l
6735 set currentid $id
6736 if {$lastscrollrows < $numcommits} {
6737 setcanvscroll
6740 set y [expr {$canvy0 + $l * $linespc}]
6741 set ymax [lindex [$canv cget -scrollregion] 3]
6742 set ytop [expr {$y - $linespc - 1}]
6743 set ybot [expr {$y + $linespc + 1}]
6744 set wnow [$canv yview]
6745 set wtop [expr {[lindex $wnow 0] * $ymax}]
6746 set wbot [expr {[lindex $wnow 1] * $ymax}]
6747 set wh [expr {$wbot - $wtop}]
6748 set newtop $wtop
6749 if {$ytop < $wtop} {
6750 if {$ybot < $wtop} {
6751 set newtop [expr {$y - $wh / 2.0}]
6752 } else {
6753 set newtop $ytop
6754 if {$newtop > $wtop - $linespc} {
6755 set newtop [expr {$wtop - $linespc}]
6758 } elseif {$ybot > $wbot} {
6759 if {$ytop > $wbot} {
6760 set newtop [expr {$y - $wh / 2.0}]
6761 } else {
6762 set newtop [expr {$ybot - $wh}]
6763 if {$newtop < $wtop + $linespc} {
6764 set newtop [expr {$wtop + $linespc}]
6768 if {$newtop != $wtop} {
6769 if {$newtop < 0} {
6770 set newtop 0
6772 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6773 drawvisible
6776 make_secsel $id
6778 if {$isnew} {
6779 addtohistory [list selbyid $id]
6782 $sha1entry delete 0 end
6783 $sha1entry insert 0 $id
6784 if {$autoselect} {
6785 $sha1entry selection from 0
6786 $sha1entry selection to end
6788 rhighlight_sel $id
6790 $ctext conf -state normal
6791 clear_ctext
6792 set linknum 0
6793 if {![info exists commitinfo($id)]} {
6794 getcommit $id
6796 set info $commitinfo($id)
6797 set date [formatdate [lindex $info 2]]
6798 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6799 set date [formatdate [lindex $info 4]]
6800 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6801 if {[info exists idtags($id)]} {
6802 $ctext insert end [mc "Tags:"]
6803 foreach tag $idtags($id) {
6804 $ctext insert end " $tag"
6806 $ctext insert end "\n"
6809 set headers {}
6810 set olds $parents($curview,$id)
6811 if {[llength $olds] > 1} {
6812 set np 0
6813 foreach p $olds {
6814 if {$np >= $mergemax} {
6815 set tag mmax
6816 } else {
6817 set tag m$np
6819 $ctext insert end "[mc "Parent"]: " $tag
6820 appendwithlinks [commit_descriptor $p] {}
6821 incr np
6823 } else {
6824 foreach p $olds {
6825 append headers "[mc "Parent"]: [commit_descriptor $p]"
6829 foreach c $children($curview,$id) {
6830 append headers "[mc "Child"]: [commit_descriptor $c]"
6833 # make anything that looks like a SHA1 ID be a clickable link
6834 appendwithlinks $headers {}
6835 if {$showneartags} {
6836 if {![info exists allcommits]} {
6837 getallcommits
6839 $ctext insert end "[mc "Branch"]: "
6840 $ctext mark set branch "end -1c"
6841 $ctext mark gravity branch left
6842 $ctext insert end "\n[mc "Follows"]: "
6843 $ctext mark set follows "end -1c"
6844 $ctext mark gravity follows left
6845 $ctext insert end "\n[mc "Precedes"]: "
6846 $ctext mark set precedes "end -1c"
6847 $ctext mark gravity precedes left
6848 $ctext insert end "\n"
6849 dispneartags 1
6851 $ctext insert end "\n"
6852 set comment [lindex $info 5]
6853 if {[string first "\r" $comment] >= 0} {
6854 set comment [string map {"\r" "\n "} $comment]
6856 appendwithlinks $comment {comment}
6858 $ctext tag remove found 1.0 end
6859 $ctext conf -state disabled
6860 set commentend [$ctext index "end - 1c"]
6862 set jump_to_here $desired_loc
6863 init_flist [mc "Comments"]
6864 if {$cmitmode eq "tree"} {
6865 gettree $id
6866 } elseif {[llength $olds] <= 1} {
6867 startdiff $id
6868 } else {
6869 mergediff $id
6873 proc selfirstline {} {
6874 unmarkmatches
6875 selectline 0 1
6878 proc sellastline {} {
6879 global numcommits
6880 unmarkmatches
6881 set l [expr {$numcommits - 1}]
6882 selectline $l 1
6885 proc selnextline {dir} {
6886 global selectedline
6887 focus .
6888 if {$selectedline eq {}} return
6889 set l [expr {$selectedline + $dir}]
6890 unmarkmatches
6891 selectline $l 1
6894 proc selnextpage {dir} {
6895 global canv linespc selectedline numcommits
6897 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6898 if {$lpp < 1} {
6899 set lpp 1
6901 allcanvs yview scroll [expr {$dir * $lpp}] units
6902 drawvisible
6903 if {$selectedline eq {}} return
6904 set l [expr {$selectedline + $dir * $lpp}]
6905 if {$l < 0} {
6906 set l 0
6907 } elseif {$l >= $numcommits} {
6908 set l [expr $numcommits - 1]
6910 unmarkmatches
6911 selectline $l 1
6914 proc unselectline {} {
6915 global selectedline currentid
6917 set selectedline {}
6918 catch {unset currentid}
6919 allcanvs delete secsel
6920 rhighlight_none
6923 proc reselectline {} {
6924 global selectedline
6926 if {$selectedline ne {}} {
6927 selectline $selectedline 0
6931 proc addtohistory {cmd} {
6932 global history historyindex curview
6934 set elt [list $curview $cmd]
6935 if {$historyindex > 0
6936 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6937 return
6940 if {$historyindex < [llength $history]} {
6941 set history [lreplace $history $historyindex end $elt]
6942 } else {
6943 lappend history $elt
6945 incr historyindex
6946 if {$historyindex > 1} {
6947 .tf.bar.leftbut conf -state normal
6948 } else {
6949 .tf.bar.leftbut conf -state disabled
6951 .tf.bar.rightbut conf -state disabled
6954 proc godo {elt} {
6955 global curview
6957 set view [lindex $elt 0]
6958 set cmd [lindex $elt 1]
6959 if {$curview != $view} {
6960 showview $view
6962 eval $cmd
6965 proc goback {} {
6966 global history historyindex
6967 focus .
6969 if {$historyindex > 1} {
6970 incr historyindex -1
6971 godo [lindex $history [expr {$historyindex - 1}]]
6972 .tf.bar.rightbut conf -state normal
6974 if {$historyindex <= 1} {
6975 .tf.bar.leftbut conf -state disabled
6979 proc goforw {} {
6980 global history historyindex
6981 focus .
6983 if {$historyindex < [llength $history]} {
6984 set cmd [lindex $history $historyindex]
6985 incr historyindex
6986 godo $cmd
6987 .tf.bar.leftbut conf -state normal
6989 if {$historyindex >= [llength $history]} {
6990 .tf.bar.rightbut conf -state disabled
6994 proc gettree {id} {
6995 global treefilelist treeidlist diffids diffmergeid treepending
6996 global nullid nullid2
6998 set diffids $id
6999 catch {unset diffmergeid}
7000 if {![info exists treefilelist($id)]} {
7001 if {![info exists treepending]} {
7002 if {$id eq $nullid} {
7003 set cmd [list | git ls-files]
7004 } elseif {$id eq $nullid2} {
7005 set cmd [list | git ls-files --stage -t]
7006 } else {
7007 set cmd [list | git ls-tree -r $id]
7009 if {[catch {set gtf [open $cmd r]}]} {
7010 return
7012 set treepending $id
7013 set treefilelist($id) {}
7014 set treeidlist($id) {}
7015 fconfigure $gtf -blocking 0 -encoding binary
7016 filerun $gtf [list gettreeline $gtf $id]
7018 } else {
7019 setfilelist $id
7023 proc gettreeline {gtf id} {
7024 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7026 set nl 0
7027 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7028 if {$diffids eq $nullid} {
7029 set fname $line
7030 } else {
7031 set i [string first "\t" $line]
7032 if {$i < 0} continue
7033 set fname [string range $line [expr {$i+1}] end]
7034 set line [string range $line 0 [expr {$i-1}]]
7035 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7036 set sha1 [lindex $line 2]
7037 lappend treeidlist($id) $sha1
7039 if {[string index $fname 0] eq "\""} {
7040 set fname [lindex $fname 0]
7042 set fname [encoding convertfrom $fname]
7043 lappend treefilelist($id) $fname
7045 if {![eof $gtf]} {
7046 return [expr {$nl >= 1000? 2: 1}]
7048 close $gtf
7049 unset treepending
7050 if {$cmitmode ne "tree"} {
7051 if {![info exists diffmergeid]} {
7052 gettreediffs $diffids
7054 } elseif {$id ne $diffids} {
7055 gettree $diffids
7056 } else {
7057 setfilelist $id
7059 return 0
7062 proc showfile {f} {
7063 global treefilelist treeidlist diffids nullid nullid2
7064 global ctext_file_names ctext_file_lines
7065 global ctext commentend
7067 set i [lsearch -exact $treefilelist($diffids) $f]
7068 if {$i < 0} {
7069 puts "oops, $f not in list for id $diffids"
7070 return
7072 if {$diffids eq $nullid} {
7073 if {[catch {set bf [open $f r]} err]} {
7074 puts "oops, can't read $f: $err"
7075 return
7077 } else {
7078 set blob [lindex $treeidlist($diffids) $i]
7079 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7080 puts "oops, error reading blob $blob: $err"
7081 return
7084 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7085 filerun $bf [list getblobline $bf $diffids]
7086 $ctext config -state normal
7087 clear_ctext $commentend
7088 lappend ctext_file_names $f
7089 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7090 $ctext insert end "\n"
7091 $ctext insert end "$f\n" filesep
7092 $ctext config -state disabled
7093 $ctext yview $commentend
7094 settabs 0
7097 proc getblobline {bf id} {
7098 global diffids cmitmode ctext
7100 if {$id ne $diffids || $cmitmode ne "tree"} {
7101 catch {close $bf}
7102 return 0
7104 $ctext config -state normal
7105 set nl 0
7106 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7107 $ctext insert end "$line\n"
7109 if {[eof $bf]} {
7110 global jump_to_here ctext_file_names commentend
7112 # delete last newline
7113 $ctext delete "end - 2c" "end - 1c"
7114 close $bf
7115 if {$jump_to_here ne {} &&
7116 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7117 set lnum [expr {[lindex $jump_to_here 1] +
7118 [lindex [split $commentend .] 0]}]
7119 mark_ctext_line $lnum
7121 return 0
7123 $ctext config -state disabled
7124 return [expr {$nl >= 1000? 2: 1}]
7127 proc mark_ctext_line {lnum} {
7128 global ctext markbgcolor
7130 $ctext tag delete omark
7131 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7132 $ctext tag conf omark -background $markbgcolor
7133 $ctext see $lnum.0
7136 proc mergediff {id} {
7137 global diffmergeid
7138 global diffids treediffs
7139 global parents curview
7141 set diffmergeid $id
7142 set diffids $id
7143 set treediffs($id) {}
7144 set np [llength $parents($curview,$id)]
7145 settabs $np
7146 getblobdiffs $id
7149 proc startdiff {ids} {
7150 global treediffs diffids treepending diffmergeid nullid nullid2
7152 settabs 1
7153 set diffids $ids
7154 catch {unset diffmergeid}
7155 if {![info exists treediffs($ids)] ||
7156 [lsearch -exact $ids $nullid] >= 0 ||
7157 [lsearch -exact $ids $nullid2] >= 0} {
7158 if {![info exists treepending]} {
7159 gettreediffs $ids
7161 } else {
7162 addtocflist $ids
7166 proc path_filter {filter name} {
7167 foreach p $filter {
7168 set l [string length $p]
7169 if {[string index $p end] eq "/"} {
7170 if {[string compare -length $l $p $name] == 0} {
7171 return 1
7173 } else {
7174 if {[string compare -length $l $p $name] == 0 &&
7175 ([string length $name] == $l ||
7176 [string index $name $l] eq "/")} {
7177 return 1
7181 return 0
7184 proc addtocflist {ids} {
7185 global treediffs
7187 add_flist $treediffs($ids)
7188 getblobdiffs $ids
7191 proc diffcmd {ids flags} {
7192 global nullid nullid2
7194 set i [lsearch -exact $ids $nullid]
7195 set j [lsearch -exact $ids $nullid2]
7196 if {$i >= 0} {
7197 if {[llength $ids] > 1 && $j < 0} {
7198 # comparing working directory with some specific revision
7199 set cmd [concat | git diff-index $flags]
7200 if {$i == 0} {
7201 lappend cmd -R [lindex $ids 1]
7202 } else {
7203 lappend cmd [lindex $ids 0]
7205 } else {
7206 # comparing working directory with index
7207 set cmd [concat | git diff-files $flags]
7208 if {$j == 1} {
7209 lappend cmd -R
7212 } elseif {$j >= 0} {
7213 set cmd [concat | git diff-index --cached $flags]
7214 if {[llength $ids] > 1} {
7215 # comparing index with specific revision
7216 if {$i == 0} {
7217 lappend cmd -R [lindex $ids 1]
7218 } else {
7219 lappend cmd [lindex $ids 0]
7221 } else {
7222 # comparing index with HEAD
7223 lappend cmd HEAD
7225 } else {
7226 set cmd [concat | git diff-tree -r $flags $ids]
7228 return $cmd
7231 proc gettreediffs {ids} {
7232 global treediff treepending
7234 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7236 set treepending $ids
7237 set treediff {}
7238 fconfigure $gdtf -blocking 0 -encoding binary
7239 filerun $gdtf [list gettreediffline $gdtf $ids]
7242 proc gettreediffline {gdtf ids} {
7243 global treediff treediffs treepending diffids diffmergeid
7244 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7246 set nr 0
7247 set sublist {}
7248 set max 1000
7249 if {$perfile_attrs} {
7250 # cache_gitattr is slow, and even slower on win32 where we
7251 # have to invoke it for only about 30 paths at a time
7252 set max 500
7253 if {[tk windowingsystem] == "win32"} {
7254 set max 120
7257 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7258 set i [string first "\t" $line]
7259 if {$i >= 0} {
7260 set file [string range $line [expr {$i+1}] end]
7261 if {[string index $file 0] eq "\""} {
7262 set file [lindex $file 0]
7264 set file [encoding convertfrom $file]
7265 if {$file ne [lindex $treediff end]} {
7266 lappend treediff $file
7267 lappend sublist $file
7271 if {$perfile_attrs} {
7272 cache_gitattr encoding $sublist
7274 if {![eof $gdtf]} {
7275 return [expr {$nr >= $max? 2: 1}]
7277 close $gdtf
7278 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7279 set flist {}
7280 foreach f $treediff {
7281 if {[path_filter $vfilelimit($curview) $f]} {
7282 lappend flist $f
7285 set treediffs($ids) $flist
7286 } else {
7287 set treediffs($ids) $treediff
7289 unset treepending
7290 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7291 gettree $diffids
7292 } elseif {$ids != $diffids} {
7293 if {![info exists diffmergeid]} {
7294 gettreediffs $diffids
7296 } else {
7297 addtocflist $ids
7299 return 0
7302 # empty string or positive integer
7303 proc diffcontextvalidate {v} {
7304 return [regexp {^(|[1-9][0-9]*)$} $v]
7307 proc diffcontextchange {n1 n2 op} {
7308 global diffcontextstring diffcontext
7310 if {[string is integer -strict $diffcontextstring]} {
7311 if {$diffcontextstring >= 0} {
7312 set diffcontext $diffcontextstring
7313 reselectline
7318 proc changeignorespace {} {
7319 reselectline
7322 proc getblobdiffs {ids} {
7323 global blobdifffd diffids env
7324 global diffinhdr treediffs
7325 global diffcontext
7326 global ignorespace
7327 global limitdiffs vfilelimit curview
7328 global diffencoding targetline diffnparents
7329 global git_version
7331 set textconv {}
7332 if {[package vcompare $git_version "1.6.1"] >= 0} {
7333 set textconv "--textconv"
7335 set cmd [diffcmd $ids "-p $textconv -C --cc --no-commit-id -U$diffcontext"]
7336 if {$ignorespace} {
7337 append cmd " -w"
7339 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7340 set cmd [concat $cmd -- $vfilelimit($curview)]
7342 if {[catch {set bdf [open $cmd r]} err]} {
7343 error_popup [mc "Error getting diffs: %s" $err]
7344 return
7346 set targetline {}
7347 set diffnparents 0
7348 set diffinhdr 0
7349 set diffencoding [get_path_encoding {}]
7350 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7351 set blobdifffd($ids) $bdf
7352 filerun $bdf [list getblobdiffline $bdf $diffids]
7355 proc setinlist {var i val} {
7356 global $var
7358 while {[llength [set $var]] < $i} {
7359 lappend $var {}
7361 if {[llength [set $var]] == $i} {
7362 lappend $var $val
7363 } else {
7364 lset $var $i $val
7368 proc makediffhdr {fname ids} {
7369 global ctext curdiffstart treediffs diffencoding
7370 global ctext_file_names jump_to_here targetline diffline
7372 set fname [encoding convertfrom $fname]
7373 set diffencoding [get_path_encoding $fname]
7374 set i [lsearch -exact $treediffs($ids) $fname]
7375 if {$i >= 0} {
7376 setinlist difffilestart $i $curdiffstart
7378 lset ctext_file_names end $fname
7379 set l [expr {(78 - [string length $fname]) / 2}]
7380 set pad [string range "----------------------------------------" 1 $l]
7381 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7382 set targetline {}
7383 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7384 set targetline [lindex $jump_to_here 1]
7386 set diffline 0
7389 proc getblobdiffline {bdf ids} {
7390 global diffids blobdifffd ctext curdiffstart
7391 global diffnexthead diffnextnote difffilestart
7392 global ctext_file_names ctext_file_lines
7393 global diffinhdr treediffs mergemax diffnparents
7394 global diffencoding jump_to_here targetline diffline
7396 set nr 0
7397 $ctext conf -state normal
7398 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7399 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7400 close $bdf
7401 return 0
7403 if {![string compare -length 5 "diff " $line]} {
7404 if {![regexp {^diff (--cc|--git) } $line m type]} {
7405 set line [encoding convertfrom $line]
7406 $ctext insert end "$line\n" hunksep
7407 continue
7409 # start of a new file
7410 set diffinhdr 1
7411 $ctext insert end "\n"
7412 set curdiffstart [$ctext index "end - 1c"]
7413 lappend ctext_file_names ""
7414 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7415 $ctext insert end "\n" filesep
7417 if {$type eq "--cc"} {
7418 # start of a new file in a merge diff
7419 set fname [string range $line 10 end]
7420 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7421 lappend treediffs($ids) $fname
7422 add_flist [list $fname]
7425 } else {
7426 set line [string range $line 11 end]
7427 # If the name hasn't changed the length will be odd,
7428 # the middle char will be a space, and the two bits either
7429 # side will be a/name and b/name, or "a/name" and "b/name".
7430 # If the name has changed we'll get "rename from" and
7431 # "rename to" or "copy from" and "copy to" lines following
7432 # this, and we'll use them to get the filenames.
7433 # This complexity is necessary because spaces in the
7434 # filename(s) don't get escaped.
7435 set l [string length $line]
7436 set i [expr {$l / 2}]
7437 if {!(($l & 1) && [string index $line $i] eq " " &&
7438 [string range $line 2 [expr {$i - 1}]] eq \
7439 [string range $line [expr {$i + 3}] end])} {
7440 continue
7442 # unescape if quoted and chop off the a/ from the front
7443 if {[string index $line 0] eq "\""} {
7444 set fname [string range [lindex $line 0] 2 end]
7445 } else {
7446 set fname [string range $line 2 [expr {$i - 1}]]
7449 makediffhdr $fname $ids
7451 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7452 set fname [encoding convertfrom [string range $line 16 end]]
7453 $ctext insert end "\n"
7454 set curdiffstart [$ctext index "end - 1c"]
7455 lappend ctext_file_names $fname
7456 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7457 $ctext insert end "$line\n" filesep
7458 set i [lsearch -exact $treediffs($ids) $fname]
7459 if {$i >= 0} {
7460 setinlist difffilestart $i $curdiffstart
7463 } elseif {![string compare -length 2 "@@" $line]} {
7464 regexp {^@@+} $line ats
7465 set line [encoding convertfrom $diffencoding $line]
7466 $ctext insert end "$line\n" hunksep
7467 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7468 set diffline $nl
7470 set diffnparents [expr {[string length $ats] - 1}]
7471 set diffinhdr 0
7473 } elseif {$diffinhdr} {
7474 if {![string compare -length 12 "rename from " $line]} {
7475 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7476 if {[string index $fname 0] eq "\""} {
7477 set fname [lindex $fname 0]
7479 set fname [encoding convertfrom $fname]
7480 set i [lsearch -exact $treediffs($ids) $fname]
7481 if {$i >= 0} {
7482 setinlist difffilestart $i $curdiffstart
7484 } elseif {![string compare -length 10 $line "rename to "] ||
7485 ![string compare -length 8 $line "copy to "]} {
7486 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7487 if {[string index $fname 0] eq "\""} {
7488 set fname [lindex $fname 0]
7490 makediffhdr $fname $ids
7491 } elseif {[string compare -length 3 $line "---"] == 0} {
7492 # do nothing
7493 continue
7494 } elseif {[string compare -length 3 $line "+++"] == 0} {
7495 set diffinhdr 0
7496 continue
7498 $ctext insert end "$line\n" filesep
7500 } else {
7501 set line [string map {\x1A ^Z} \
7502 [encoding convertfrom $diffencoding $line]]
7503 # parse the prefix - one ' ', '-' or '+' for each parent
7504 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7505 set tag [expr {$diffnparents > 1? "m": "d"}]
7506 if {[string trim $prefix " -+"] eq {}} {
7507 # prefix only has " ", "-" and "+" in it: normal diff line
7508 set num [string first "-" $prefix]
7509 if {$num >= 0} {
7510 # removed line, first parent with line is $num
7511 if {$num >= $mergemax} {
7512 set num "max"
7514 $ctext insert end "$line\n" $tag$num
7515 } else {
7516 set tags {}
7517 if {[string first "+" $prefix] >= 0} {
7518 # added line
7519 lappend tags ${tag}result
7520 if {$diffnparents > 1} {
7521 set num [string first " " $prefix]
7522 if {$num >= 0} {
7523 if {$num >= $mergemax} {
7524 set num "max"
7526 lappend tags m$num
7530 if {$targetline ne {}} {
7531 if {$diffline == $targetline} {
7532 set seehere [$ctext index "end - 1 chars"]
7533 set targetline {}
7534 } else {
7535 incr diffline
7538 $ctext insert end "$line\n" $tags
7540 } else {
7541 # "\ No newline at end of file",
7542 # or something else we don't recognize
7543 $ctext insert end "$line\n" hunksep
7547 if {[info exists seehere]} {
7548 mark_ctext_line [lindex [split $seehere .] 0]
7550 $ctext conf -state disabled
7551 if {[eof $bdf]} {
7552 close $bdf
7553 return 0
7555 return [expr {$nr >= 1000? 2: 1}]
7558 proc changediffdisp {} {
7559 global ctext diffelide
7561 $ctext tag conf d0 -elide [lindex $diffelide 0]
7562 $ctext tag conf dresult -elide [lindex $diffelide 1]
7565 proc highlightfile {loc cline} {
7566 global ctext cflist cflist_top
7568 $ctext yview $loc
7569 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7570 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7571 $cflist see $cline.0
7572 set cflist_top $cline
7575 proc prevfile {} {
7576 global difffilestart ctext cmitmode
7578 if {$cmitmode eq "tree"} return
7579 set prev 0.0
7580 set prevline 1
7581 set here [$ctext index @0,0]
7582 foreach loc $difffilestart {
7583 if {[$ctext compare $loc >= $here]} {
7584 highlightfile $prev $prevline
7585 return
7587 set prev $loc
7588 incr prevline
7590 highlightfile $prev $prevline
7593 proc nextfile {} {
7594 global difffilestart ctext cmitmode
7596 if {$cmitmode eq "tree"} return
7597 set here [$ctext index @0,0]
7598 set line 1
7599 foreach loc $difffilestart {
7600 incr line
7601 if {[$ctext compare $loc > $here]} {
7602 highlightfile $loc $line
7603 return
7608 proc clear_ctext {{first 1.0}} {
7609 global ctext smarktop smarkbot
7610 global ctext_file_names ctext_file_lines
7611 global pendinglinks
7613 set l [lindex [split $first .] 0]
7614 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7615 set smarktop $l
7617 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7618 set smarkbot $l
7620 $ctext delete $first end
7621 if {$first eq "1.0"} {
7622 catch {unset pendinglinks}
7624 set ctext_file_names {}
7625 set ctext_file_lines {}
7628 proc settabs {{firstab {}}} {
7629 global firsttabstop tabstop ctext have_tk85
7631 if {$firstab ne {} && $have_tk85} {
7632 set firsttabstop $firstab
7634 set w [font measure textfont "0"]
7635 if {$firsttabstop != 0} {
7636 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7637 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7638 } elseif {$have_tk85 || $tabstop != 8} {
7639 $ctext conf -tabs [expr {$tabstop * $w}]
7640 } else {
7641 $ctext conf -tabs {}
7645 proc incrsearch {name ix op} {
7646 global ctext searchstring searchdirn
7648 $ctext tag remove found 1.0 end
7649 if {[catch {$ctext index anchor}]} {
7650 # no anchor set, use start of selection, or of visible area
7651 set sel [$ctext tag ranges sel]
7652 if {$sel ne {}} {
7653 $ctext mark set anchor [lindex $sel 0]
7654 } elseif {$searchdirn eq "-forwards"} {
7655 $ctext mark set anchor @0,0
7656 } else {
7657 $ctext mark set anchor @0,[winfo height $ctext]
7660 if {$searchstring ne {}} {
7661 set here [$ctext search $searchdirn -- $searchstring anchor]
7662 if {$here ne {}} {
7663 $ctext see $here
7665 searchmarkvisible 1
7669 proc dosearch {} {
7670 global sstring ctext searchstring searchdirn
7672 focus $sstring
7673 $sstring icursor end
7674 set searchdirn -forwards
7675 if {$searchstring ne {}} {
7676 set sel [$ctext tag ranges sel]
7677 if {$sel ne {}} {
7678 set start "[lindex $sel 0] + 1c"
7679 } elseif {[catch {set start [$ctext index anchor]}]} {
7680 set start "@0,0"
7682 set match [$ctext search -count mlen -- $searchstring $start]
7683 $ctext tag remove sel 1.0 end
7684 if {$match eq {}} {
7685 bell
7686 return
7688 $ctext see $match
7689 set mend "$match + $mlen c"
7690 $ctext tag add sel $match $mend
7691 $ctext mark unset anchor
7695 proc dosearchback {} {
7696 global sstring ctext searchstring searchdirn
7698 focus $sstring
7699 $sstring icursor end
7700 set searchdirn -backwards
7701 if {$searchstring ne {}} {
7702 set sel [$ctext tag ranges sel]
7703 if {$sel ne {}} {
7704 set start [lindex $sel 0]
7705 } elseif {[catch {set start [$ctext index anchor]}]} {
7706 set start @0,[winfo height $ctext]
7708 set match [$ctext search -backwards -count ml -- $searchstring $start]
7709 $ctext tag remove sel 1.0 end
7710 if {$match eq {}} {
7711 bell
7712 return
7714 $ctext see $match
7715 set mend "$match + $ml c"
7716 $ctext tag add sel $match $mend
7717 $ctext mark unset anchor
7721 proc searchmark {first last} {
7722 global ctext searchstring
7724 set mend $first.0
7725 while {1} {
7726 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7727 if {$match eq {}} break
7728 set mend "$match + $mlen c"
7729 $ctext tag add found $match $mend
7733 proc searchmarkvisible {doall} {
7734 global ctext smarktop smarkbot
7736 set topline [lindex [split [$ctext index @0,0] .] 0]
7737 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7738 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7739 # no overlap with previous
7740 searchmark $topline $botline
7741 set smarktop $topline
7742 set smarkbot $botline
7743 } else {
7744 if {$topline < $smarktop} {
7745 searchmark $topline [expr {$smarktop-1}]
7746 set smarktop $topline
7748 if {$botline > $smarkbot} {
7749 searchmark [expr {$smarkbot+1}] $botline
7750 set smarkbot $botline
7755 proc scrolltext {f0 f1} {
7756 global searchstring
7758 .bleft.bottom.sb set $f0 $f1
7759 if {$searchstring ne {}} {
7760 searchmarkvisible 0
7764 proc setcoords {} {
7765 global linespc charspc canvx0 canvy0
7766 global xspc1 xspc2 lthickness
7768 set linespc [font metrics mainfont -linespace]
7769 set charspc [font measure mainfont "m"]
7770 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7771 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7772 set lthickness [expr {int($linespc / 9) + 1}]
7773 set xspc1(0) $linespc
7774 set xspc2 $linespc
7777 proc redisplay {} {
7778 global canv
7779 global selectedline
7781 set ymax [lindex [$canv cget -scrollregion] 3]
7782 if {$ymax eq {} || $ymax == 0} return
7783 set span [$canv yview]
7784 clear_display
7785 setcanvscroll
7786 allcanvs yview moveto [lindex $span 0]
7787 drawvisible
7788 if {$selectedline ne {}} {
7789 selectline $selectedline 0
7790 allcanvs yview moveto [lindex $span 0]
7794 proc parsefont {f n} {
7795 global fontattr
7797 set fontattr($f,family) [lindex $n 0]
7798 set s [lindex $n 1]
7799 if {$s eq {} || $s == 0} {
7800 set s 10
7801 } elseif {$s < 0} {
7802 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7804 set fontattr($f,size) $s
7805 set fontattr($f,weight) normal
7806 set fontattr($f,slant) roman
7807 foreach style [lrange $n 2 end] {
7808 switch -- $style {
7809 "normal" -
7810 "bold" {set fontattr($f,weight) $style}
7811 "roman" -
7812 "italic" {set fontattr($f,slant) $style}
7817 proc fontflags {f {isbold 0}} {
7818 global fontattr
7820 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7821 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7822 -slant $fontattr($f,slant)]
7825 proc fontname {f} {
7826 global fontattr
7828 set n [list $fontattr($f,family) $fontattr($f,size)]
7829 if {$fontattr($f,weight) eq "bold"} {
7830 lappend n "bold"
7832 if {$fontattr($f,slant) eq "italic"} {
7833 lappend n "italic"
7835 return $n
7838 proc incrfont {inc} {
7839 global mainfont textfont ctext canv cflist showrefstop
7840 global stopped entries fontattr
7842 unmarkmatches
7843 set s $fontattr(mainfont,size)
7844 incr s $inc
7845 if {$s < 1} {
7846 set s 1
7848 set fontattr(mainfont,size) $s
7849 font config mainfont -size $s
7850 font config mainfontbold -size $s
7851 set mainfont [fontname mainfont]
7852 set s $fontattr(textfont,size)
7853 incr s $inc
7854 if {$s < 1} {
7855 set s 1
7857 set fontattr(textfont,size) $s
7858 font config textfont -size $s
7859 font config textfontbold -size $s
7860 set textfont [fontname textfont]
7861 setcoords
7862 settabs
7863 redisplay
7866 proc clearsha1 {} {
7867 global sha1entry sha1string
7868 if {[string length $sha1string] == 40} {
7869 $sha1entry delete 0 end
7873 proc sha1change {n1 n2 op} {
7874 global sha1string currentid sha1but
7875 if {$sha1string == {}
7876 || ([info exists currentid] && $sha1string == $currentid)} {
7877 set state disabled
7878 } else {
7879 set state normal
7881 if {[$sha1but cget -state] == $state} return
7882 if {$state == "normal"} {
7883 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7884 } else {
7885 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7889 proc gotocommit {} {
7890 global sha1string tagids headids curview varcid
7892 if {$sha1string == {}
7893 || ([info exists currentid] && $sha1string == $currentid)} return
7894 if {[info exists tagids($sha1string)]} {
7895 set id $tagids($sha1string)
7896 } elseif {[info exists headids($sha1string)]} {
7897 set id $headids($sha1string)
7898 } else {
7899 set id [string tolower $sha1string]
7900 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7901 set matches [longid $id]
7902 if {$matches ne {}} {
7903 if {[llength $matches] > 1} {
7904 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7905 return
7907 set id [lindex $matches 0]
7911 if {[commitinview $id $curview]} {
7912 selectline [rowofcommit $id] 1
7913 return
7915 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7916 set msg [mc "SHA1 id %s is not known" $sha1string]
7917 } else {
7918 set msg [mc "Tag/Head %s is not known" $sha1string]
7920 error_popup $msg
7923 proc lineenter {x y id} {
7924 global hoverx hovery hoverid hovertimer
7925 global commitinfo canv
7927 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7928 set hoverx $x
7929 set hovery $y
7930 set hoverid $id
7931 if {[info exists hovertimer]} {
7932 after cancel $hovertimer
7934 set hovertimer [after 500 linehover]
7935 $canv delete hover
7938 proc linemotion {x y id} {
7939 global hoverx hovery hoverid hovertimer
7941 if {[info exists hoverid] && $id == $hoverid} {
7942 set hoverx $x
7943 set hovery $y
7944 if {[info exists hovertimer]} {
7945 after cancel $hovertimer
7947 set hovertimer [after 500 linehover]
7951 proc lineleave {id} {
7952 global hoverid hovertimer canv
7954 if {[info exists hoverid] && $id == $hoverid} {
7955 $canv delete hover
7956 if {[info exists hovertimer]} {
7957 after cancel $hovertimer
7958 unset hovertimer
7960 unset hoverid
7964 proc linehover {} {
7965 global hoverx hovery hoverid hovertimer
7966 global canv linespc lthickness
7967 global commitinfo
7969 set text [lindex $commitinfo($hoverid) 0]
7970 set ymax [lindex [$canv cget -scrollregion] 3]
7971 if {$ymax == {}} return
7972 set yfrac [lindex [$canv yview] 0]
7973 set x [expr {$hoverx + 2 * $linespc}]
7974 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7975 set x0 [expr {$x - 2 * $lthickness}]
7976 set y0 [expr {$y - 2 * $lthickness}]
7977 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7978 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7979 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7980 -fill \#ffff80 -outline black -width 1 -tags hover]
7981 $canv raise $t
7982 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7983 -font mainfont]
7984 $canv raise $t
7987 proc clickisonarrow {id y} {
7988 global lthickness
7990 set ranges [rowranges $id]
7991 set thresh [expr {2 * $lthickness + 6}]
7992 set n [expr {[llength $ranges] - 1}]
7993 for {set i 1} {$i < $n} {incr i} {
7994 set row [lindex $ranges $i]
7995 if {abs([yc $row] - $y) < $thresh} {
7996 return $i
7999 return {}
8002 proc arrowjump {id n y} {
8003 global canv
8005 # 1 <-> 2, 3 <-> 4, etc...
8006 set n [expr {(($n - 1) ^ 1) + 1}]
8007 set row [lindex [rowranges $id] $n]
8008 set yt [yc $row]
8009 set ymax [lindex [$canv cget -scrollregion] 3]
8010 if {$ymax eq {} || $ymax <= 0} return
8011 set view [$canv yview]
8012 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8013 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8014 if {$yfrac < 0} {
8015 set yfrac 0
8017 allcanvs yview moveto $yfrac
8020 proc lineclick {x y id isnew} {
8021 global ctext commitinfo children canv thickerline curview
8023 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8024 unmarkmatches
8025 unselectline
8026 normalline
8027 $canv delete hover
8028 # draw this line thicker than normal
8029 set thickerline $id
8030 drawlines $id
8031 if {$isnew} {
8032 set ymax [lindex [$canv cget -scrollregion] 3]
8033 if {$ymax eq {}} return
8034 set yfrac [lindex [$canv yview] 0]
8035 set y [expr {$y + $yfrac * $ymax}]
8037 set dirn [clickisonarrow $id $y]
8038 if {$dirn ne {}} {
8039 arrowjump $id $dirn $y
8040 return
8043 if {$isnew} {
8044 addtohistory [list lineclick $x $y $id 0]
8046 # fill the details pane with info about this line
8047 $ctext conf -state normal
8048 clear_ctext
8049 settabs 0
8050 $ctext insert end "[mc "Parent"]:\t"
8051 $ctext insert end $id link0
8052 setlink $id link0
8053 set info $commitinfo($id)
8054 $ctext insert end "\n\t[lindex $info 0]\n"
8055 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8056 set date [formatdate [lindex $info 2]]
8057 $ctext insert end "\t[mc "Date"]:\t$date\n"
8058 set kids $children($curview,$id)
8059 if {$kids ne {}} {
8060 $ctext insert end "\n[mc "Children"]:"
8061 set i 0
8062 foreach child $kids {
8063 incr i
8064 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8065 set info $commitinfo($child)
8066 $ctext insert end "\n\t"
8067 $ctext insert end $child link$i
8068 setlink $child link$i
8069 $ctext insert end "\n\t[lindex $info 0]"
8070 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8071 set date [formatdate [lindex $info 2]]
8072 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8075 $ctext conf -state disabled
8076 init_flist {}
8079 proc normalline {} {
8080 global thickerline
8081 if {[info exists thickerline]} {
8082 set id $thickerline
8083 unset thickerline
8084 drawlines $id
8088 proc selbyid {id} {
8089 global curview
8090 if {[commitinview $id $curview]} {
8091 selectline [rowofcommit $id] 1
8095 proc mstime {} {
8096 global startmstime
8097 if {![info exists startmstime]} {
8098 set startmstime [clock clicks -milliseconds]
8100 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8103 proc rowmenu {x y id} {
8104 global rowctxmenu selectedline rowmenuid curview
8105 global nullid nullid2 fakerowmenu mainhead markedid
8107 stopfinding
8108 set rowmenuid $id
8109 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8110 set state disabled
8111 } else {
8112 set state normal
8114 if {$id ne $nullid && $id ne $nullid2} {
8115 set menu $rowctxmenu
8116 if {$mainhead ne {}} {
8117 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8118 } else {
8119 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8121 if {[info exists markedid] && $markedid ne $id} {
8122 $menu entryconfigure 9 -state normal
8123 $menu entryconfigure 10 -state normal
8124 $menu entryconfigure 11 -state normal
8125 } else {
8126 $menu entryconfigure 9 -state disabled
8127 $menu entryconfigure 10 -state disabled
8128 $menu entryconfigure 11 -state disabled
8130 } else {
8131 set menu $fakerowmenu
8133 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8134 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8135 $menu entryconfigure [mca "Make patch"] -state $state
8136 tk_popup $menu $x $y
8139 proc markhere {} {
8140 global rowmenuid markedid canv
8142 set markedid $rowmenuid
8143 make_idmark $markedid
8146 proc gotomark {} {
8147 global markedid
8149 if {[info exists markedid]} {
8150 selbyid $markedid
8154 proc replace_by_kids {l r} {
8155 global curview children
8157 set id [commitonrow $r]
8158 set l [lreplace $l 0 0]
8159 foreach kid $children($curview,$id) {
8160 lappend l [rowofcommit $kid]
8162 return [lsort -integer -decreasing -unique $l]
8165 proc find_common_desc {} {
8166 global markedid rowmenuid curview children
8168 if {![info exists markedid]} return
8169 if {![commitinview $markedid $curview] ||
8170 ![commitinview $rowmenuid $curview]} return
8171 #set t1 [clock clicks -milliseconds]
8172 set l1 [list [rowofcommit $markedid]]
8173 set l2 [list [rowofcommit $rowmenuid]]
8174 while 1 {
8175 set r1 [lindex $l1 0]
8176 set r2 [lindex $l2 0]
8177 if {$r1 eq {} || $r2 eq {}} break
8178 if {$r1 == $r2} {
8179 selectline $r1 1
8180 break
8182 if {$r1 > $r2} {
8183 set l1 [replace_by_kids $l1 $r1]
8184 } else {
8185 set l2 [replace_by_kids $l2 $r2]
8188 #set t2 [clock clicks -milliseconds]
8189 #puts "took [expr {$t2-$t1}]ms"
8192 proc compare_commits {} {
8193 global markedid rowmenuid curview children
8195 if {![info exists markedid]} return
8196 if {![commitinview $markedid $curview]} return
8197 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8198 do_cmp_commits $markedid $rowmenuid
8201 proc getpatchid {id} {
8202 global patchids
8204 if {![info exists patchids($id)]} {
8205 set cmd [diffcmd [list $id] {-p --root}]
8206 # trim off the initial "|"
8207 set cmd [lrange $cmd 1 end]
8208 if {[catch {
8209 set x [eval exec $cmd | git patch-id]
8210 set patchids($id) [lindex $x 0]
8211 }]} {
8212 set patchids($id) "error"
8215 return $patchids($id)
8218 proc do_cmp_commits {a b} {
8219 global ctext curview parents children patchids commitinfo
8221 $ctext conf -state normal
8222 clear_ctext
8223 init_flist {}
8224 for {set i 0} {$i < 100} {incr i} {
8225 set skipa 0
8226 set skipb 0
8227 if {[llength $parents($curview,$a)] > 1} {
8228 appendshortlink $a [mc "Skipping merge commit "] "\n"
8229 set skipa 1
8230 } else {
8231 set patcha [getpatchid $a]
8233 if {[llength $parents($curview,$b)] > 1} {
8234 appendshortlink $b [mc "Skipping merge commit "] "\n"
8235 set skipb 1
8236 } else {
8237 set patchb [getpatchid $b]
8239 if {!$skipa && !$skipb} {
8240 set heada [lindex $commitinfo($a) 0]
8241 set headb [lindex $commitinfo($b) 0]
8242 if {$patcha eq "error"} {
8243 appendshortlink $a [mc "Error getting patch ID for "] \
8244 [mc " - stopping\n"]
8245 break
8247 if {$patchb eq "error"} {
8248 appendshortlink $b [mc "Error getting patch ID for "] \
8249 [mc " - stopping\n"]
8250 break
8252 if {$patcha eq $patchb} {
8253 if {$heada eq $headb} {
8254 appendshortlink $a [mc "Commit "]
8255 appendshortlink $b " == " " $heada\n"
8256 } else {
8257 appendshortlink $a [mc "Commit "] " $heada\n"
8258 appendshortlink $b [mc " is the same patch as\n "] \
8259 " $headb\n"
8261 set skipa 1
8262 set skipb 1
8263 } else {
8264 $ctext insert end "\n"
8265 appendshortlink $a [mc "Commit "] " $heada\n"
8266 appendshortlink $b [mc " differs from\n "] \
8267 " $headb\n"
8268 $ctext insert end [mc "- stopping\n"]
8269 break
8272 if {$skipa} {
8273 if {[llength $children($curview,$a)] != 1} {
8274 $ctext insert end "\n"
8275 appendshortlink $a [mc "Commit "] \
8276 [mc " has %s children - stopping\n" \
8277 [llength $children($curview,$a)]]
8278 break
8280 set a [lindex $children($curview,$a) 0]
8282 if {$skipb} {
8283 if {[llength $children($curview,$b)] != 1} {
8284 appendshortlink $b [mc "Commit "] \
8285 [mc " has %s children - stopping\n" \
8286 [llength $children($curview,$b)]]
8287 break
8289 set b [lindex $children($curview,$b) 0]
8292 $ctext conf -state disabled
8295 proc diffvssel {dirn} {
8296 global rowmenuid selectedline
8298 if {$selectedline eq {}} return
8299 if {$dirn} {
8300 set oldid [commitonrow $selectedline]
8301 set newid $rowmenuid
8302 } else {
8303 set oldid $rowmenuid
8304 set newid [commitonrow $selectedline]
8306 addtohistory [list doseldiff $oldid $newid]
8307 doseldiff $oldid $newid
8310 proc doseldiff {oldid newid} {
8311 global ctext
8312 global commitinfo
8314 $ctext conf -state normal
8315 clear_ctext
8316 init_flist [mc "Top"]
8317 $ctext insert end "[mc "From"] "
8318 $ctext insert end $oldid link0
8319 setlink $oldid link0
8320 $ctext insert end "\n "
8321 $ctext insert end [lindex $commitinfo($oldid) 0]
8322 $ctext insert end "\n\n[mc "To"] "
8323 $ctext insert end $newid link1
8324 setlink $newid link1
8325 $ctext insert end "\n "
8326 $ctext insert end [lindex $commitinfo($newid) 0]
8327 $ctext insert end "\n"
8328 $ctext conf -state disabled
8329 $ctext tag remove found 1.0 end
8330 startdiff [list $oldid $newid]
8333 proc mkpatch {} {
8334 global rowmenuid currentid commitinfo patchtop patchnum
8336 if {![info exists currentid]} return
8337 set oldid $currentid
8338 set oldhead [lindex $commitinfo($oldid) 0]
8339 set newid $rowmenuid
8340 set newhead [lindex $commitinfo($newid) 0]
8341 set top .patch
8342 set patchtop $top
8343 catch {destroy $top}
8344 toplevel $top
8345 make_transient $top .
8346 label $top.title -text [mc "Generate patch"]
8347 grid $top.title - -pady 10
8348 label $top.from -text [mc "From:"]
8349 entry $top.fromsha1 -width 40 -relief flat
8350 $top.fromsha1 insert 0 $oldid
8351 $top.fromsha1 conf -state readonly
8352 grid $top.from $top.fromsha1 -sticky w
8353 entry $top.fromhead -width 60 -relief flat
8354 $top.fromhead insert 0 $oldhead
8355 $top.fromhead conf -state readonly
8356 grid x $top.fromhead -sticky w
8357 label $top.to -text [mc "To:"]
8358 entry $top.tosha1 -width 40 -relief flat
8359 $top.tosha1 insert 0 $newid
8360 $top.tosha1 conf -state readonly
8361 grid $top.to $top.tosha1 -sticky w
8362 entry $top.tohead -width 60 -relief flat
8363 $top.tohead insert 0 $newhead
8364 $top.tohead conf -state readonly
8365 grid x $top.tohead -sticky w
8366 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8367 grid $top.rev x -pady 10
8368 label $top.flab -text [mc "Output file:"]
8369 entry $top.fname -width 60
8370 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8371 incr patchnum
8372 grid $top.flab $top.fname -sticky w
8373 frame $top.buts
8374 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8375 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8376 bind $top <Key-Return> mkpatchgo
8377 bind $top <Key-Escape> mkpatchcan
8378 grid $top.buts.gen $top.buts.can
8379 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8380 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8381 grid $top.buts - -pady 10 -sticky ew
8382 focus $top.fname
8385 proc mkpatchrev {} {
8386 global patchtop
8388 set oldid [$patchtop.fromsha1 get]
8389 set oldhead [$patchtop.fromhead get]
8390 set newid [$patchtop.tosha1 get]
8391 set newhead [$patchtop.tohead get]
8392 foreach e [list fromsha1 fromhead tosha1 tohead] \
8393 v [list $newid $newhead $oldid $oldhead] {
8394 $patchtop.$e conf -state normal
8395 $patchtop.$e delete 0 end
8396 $patchtop.$e insert 0 $v
8397 $patchtop.$e conf -state readonly
8401 proc mkpatchgo {} {
8402 global patchtop nullid nullid2
8404 set oldid [$patchtop.fromsha1 get]
8405 set newid [$patchtop.tosha1 get]
8406 set fname [$patchtop.fname get]
8407 set cmd [diffcmd [list $oldid $newid] -p]
8408 # trim off the initial "|"
8409 set cmd [lrange $cmd 1 end]
8410 lappend cmd >$fname &
8411 if {[catch {eval exec $cmd} err]} {
8412 error_popup "[mc "Error creating patch:"] $err" $patchtop
8414 catch {destroy $patchtop}
8415 unset patchtop
8418 proc mkpatchcan {} {
8419 global patchtop
8421 catch {destroy $patchtop}
8422 unset patchtop
8425 proc mktag {} {
8426 global rowmenuid mktagtop commitinfo
8428 set top .maketag
8429 set mktagtop $top
8430 catch {destroy $top}
8431 toplevel $top
8432 make_transient $top .
8433 label $top.title -text [mc "Create tag"]
8434 grid $top.title - -pady 10
8435 label $top.id -text [mc "ID:"]
8436 entry $top.sha1 -width 40 -relief flat
8437 $top.sha1 insert 0 $rowmenuid
8438 $top.sha1 conf -state readonly
8439 grid $top.id $top.sha1 -sticky w
8440 entry $top.head -width 60 -relief flat
8441 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8442 $top.head conf -state readonly
8443 grid x $top.head -sticky w
8444 label $top.tlab -text [mc "Tag name:"]
8445 entry $top.tag -width 60
8446 grid $top.tlab $top.tag -sticky w
8447 frame $top.buts
8448 button $top.buts.gen -text [mc "Create"] -command mktaggo
8449 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8450 bind $top <Key-Return> mktaggo
8451 bind $top <Key-Escape> mktagcan
8452 grid $top.buts.gen $top.buts.can
8453 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8454 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8455 grid $top.buts - -pady 10 -sticky ew
8456 focus $top.tag
8459 proc domktag {} {
8460 global mktagtop env tagids idtags
8462 set id [$mktagtop.sha1 get]
8463 set tag [$mktagtop.tag get]
8464 if {$tag == {}} {
8465 error_popup [mc "No tag name specified"] $mktagtop
8466 return 0
8468 if {[info exists tagids($tag)]} {
8469 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8470 return 0
8472 if {[catch {
8473 exec git tag $tag $id
8474 } err]} {
8475 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8476 return 0
8479 set tagids($tag) $id
8480 lappend idtags($id) $tag
8481 redrawtags $id
8482 addedtag $id
8483 dispneartags 0
8484 run refill_reflist
8485 return 1
8488 proc redrawtags {id} {
8489 global canv linehtag idpos currentid curview cmitlisted markedid
8490 global canvxmax iddrawn circleitem mainheadid circlecolors
8492 if {![commitinview $id $curview]} return
8493 if {![info exists iddrawn($id)]} return
8494 set row [rowofcommit $id]
8495 if {$id eq $mainheadid} {
8496 set ofill yellow
8497 } else {
8498 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8500 $canv itemconf $circleitem($row) -fill $ofill
8501 $canv delete tag.$id
8502 set xt [eval drawtags $id $idpos($id)]
8503 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8504 set text [$canv itemcget $linehtag($id) -text]
8505 set font [$canv itemcget $linehtag($id) -font]
8506 set xr [expr {$xt + [font measure $font $text]}]
8507 if {$xr > $canvxmax} {
8508 set canvxmax $xr
8509 setcanvscroll
8511 if {[info exists currentid] && $currentid == $id} {
8512 make_secsel $id
8514 if {[info exists markedid] && $markedid eq $id} {
8515 make_idmark $id
8519 proc mktagcan {} {
8520 global mktagtop
8522 catch {destroy $mktagtop}
8523 unset mktagtop
8526 proc mktaggo {} {
8527 if {![domktag]} return
8528 mktagcan
8531 proc writecommit {} {
8532 global rowmenuid wrcomtop commitinfo wrcomcmd
8534 set top .writecommit
8535 set wrcomtop $top
8536 catch {destroy $top}
8537 toplevel $top
8538 make_transient $top .
8539 label $top.title -text [mc "Write commit to file"]
8540 grid $top.title - -pady 10
8541 label $top.id -text [mc "ID:"]
8542 entry $top.sha1 -width 40 -relief flat
8543 $top.sha1 insert 0 $rowmenuid
8544 $top.sha1 conf -state readonly
8545 grid $top.id $top.sha1 -sticky w
8546 entry $top.head -width 60 -relief flat
8547 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8548 $top.head conf -state readonly
8549 grid x $top.head -sticky w
8550 label $top.clab -text [mc "Command:"]
8551 entry $top.cmd -width 60 -textvariable wrcomcmd
8552 grid $top.clab $top.cmd -sticky w -pady 10
8553 label $top.flab -text [mc "Output file:"]
8554 entry $top.fname -width 60
8555 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8556 grid $top.flab $top.fname -sticky w
8557 frame $top.buts
8558 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8559 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8560 bind $top <Key-Return> wrcomgo
8561 bind $top <Key-Escape> wrcomcan
8562 grid $top.buts.gen $top.buts.can
8563 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8564 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8565 grid $top.buts - -pady 10 -sticky ew
8566 focus $top.fname
8569 proc wrcomgo {} {
8570 global wrcomtop
8572 set id [$wrcomtop.sha1 get]
8573 set cmd "echo $id | [$wrcomtop.cmd get]"
8574 set fname [$wrcomtop.fname get]
8575 if {[catch {exec sh -c $cmd >$fname &} err]} {
8576 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8578 catch {destroy $wrcomtop}
8579 unset wrcomtop
8582 proc wrcomcan {} {
8583 global wrcomtop
8585 catch {destroy $wrcomtop}
8586 unset wrcomtop
8589 proc mkbranch {} {
8590 global rowmenuid mkbrtop
8592 set top .makebranch
8593 catch {destroy $top}
8594 toplevel $top
8595 make_transient $top .
8596 label $top.title -text [mc "Create new branch"]
8597 grid $top.title - -pady 10
8598 label $top.id -text [mc "ID:"]
8599 entry $top.sha1 -width 40 -relief flat
8600 $top.sha1 insert 0 $rowmenuid
8601 $top.sha1 conf -state readonly
8602 grid $top.id $top.sha1 -sticky w
8603 label $top.nlab -text [mc "Name:"]
8604 entry $top.name -width 40
8605 grid $top.nlab $top.name -sticky w
8606 frame $top.buts
8607 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8608 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8609 bind $top <Key-Return> [list mkbrgo $top]
8610 bind $top <Key-Escape> "catch {destroy $top}"
8611 grid $top.buts.go $top.buts.can
8612 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8613 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8614 grid $top.buts - -pady 10 -sticky ew
8615 focus $top.name
8618 proc mkbrgo {top} {
8619 global headids idheads
8621 set name [$top.name get]
8622 set id [$top.sha1 get]
8623 set cmdargs {}
8624 set old_id {}
8625 if {$name eq {}} {
8626 error_popup [mc "Please specify a name for the new branch"] $top
8627 return
8629 if {[info exists headids($name)]} {
8630 if {![confirm_popup [mc \
8631 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8632 return
8634 set old_id $headids($name)
8635 lappend cmdargs -f
8637 catch {destroy $top}
8638 lappend cmdargs $name $id
8639 nowbusy newbranch
8640 update
8641 if {[catch {
8642 eval exec git branch $cmdargs
8643 } err]} {
8644 notbusy newbranch
8645 error_popup $err
8646 } else {
8647 notbusy newbranch
8648 if {$old_id ne {}} {
8649 movehead $id $name
8650 movedhead $id $name
8651 redrawtags $old_id
8652 redrawtags $id
8653 } else {
8654 set headids($name) $id
8655 lappend idheads($id) $name
8656 addedhead $id $name
8657 redrawtags $id
8659 dispneartags 0
8660 run refill_reflist
8664 proc exec_citool {tool_args {baseid {}}} {
8665 global commitinfo env
8667 set save_env [array get env GIT_AUTHOR_*]
8669 if {$baseid ne {}} {
8670 if {![info exists commitinfo($baseid)]} {
8671 getcommit $baseid
8673 set author [lindex $commitinfo($baseid) 1]
8674 set date [lindex $commitinfo($baseid) 2]
8675 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8676 $author author name email]
8677 && $date ne {}} {
8678 set env(GIT_AUTHOR_NAME) $name
8679 set env(GIT_AUTHOR_EMAIL) $email
8680 set env(GIT_AUTHOR_DATE) $date
8684 eval exec git citool $tool_args &
8686 array unset env GIT_AUTHOR_*
8687 array set env $save_env
8690 proc cherrypick {} {
8691 global rowmenuid curview
8692 global mainhead mainheadid
8694 set oldhead [exec git rev-parse HEAD]
8695 set dheads [descheads $rowmenuid]
8696 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8697 set ok [confirm_popup [mc "Commit %s is already\
8698 included in branch %s -- really re-apply it?" \
8699 [string range $rowmenuid 0 7] $mainhead]]
8700 if {!$ok} return
8702 nowbusy cherrypick [mc "Cherry-picking"]
8703 update
8704 # Unfortunately git-cherry-pick writes stuff to stderr even when
8705 # no error occurs, and exec takes that as an indication of error...
8706 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8707 notbusy cherrypick
8708 if {[regexp -line \
8709 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8710 $err msg fname]} {
8711 error_popup [mc "Cherry-pick failed because of local changes\
8712 to file '%s'.\nPlease commit, reset or stash\
8713 your changes and try again." $fname]
8714 } elseif {[regexp -line \
8715 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8716 $err]} {
8717 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8718 conflict.\nDo you wish to run git citool to\
8719 resolve it?"]]} {
8720 # Force citool to read MERGE_MSG
8721 file delete [file join [gitdir] "GITGUI_MSG"]
8722 exec_citool {} $rowmenuid
8724 } else {
8725 error_popup $err
8727 run updatecommits
8728 return
8730 set newhead [exec git rev-parse HEAD]
8731 if {$newhead eq $oldhead} {
8732 notbusy cherrypick
8733 error_popup [mc "No changes committed"]
8734 return
8736 addnewchild $newhead $oldhead
8737 if {[commitinview $oldhead $curview]} {
8738 # XXX this isn't right if we have a path limit...
8739 insertrow $newhead $oldhead $curview
8740 if {$mainhead ne {}} {
8741 movehead $newhead $mainhead
8742 movedhead $newhead $mainhead
8744 set mainheadid $newhead
8745 redrawtags $oldhead
8746 redrawtags $newhead
8747 selbyid $newhead
8749 notbusy cherrypick
8752 proc resethead {} {
8753 global mainhead rowmenuid confirm_ok resettype
8755 set confirm_ok 0
8756 set w ".confirmreset"
8757 toplevel $w
8758 make_transient $w .
8759 wm title $w [mc "Confirm reset"]
8760 message $w.m -text \
8761 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8762 -justify center -aspect 1000
8763 pack $w.m -side top -fill x -padx 20 -pady 20
8764 frame $w.f -relief sunken -border 2
8765 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8766 grid $w.f.rt -sticky w
8767 set resettype mixed
8768 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8769 -text [mc "Soft: Leave working tree and index untouched"]
8770 grid $w.f.soft -sticky w
8771 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8772 -text [mc "Mixed: Leave working tree untouched, reset index"]
8773 grid $w.f.mixed -sticky w
8774 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8775 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8776 grid $w.f.hard -sticky w
8777 pack $w.f -side top -fill x
8778 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8779 pack $w.ok -side left -fill x -padx 20 -pady 20
8780 button $w.cancel -text [mc Cancel] -command "destroy $w"
8781 bind $w <Key-Escape> [list destroy $w]
8782 pack $w.cancel -side right -fill x -padx 20 -pady 20
8783 bind $w <Visibility> "grab $w; focus $w"
8784 tkwait window $w
8785 if {!$confirm_ok} return
8786 if {[catch {set fd [open \
8787 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8788 error_popup $err
8789 } else {
8790 dohidelocalchanges
8791 filerun $fd [list readresetstat $fd]
8792 nowbusy reset [mc "Resetting"]
8793 selbyid $rowmenuid
8797 proc readresetstat {fd} {
8798 global mainhead mainheadid showlocalchanges rprogcoord
8800 if {[gets $fd line] >= 0} {
8801 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8802 set rprogcoord [expr {1.0 * $m / $n}]
8803 adjustprogress
8805 return 1
8807 set rprogcoord 0
8808 adjustprogress
8809 notbusy reset
8810 if {[catch {close $fd} err]} {
8811 error_popup $err
8813 set oldhead $mainheadid
8814 set newhead [exec git rev-parse HEAD]
8815 if {$newhead ne $oldhead} {
8816 movehead $newhead $mainhead
8817 movedhead $newhead $mainhead
8818 set mainheadid $newhead
8819 redrawtags $oldhead
8820 redrawtags $newhead
8822 if {$showlocalchanges} {
8823 doshowlocalchanges
8825 return 0
8828 # context menu for a head
8829 proc headmenu {x y id head} {
8830 global headmenuid headmenuhead headctxmenu mainhead
8832 stopfinding
8833 set headmenuid $id
8834 set headmenuhead $head
8835 set state normal
8836 if {$head eq $mainhead} {
8837 set state disabled
8839 $headctxmenu entryconfigure 0 -state $state
8840 $headctxmenu entryconfigure 1 -state $state
8841 tk_popup $headctxmenu $x $y
8844 proc cobranch {} {
8845 global headmenuid headmenuhead headids
8846 global showlocalchanges
8848 # check the tree is clean first??
8849 nowbusy checkout [mc "Checking out"]
8850 update
8851 dohidelocalchanges
8852 if {[catch {
8853 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8854 } err]} {
8855 notbusy checkout
8856 error_popup $err
8857 if {$showlocalchanges} {
8858 dodiffindex
8860 } else {
8861 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8865 proc readcheckoutstat {fd newhead newheadid} {
8866 global mainhead mainheadid headids showlocalchanges progresscoords
8867 global viewmainheadid curview
8869 if {[gets $fd line] >= 0} {
8870 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8871 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8872 adjustprogress
8874 return 1
8876 set progresscoords {0 0}
8877 adjustprogress
8878 notbusy checkout
8879 if {[catch {close $fd} err]} {
8880 error_popup $err
8882 set oldmainid $mainheadid
8883 set mainhead $newhead
8884 set mainheadid $newheadid
8885 set viewmainheadid($curview) $newheadid
8886 redrawtags $oldmainid
8887 redrawtags $newheadid
8888 selbyid $newheadid
8889 if {$showlocalchanges} {
8890 dodiffindex
8894 proc rmbranch {} {
8895 global headmenuid headmenuhead mainhead
8896 global idheads
8898 set head $headmenuhead
8899 set id $headmenuid
8900 # this check shouldn't be needed any more...
8901 if {$head eq $mainhead} {
8902 error_popup [mc "Cannot delete the currently checked-out branch"]
8903 return
8905 set dheads [descheads $id]
8906 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8907 # the stuff on this branch isn't on any other branch
8908 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8909 branch.\nReally delete branch %s?" $head $head]]} return
8911 nowbusy rmbranch
8912 update
8913 if {[catch {exec git branch -D $head} err]} {
8914 notbusy rmbranch
8915 error_popup $err
8916 return
8918 removehead $id $head
8919 removedhead $id $head
8920 redrawtags $id
8921 notbusy rmbranch
8922 dispneartags 0
8923 run refill_reflist
8926 # Display a list of tags and heads
8927 proc showrefs {} {
8928 global showrefstop bgcolor fgcolor selectbgcolor
8929 global bglist fglist reflistfilter reflist maincursor
8931 set top .showrefs
8932 set showrefstop $top
8933 if {[winfo exists $top]} {
8934 raise $top
8935 refill_reflist
8936 return
8938 toplevel $top
8939 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8940 make_transient $top .
8941 text $top.list -background $bgcolor -foreground $fgcolor \
8942 -selectbackground $selectbgcolor -font mainfont \
8943 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8944 -width 30 -height 20 -cursor $maincursor \
8945 -spacing1 1 -spacing3 1 -state disabled
8946 $top.list tag configure highlight -background $selectbgcolor
8947 lappend bglist $top.list
8948 lappend fglist $top.list
8949 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8950 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8951 grid $top.list $top.ysb -sticky nsew
8952 grid $top.xsb x -sticky ew
8953 frame $top.f
8954 label $top.f.l -text "[mc "Filter"]: "
8955 entry $top.f.e -width 20 -textvariable reflistfilter
8956 set reflistfilter "*"
8957 trace add variable reflistfilter write reflistfilter_change
8958 pack $top.f.e -side right -fill x -expand 1
8959 pack $top.f.l -side left
8960 grid $top.f - -sticky ew -pady 2
8961 button $top.close -command [list destroy $top] -text [mc "Close"]
8962 bind $top <Key-Escape> [list destroy $top]
8963 grid $top.close -
8964 grid columnconfigure $top 0 -weight 1
8965 grid rowconfigure $top 0 -weight 1
8966 bind $top.list <1> {break}
8967 bind $top.list <B1-Motion> {break}
8968 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8969 set reflist {}
8970 refill_reflist
8973 proc sel_reflist {w x y} {
8974 global showrefstop reflist headids tagids otherrefids
8976 if {![winfo exists $showrefstop]} return
8977 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8978 set ref [lindex $reflist [expr {$l-1}]]
8979 set n [lindex $ref 0]
8980 switch -- [lindex $ref 1] {
8981 "H" {selbyid $headids($n)}
8982 "T" {selbyid $tagids($n)}
8983 "o" {selbyid $otherrefids($n)}
8985 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8988 proc unsel_reflist {} {
8989 global showrefstop
8991 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8992 $showrefstop.list tag remove highlight 0.0 end
8995 proc reflistfilter_change {n1 n2 op} {
8996 global reflistfilter
8998 after cancel refill_reflist
8999 after 200 refill_reflist
9002 proc refill_reflist {} {
9003 global reflist reflistfilter showrefstop headids tagids otherrefids
9004 global curview
9006 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9007 set refs {}
9008 foreach n [array names headids] {
9009 if {[string match $reflistfilter $n]} {
9010 if {[commitinview $headids($n) $curview]} {
9011 lappend refs [list $n H]
9012 } else {
9013 interestedin $headids($n) {run refill_reflist}
9017 foreach n [array names tagids] {
9018 if {[string match $reflistfilter $n]} {
9019 if {[commitinview $tagids($n) $curview]} {
9020 lappend refs [list $n T]
9021 } else {
9022 interestedin $tagids($n) {run refill_reflist}
9026 foreach n [array names otherrefids] {
9027 if {[string match $reflistfilter $n]} {
9028 if {[commitinview $otherrefids($n) $curview]} {
9029 lappend refs [list $n o]
9030 } else {
9031 interestedin $otherrefids($n) {run refill_reflist}
9035 set refs [lsort -index 0 $refs]
9036 if {$refs eq $reflist} return
9038 # Update the contents of $showrefstop.list according to the
9039 # differences between $reflist (old) and $refs (new)
9040 $showrefstop.list conf -state normal
9041 $showrefstop.list insert end "\n"
9042 set i 0
9043 set j 0
9044 while {$i < [llength $reflist] || $j < [llength $refs]} {
9045 if {$i < [llength $reflist]} {
9046 if {$j < [llength $refs]} {
9047 set cmp [string compare [lindex $reflist $i 0] \
9048 [lindex $refs $j 0]]
9049 if {$cmp == 0} {
9050 set cmp [string compare [lindex $reflist $i 1] \
9051 [lindex $refs $j 1]]
9053 } else {
9054 set cmp -1
9056 } else {
9057 set cmp 1
9059 switch -- $cmp {
9060 -1 {
9061 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9062 incr i
9065 incr i
9066 incr j
9069 set l [expr {$j + 1}]
9070 $showrefstop.list image create $l.0 -align baseline \
9071 -image reficon-[lindex $refs $j 1] -padx 2
9072 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9073 incr j
9077 set reflist $refs
9078 # delete last newline
9079 $showrefstop.list delete end-2c end-1c
9080 $showrefstop.list conf -state disabled
9083 # Stuff for finding nearby tags
9084 proc getallcommits {} {
9085 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9086 global idheads idtags idotherrefs allparents tagobjid
9088 if {![info exists allcommits]} {
9089 set nextarc 0
9090 set allcommits 0
9091 set seeds {}
9092 set allcwait 0
9093 set cachedarcs 0
9094 set allccache [file join [gitdir] "gitk.cache"]
9095 if {![catch {
9096 set f [open $allccache r]
9097 set allcwait 1
9098 getcache $f
9099 }]} return
9102 if {$allcwait} {
9103 return
9105 set cmd [list | git rev-list --parents]
9106 set allcupdate [expr {$seeds ne {}}]
9107 if {!$allcupdate} {
9108 set ids "--all"
9109 } else {
9110 set refs [concat [array names idheads] [array names idtags] \
9111 [array names idotherrefs]]
9112 set ids {}
9113 set tagobjs {}
9114 foreach name [array names tagobjid] {
9115 lappend tagobjs $tagobjid($name)
9117 foreach id [lsort -unique $refs] {
9118 if {![info exists allparents($id)] &&
9119 [lsearch -exact $tagobjs $id] < 0} {
9120 lappend ids $id
9123 if {$ids ne {}} {
9124 foreach id $seeds {
9125 lappend ids "^$id"
9129 if {$ids ne {}} {
9130 set fd [open [concat $cmd $ids] r]
9131 fconfigure $fd -blocking 0
9132 incr allcommits
9133 nowbusy allcommits
9134 filerun $fd [list getallclines $fd]
9135 } else {
9136 dispneartags 0
9140 # Since most commits have 1 parent and 1 child, we group strings of
9141 # such commits into "arcs" joining branch/merge points (BMPs), which
9142 # are commits that either don't have 1 parent or don't have 1 child.
9144 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9145 # arcout(id) - outgoing arcs for BMP
9146 # arcids(a) - list of IDs on arc including end but not start
9147 # arcstart(a) - BMP ID at start of arc
9148 # arcend(a) - BMP ID at end of arc
9149 # growing(a) - arc a is still growing
9150 # arctags(a) - IDs out of arcids (excluding end) that have tags
9151 # archeads(a) - IDs out of arcids (excluding end) that have heads
9152 # The start of an arc is at the descendent end, so "incoming" means
9153 # coming from descendents, and "outgoing" means going towards ancestors.
9155 proc getallclines {fd} {
9156 global allparents allchildren idtags idheads nextarc
9157 global arcnos arcids arctags arcout arcend arcstart archeads growing
9158 global seeds allcommits cachedarcs allcupdate
9160 set nid 0
9161 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9162 set id [lindex $line 0]
9163 if {[info exists allparents($id)]} {
9164 # seen it already
9165 continue
9167 set cachedarcs 0
9168 set olds [lrange $line 1 end]
9169 set allparents($id) $olds
9170 if {![info exists allchildren($id)]} {
9171 set allchildren($id) {}
9172 set arcnos($id) {}
9173 lappend seeds $id
9174 } else {
9175 set a $arcnos($id)
9176 if {[llength $olds] == 1 && [llength $a] == 1} {
9177 lappend arcids($a) $id
9178 if {[info exists idtags($id)]} {
9179 lappend arctags($a) $id
9181 if {[info exists idheads($id)]} {
9182 lappend archeads($a) $id
9184 if {[info exists allparents($olds)]} {
9185 # seen parent already
9186 if {![info exists arcout($olds)]} {
9187 splitarc $olds
9189 lappend arcids($a) $olds
9190 set arcend($a) $olds
9191 unset growing($a)
9193 lappend allchildren($olds) $id
9194 lappend arcnos($olds) $a
9195 continue
9198 foreach a $arcnos($id) {
9199 lappend arcids($a) $id
9200 set arcend($a) $id
9201 unset growing($a)
9204 set ao {}
9205 foreach p $olds {
9206 lappend allchildren($p) $id
9207 set a [incr nextarc]
9208 set arcstart($a) $id
9209 set archeads($a) {}
9210 set arctags($a) {}
9211 set archeads($a) {}
9212 set arcids($a) {}
9213 lappend ao $a
9214 set growing($a) 1
9215 if {[info exists allparents($p)]} {
9216 # seen it already, may need to make a new branch
9217 if {![info exists arcout($p)]} {
9218 splitarc $p
9220 lappend arcids($a) $p
9221 set arcend($a) $p
9222 unset growing($a)
9224 lappend arcnos($p) $a
9226 set arcout($id) $ao
9228 if {$nid > 0} {
9229 global cached_dheads cached_dtags cached_atags
9230 catch {unset cached_dheads}
9231 catch {unset cached_dtags}
9232 catch {unset cached_atags}
9234 if {![eof $fd]} {
9235 return [expr {$nid >= 1000? 2: 1}]
9237 set cacheok 1
9238 if {[catch {
9239 fconfigure $fd -blocking 1
9240 close $fd
9241 } err]} {
9242 # got an error reading the list of commits
9243 # if we were updating, try rereading the whole thing again
9244 if {$allcupdate} {
9245 incr allcommits -1
9246 dropcache $err
9247 return
9249 error_popup "[mc "Error reading commit topology information;\
9250 branch and preceding/following tag information\
9251 will be incomplete."]\n($err)"
9252 set cacheok 0
9254 if {[incr allcommits -1] == 0} {
9255 notbusy allcommits
9256 if {$cacheok} {
9257 run savecache
9260 dispneartags 0
9261 return 0
9264 proc recalcarc {a} {
9265 global arctags archeads arcids idtags idheads
9267 set at {}
9268 set ah {}
9269 foreach id [lrange $arcids($a) 0 end-1] {
9270 if {[info exists idtags($id)]} {
9271 lappend at $id
9273 if {[info exists idheads($id)]} {
9274 lappend ah $id
9277 set arctags($a) $at
9278 set archeads($a) $ah
9281 proc splitarc {p} {
9282 global arcnos arcids nextarc arctags archeads idtags idheads
9283 global arcstart arcend arcout allparents growing
9285 set a $arcnos($p)
9286 if {[llength $a] != 1} {
9287 puts "oops splitarc called but [llength $a] arcs already"
9288 return
9290 set a [lindex $a 0]
9291 set i [lsearch -exact $arcids($a) $p]
9292 if {$i < 0} {
9293 puts "oops splitarc $p not in arc $a"
9294 return
9296 set na [incr nextarc]
9297 if {[info exists arcend($a)]} {
9298 set arcend($na) $arcend($a)
9299 } else {
9300 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9301 set j [lsearch -exact $arcnos($l) $a]
9302 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9304 set tail [lrange $arcids($a) [expr {$i+1}] end]
9305 set arcids($a) [lrange $arcids($a) 0 $i]
9306 set arcend($a) $p
9307 set arcstart($na) $p
9308 set arcout($p) $na
9309 set arcids($na) $tail
9310 if {[info exists growing($a)]} {
9311 set growing($na) 1
9312 unset growing($a)
9315 foreach id $tail {
9316 if {[llength $arcnos($id)] == 1} {
9317 set arcnos($id) $na
9318 } else {
9319 set j [lsearch -exact $arcnos($id) $a]
9320 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9324 # reconstruct tags and heads lists
9325 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9326 recalcarc $a
9327 recalcarc $na
9328 } else {
9329 set arctags($na) {}
9330 set archeads($na) {}
9334 # Update things for a new commit added that is a child of one
9335 # existing commit. Used when cherry-picking.
9336 proc addnewchild {id p} {
9337 global allparents allchildren idtags nextarc
9338 global arcnos arcids arctags arcout arcend arcstart archeads growing
9339 global seeds allcommits
9341 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9342 set allparents($id) [list $p]
9343 set allchildren($id) {}
9344 set arcnos($id) {}
9345 lappend seeds $id
9346 lappend allchildren($p) $id
9347 set a [incr nextarc]
9348 set arcstart($a) $id
9349 set archeads($a) {}
9350 set arctags($a) {}
9351 set arcids($a) [list $p]
9352 set arcend($a) $p
9353 if {![info exists arcout($p)]} {
9354 splitarc $p
9356 lappend arcnos($p) $a
9357 set arcout($id) [list $a]
9360 # This implements a cache for the topology information.
9361 # The cache saves, for each arc, the start and end of the arc,
9362 # the ids on the arc, and the outgoing arcs from the end.
9363 proc readcache {f} {
9364 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9365 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9366 global allcwait
9368 set a $nextarc
9369 set lim $cachedarcs
9370 if {$lim - $a > 500} {
9371 set lim [expr {$a + 500}]
9373 if {[catch {
9374 if {$a == $lim} {
9375 # finish reading the cache and setting up arctags, etc.
9376 set line [gets $f]
9377 if {$line ne "1"} {error "bad final version"}
9378 close $f
9379 foreach id [array names idtags] {
9380 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9381 [llength $allparents($id)] == 1} {
9382 set a [lindex $arcnos($id) 0]
9383 if {$arctags($a) eq {}} {
9384 recalcarc $a
9388 foreach id [array names idheads] {
9389 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9390 [llength $allparents($id)] == 1} {
9391 set a [lindex $arcnos($id) 0]
9392 if {$archeads($a) eq {}} {
9393 recalcarc $a
9397 foreach id [lsort -unique $possible_seeds] {
9398 if {$arcnos($id) eq {}} {
9399 lappend seeds $id
9402 set allcwait 0
9403 } else {
9404 while {[incr a] <= $lim} {
9405 set line [gets $f]
9406 if {[llength $line] != 3} {error "bad line"}
9407 set s [lindex $line 0]
9408 set arcstart($a) $s
9409 lappend arcout($s) $a
9410 if {![info exists arcnos($s)]} {
9411 lappend possible_seeds $s
9412 set arcnos($s) {}
9414 set e [lindex $line 1]
9415 if {$e eq {}} {
9416 set growing($a) 1
9417 } else {
9418 set arcend($a) $e
9419 if {![info exists arcout($e)]} {
9420 set arcout($e) {}
9423 set arcids($a) [lindex $line 2]
9424 foreach id $arcids($a) {
9425 lappend allparents($s) $id
9426 set s $id
9427 lappend arcnos($id) $a
9429 if {![info exists allparents($s)]} {
9430 set allparents($s) {}
9432 set arctags($a) {}
9433 set archeads($a) {}
9435 set nextarc [expr {$a - 1}]
9437 } err]} {
9438 dropcache $err
9439 return 0
9441 if {!$allcwait} {
9442 getallcommits
9444 return $allcwait
9447 proc getcache {f} {
9448 global nextarc cachedarcs possible_seeds
9450 if {[catch {
9451 set line [gets $f]
9452 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9453 # make sure it's an integer
9454 set cachedarcs [expr {int([lindex $line 1])}]
9455 if {$cachedarcs < 0} {error "bad number of arcs"}
9456 set nextarc 0
9457 set possible_seeds {}
9458 run readcache $f
9459 } err]} {
9460 dropcache $err
9462 return 0
9465 proc dropcache {err} {
9466 global allcwait nextarc cachedarcs seeds
9468 #puts "dropping cache ($err)"
9469 foreach v {arcnos arcout arcids arcstart arcend growing \
9470 arctags archeads allparents allchildren} {
9471 global $v
9472 catch {unset $v}
9474 set allcwait 0
9475 set nextarc 0
9476 set cachedarcs 0
9477 set seeds {}
9478 getallcommits
9481 proc writecache {f} {
9482 global cachearc cachedarcs allccache
9483 global arcstart arcend arcnos arcids arcout
9485 set a $cachearc
9486 set lim $cachedarcs
9487 if {$lim - $a > 1000} {
9488 set lim [expr {$a + 1000}]
9490 if {[catch {
9491 while {[incr a] <= $lim} {
9492 if {[info exists arcend($a)]} {
9493 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9494 } else {
9495 puts $f [list $arcstart($a) {} $arcids($a)]
9498 } err]} {
9499 catch {close $f}
9500 catch {file delete $allccache}
9501 #puts "writing cache failed ($err)"
9502 return 0
9504 set cachearc [expr {$a - 1}]
9505 if {$a > $cachedarcs} {
9506 puts $f "1"
9507 close $f
9508 return 0
9510 return 1
9513 proc savecache {} {
9514 global nextarc cachedarcs cachearc allccache
9516 if {$nextarc == $cachedarcs} return
9517 set cachearc 0
9518 set cachedarcs $nextarc
9519 catch {
9520 set f [open $allccache w]
9521 puts $f [list 1 $cachedarcs]
9522 run writecache $f
9526 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9527 # or 0 if neither is true.
9528 proc anc_or_desc {a b} {
9529 global arcout arcstart arcend arcnos cached_isanc
9531 if {$arcnos($a) eq $arcnos($b)} {
9532 # Both are on the same arc(s); either both are the same BMP,
9533 # or if one is not a BMP, the other is also not a BMP or is
9534 # the BMP at end of the arc (and it only has 1 incoming arc).
9535 # Or both can be BMPs with no incoming arcs.
9536 if {$a eq $b || $arcnos($a) eq {}} {
9537 return 0
9539 # assert {[llength $arcnos($a)] == 1}
9540 set arc [lindex $arcnos($a) 0]
9541 set i [lsearch -exact $arcids($arc) $a]
9542 set j [lsearch -exact $arcids($arc) $b]
9543 if {$i < 0 || $i > $j} {
9544 return 1
9545 } else {
9546 return -1
9550 if {![info exists arcout($a)]} {
9551 set arc [lindex $arcnos($a) 0]
9552 if {[info exists arcend($arc)]} {
9553 set aend $arcend($arc)
9554 } else {
9555 set aend {}
9557 set a $arcstart($arc)
9558 } else {
9559 set aend $a
9561 if {![info exists arcout($b)]} {
9562 set arc [lindex $arcnos($b) 0]
9563 if {[info exists arcend($arc)]} {
9564 set bend $arcend($arc)
9565 } else {
9566 set bend {}
9568 set b $arcstart($arc)
9569 } else {
9570 set bend $b
9572 if {$a eq $bend} {
9573 return 1
9575 if {$b eq $aend} {
9576 return -1
9578 if {[info exists cached_isanc($a,$bend)]} {
9579 if {$cached_isanc($a,$bend)} {
9580 return 1
9583 if {[info exists cached_isanc($b,$aend)]} {
9584 if {$cached_isanc($b,$aend)} {
9585 return -1
9587 if {[info exists cached_isanc($a,$bend)]} {
9588 return 0
9592 set todo [list $a $b]
9593 set anc($a) a
9594 set anc($b) b
9595 for {set i 0} {$i < [llength $todo]} {incr i} {
9596 set x [lindex $todo $i]
9597 if {$anc($x) eq {}} {
9598 continue
9600 foreach arc $arcnos($x) {
9601 set xd $arcstart($arc)
9602 if {$xd eq $bend} {
9603 set cached_isanc($a,$bend) 1
9604 set cached_isanc($b,$aend) 0
9605 return 1
9606 } elseif {$xd eq $aend} {
9607 set cached_isanc($b,$aend) 1
9608 set cached_isanc($a,$bend) 0
9609 return -1
9611 if {![info exists anc($xd)]} {
9612 set anc($xd) $anc($x)
9613 lappend todo $xd
9614 } elseif {$anc($xd) ne $anc($x)} {
9615 set anc($xd) {}
9619 set cached_isanc($a,$bend) 0
9620 set cached_isanc($b,$aend) 0
9621 return 0
9624 # This identifies whether $desc has an ancestor that is
9625 # a growing tip of the graph and which is not an ancestor of $anc
9626 # and returns 0 if so and 1 if not.
9627 # If we subsequently discover a tag on such a growing tip, and that
9628 # turns out to be a descendent of $anc (which it could, since we
9629 # don't necessarily see children before parents), then $desc
9630 # isn't a good choice to display as a descendent tag of
9631 # $anc (since it is the descendent of another tag which is
9632 # a descendent of $anc). Similarly, $anc isn't a good choice to
9633 # display as a ancestor tag of $desc.
9635 proc is_certain {desc anc} {
9636 global arcnos arcout arcstart arcend growing problems
9638 set certain {}
9639 if {[llength $arcnos($anc)] == 1} {
9640 # tags on the same arc are certain
9641 if {$arcnos($desc) eq $arcnos($anc)} {
9642 return 1
9644 if {![info exists arcout($anc)]} {
9645 # if $anc is partway along an arc, use the start of the arc instead
9646 set a [lindex $arcnos($anc) 0]
9647 set anc $arcstart($a)
9650 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9651 set x $desc
9652 } else {
9653 set a [lindex $arcnos($desc) 0]
9654 set x $arcend($a)
9656 if {$x == $anc} {
9657 return 1
9659 set anclist [list $x]
9660 set dl($x) 1
9661 set nnh 1
9662 set ngrowanc 0
9663 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9664 set x [lindex $anclist $i]
9665 if {$dl($x)} {
9666 incr nnh -1
9668 set done($x) 1
9669 foreach a $arcout($x) {
9670 if {[info exists growing($a)]} {
9671 if {![info exists growanc($x)] && $dl($x)} {
9672 set growanc($x) 1
9673 incr ngrowanc
9675 } else {
9676 set y $arcend($a)
9677 if {[info exists dl($y)]} {
9678 if {$dl($y)} {
9679 if {!$dl($x)} {
9680 set dl($y) 0
9681 if {![info exists done($y)]} {
9682 incr nnh -1
9684 if {[info exists growanc($x)]} {
9685 incr ngrowanc -1
9687 set xl [list $y]
9688 for {set k 0} {$k < [llength $xl]} {incr k} {
9689 set z [lindex $xl $k]
9690 foreach c $arcout($z) {
9691 if {[info exists arcend($c)]} {
9692 set v $arcend($c)
9693 if {[info exists dl($v)] && $dl($v)} {
9694 set dl($v) 0
9695 if {![info exists done($v)]} {
9696 incr nnh -1
9698 if {[info exists growanc($v)]} {
9699 incr ngrowanc -1
9701 lappend xl $v
9708 } elseif {$y eq $anc || !$dl($x)} {
9709 set dl($y) 0
9710 lappend anclist $y
9711 } else {
9712 set dl($y) 1
9713 lappend anclist $y
9714 incr nnh
9719 foreach x [array names growanc] {
9720 if {$dl($x)} {
9721 return 0
9723 return 0
9725 return 1
9728 proc validate_arctags {a} {
9729 global arctags idtags
9731 set i -1
9732 set na $arctags($a)
9733 foreach id $arctags($a) {
9734 incr i
9735 if {![info exists idtags($id)]} {
9736 set na [lreplace $na $i $i]
9737 incr i -1
9740 set arctags($a) $na
9743 proc validate_archeads {a} {
9744 global archeads idheads
9746 set i -1
9747 set na $archeads($a)
9748 foreach id $archeads($a) {
9749 incr i
9750 if {![info exists idheads($id)]} {
9751 set na [lreplace $na $i $i]
9752 incr i -1
9755 set archeads($a) $na
9758 # Return the list of IDs that have tags that are descendents of id,
9759 # ignoring IDs that are descendents of IDs already reported.
9760 proc desctags {id} {
9761 global arcnos arcstart arcids arctags idtags allparents
9762 global growing cached_dtags
9764 if {![info exists allparents($id)]} {
9765 return {}
9767 set t1 [clock clicks -milliseconds]
9768 set argid $id
9769 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9770 # part-way along an arc; check that arc first
9771 set a [lindex $arcnos($id) 0]
9772 if {$arctags($a) ne {}} {
9773 validate_arctags $a
9774 set i [lsearch -exact $arcids($a) $id]
9775 set tid {}
9776 foreach t $arctags($a) {
9777 set j [lsearch -exact $arcids($a) $t]
9778 if {$j >= $i} break
9779 set tid $t
9781 if {$tid ne {}} {
9782 return $tid
9785 set id $arcstart($a)
9786 if {[info exists idtags($id)]} {
9787 return $id
9790 if {[info exists cached_dtags($id)]} {
9791 return $cached_dtags($id)
9794 set origid $id
9795 set todo [list $id]
9796 set queued($id) 1
9797 set nc 1
9798 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9799 set id [lindex $todo $i]
9800 set done($id) 1
9801 set ta [info exists hastaggedancestor($id)]
9802 if {!$ta} {
9803 incr nc -1
9805 # ignore tags on starting node
9806 if {!$ta && $i > 0} {
9807 if {[info exists idtags($id)]} {
9808 set tagloc($id) $id
9809 set ta 1
9810 } elseif {[info exists cached_dtags($id)]} {
9811 set tagloc($id) $cached_dtags($id)
9812 set ta 1
9815 foreach a $arcnos($id) {
9816 set d $arcstart($a)
9817 if {!$ta && $arctags($a) ne {}} {
9818 validate_arctags $a
9819 if {$arctags($a) ne {}} {
9820 lappend tagloc($id) [lindex $arctags($a) end]
9823 if {$ta || $arctags($a) ne {}} {
9824 set tomark [list $d]
9825 for {set j 0} {$j < [llength $tomark]} {incr j} {
9826 set dd [lindex $tomark $j]
9827 if {![info exists hastaggedancestor($dd)]} {
9828 if {[info exists done($dd)]} {
9829 foreach b $arcnos($dd) {
9830 lappend tomark $arcstart($b)
9832 if {[info exists tagloc($dd)]} {
9833 unset tagloc($dd)
9835 } elseif {[info exists queued($dd)]} {
9836 incr nc -1
9838 set hastaggedancestor($dd) 1
9842 if {![info exists queued($d)]} {
9843 lappend todo $d
9844 set queued($d) 1
9845 if {![info exists hastaggedancestor($d)]} {
9846 incr nc
9851 set tags {}
9852 foreach id [array names tagloc] {
9853 if {![info exists hastaggedancestor($id)]} {
9854 foreach t $tagloc($id) {
9855 if {[lsearch -exact $tags $t] < 0} {
9856 lappend tags $t
9861 set t2 [clock clicks -milliseconds]
9862 set loopix $i
9864 # remove tags that are descendents of other tags
9865 for {set i 0} {$i < [llength $tags]} {incr i} {
9866 set a [lindex $tags $i]
9867 for {set j 0} {$j < $i} {incr j} {
9868 set b [lindex $tags $j]
9869 set r [anc_or_desc $a $b]
9870 if {$r == 1} {
9871 set tags [lreplace $tags $j $j]
9872 incr j -1
9873 incr i -1
9874 } elseif {$r == -1} {
9875 set tags [lreplace $tags $i $i]
9876 incr i -1
9877 break
9882 if {[array names growing] ne {}} {
9883 # graph isn't finished, need to check if any tag could get
9884 # eclipsed by another tag coming later. Simply ignore any
9885 # tags that could later get eclipsed.
9886 set ctags {}
9887 foreach t $tags {
9888 if {[is_certain $t $origid]} {
9889 lappend ctags $t
9892 if {$tags eq $ctags} {
9893 set cached_dtags($origid) $tags
9894 } else {
9895 set tags $ctags
9897 } else {
9898 set cached_dtags($origid) $tags
9900 set t3 [clock clicks -milliseconds]
9901 if {0 && $t3 - $t1 >= 100} {
9902 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9903 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9905 return $tags
9908 proc anctags {id} {
9909 global arcnos arcids arcout arcend arctags idtags allparents
9910 global growing cached_atags
9912 if {![info exists allparents($id)]} {
9913 return {}
9915 set t1 [clock clicks -milliseconds]
9916 set argid $id
9917 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9918 # part-way along an arc; check that arc first
9919 set a [lindex $arcnos($id) 0]
9920 if {$arctags($a) ne {}} {
9921 validate_arctags $a
9922 set i [lsearch -exact $arcids($a) $id]
9923 foreach t $arctags($a) {
9924 set j [lsearch -exact $arcids($a) $t]
9925 if {$j > $i} {
9926 return $t
9930 if {![info exists arcend($a)]} {
9931 return {}
9933 set id $arcend($a)
9934 if {[info exists idtags($id)]} {
9935 return $id
9938 if {[info exists cached_atags($id)]} {
9939 return $cached_atags($id)
9942 set origid $id
9943 set todo [list $id]
9944 set queued($id) 1
9945 set taglist {}
9946 set nc 1
9947 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9948 set id [lindex $todo $i]
9949 set done($id) 1
9950 set td [info exists hastaggeddescendent($id)]
9951 if {!$td} {
9952 incr nc -1
9954 # ignore tags on starting node
9955 if {!$td && $i > 0} {
9956 if {[info exists idtags($id)]} {
9957 set tagloc($id) $id
9958 set td 1
9959 } elseif {[info exists cached_atags($id)]} {
9960 set tagloc($id) $cached_atags($id)
9961 set td 1
9964 foreach a $arcout($id) {
9965 if {!$td && $arctags($a) ne {}} {
9966 validate_arctags $a
9967 if {$arctags($a) ne {}} {
9968 lappend tagloc($id) [lindex $arctags($a) 0]
9971 if {![info exists arcend($a)]} continue
9972 set d $arcend($a)
9973 if {$td || $arctags($a) ne {}} {
9974 set tomark [list $d]
9975 for {set j 0} {$j < [llength $tomark]} {incr j} {
9976 set dd [lindex $tomark $j]
9977 if {![info exists hastaggeddescendent($dd)]} {
9978 if {[info exists done($dd)]} {
9979 foreach b $arcout($dd) {
9980 if {[info exists arcend($b)]} {
9981 lappend tomark $arcend($b)
9984 if {[info exists tagloc($dd)]} {
9985 unset tagloc($dd)
9987 } elseif {[info exists queued($dd)]} {
9988 incr nc -1
9990 set hastaggeddescendent($dd) 1
9994 if {![info exists queued($d)]} {
9995 lappend todo $d
9996 set queued($d) 1
9997 if {![info exists hastaggeddescendent($d)]} {
9998 incr nc
10003 set t2 [clock clicks -milliseconds]
10004 set loopix $i
10005 set tags {}
10006 foreach id [array names tagloc] {
10007 if {![info exists hastaggeddescendent($id)]} {
10008 foreach t $tagloc($id) {
10009 if {[lsearch -exact $tags $t] < 0} {
10010 lappend tags $t
10016 # remove tags that are ancestors of other tags
10017 for {set i 0} {$i < [llength $tags]} {incr i} {
10018 set a [lindex $tags $i]
10019 for {set j 0} {$j < $i} {incr j} {
10020 set b [lindex $tags $j]
10021 set r [anc_or_desc $a $b]
10022 if {$r == -1} {
10023 set tags [lreplace $tags $j $j]
10024 incr j -1
10025 incr i -1
10026 } elseif {$r == 1} {
10027 set tags [lreplace $tags $i $i]
10028 incr i -1
10029 break
10034 if {[array names growing] ne {}} {
10035 # graph isn't finished, need to check if any tag could get
10036 # eclipsed by another tag coming later. Simply ignore any
10037 # tags that could later get eclipsed.
10038 set ctags {}
10039 foreach t $tags {
10040 if {[is_certain $origid $t]} {
10041 lappend ctags $t
10044 if {$tags eq $ctags} {
10045 set cached_atags($origid) $tags
10046 } else {
10047 set tags $ctags
10049 } else {
10050 set cached_atags($origid) $tags
10052 set t3 [clock clicks -milliseconds]
10053 if {0 && $t3 - $t1 >= 100} {
10054 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10055 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10057 return $tags
10060 # Return the list of IDs that have heads that are descendents of id,
10061 # including id itself if it has a head.
10062 proc descheads {id} {
10063 global arcnos arcstart arcids archeads idheads cached_dheads
10064 global allparents
10066 if {![info exists allparents($id)]} {
10067 return {}
10069 set aret {}
10070 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10071 # part-way along an arc; check it first
10072 set a [lindex $arcnos($id) 0]
10073 if {$archeads($a) ne {}} {
10074 validate_archeads $a
10075 set i [lsearch -exact $arcids($a) $id]
10076 foreach t $archeads($a) {
10077 set j [lsearch -exact $arcids($a) $t]
10078 if {$j > $i} break
10079 lappend aret $t
10082 set id $arcstart($a)
10084 set origid $id
10085 set todo [list $id]
10086 set seen($id) 1
10087 set ret {}
10088 for {set i 0} {$i < [llength $todo]} {incr i} {
10089 set id [lindex $todo $i]
10090 if {[info exists cached_dheads($id)]} {
10091 set ret [concat $ret $cached_dheads($id)]
10092 } else {
10093 if {[info exists idheads($id)]} {
10094 lappend ret $id
10096 foreach a $arcnos($id) {
10097 if {$archeads($a) ne {}} {
10098 validate_archeads $a
10099 if {$archeads($a) ne {}} {
10100 set ret [concat $ret $archeads($a)]
10103 set d $arcstart($a)
10104 if {![info exists seen($d)]} {
10105 lappend todo $d
10106 set seen($d) 1
10111 set ret [lsort -unique $ret]
10112 set cached_dheads($origid) $ret
10113 return [concat $ret $aret]
10116 proc addedtag {id} {
10117 global arcnos arcout cached_dtags cached_atags
10119 if {![info exists arcnos($id)]} return
10120 if {![info exists arcout($id)]} {
10121 recalcarc [lindex $arcnos($id) 0]
10123 catch {unset cached_dtags}
10124 catch {unset cached_atags}
10127 proc addedhead {hid head} {
10128 global arcnos arcout cached_dheads
10130 if {![info exists arcnos($hid)]} return
10131 if {![info exists arcout($hid)]} {
10132 recalcarc [lindex $arcnos($hid) 0]
10134 catch {unset cached_dheads}
10137 proc removedhead {hid head} {
10138 global cached_dheads
10140 catch {unset cached_dheads}
10143 proc movedhead {hid head} {
10144 global arcnos arcout cached_dheads
10146 if {![info exists arcnos($hid)]} return
10147 if {![info exists arcout($hid)]} {
10148 recalcarc [lindex $arcnos($hid) 0]
10150 catch {unset cached_dheads}
10153 proc changedrefs {} {
10154 global cached_dheads cached_dtags cached_atags
10155 global arctags archeads arcnos arcout idheads idtags
10157 foreach id [concat [array names idheads] [array names idtags]] {
10158 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10159 set a [lindex $arcnos($id) 0]
10160 if {![info exists donearc($a)]} {
10161 recalcarc $a
10162 set donearc($a) 1
10166 catch {unset cached_dtags}
10167 catch {unset cached_atags}
10168 catch {unset cached_dheads}
10171 proc rereadrefs {} {
10172 global idtags idheads idotherrefs mainheadid
10174 set refids [concat [array names idtags] \
10175 [array names idheads] [array names idotherrefs]]
10176 foreach id $refids {
10177 if {![info exists ref($id)]} {
10178 set ref($id) [listrefs $id]
10181 set oldmainhead $mainheadid
10182 readrefs
10183 changedrefs
10184 set refids [lsort -unique [concat $refids [array names idtags] \
10185 [array names idheads] [array names idotherrefs]]]
10186 foreach id $refids {
10187 set v [listrefs $id]
10188 if {![info exists ref($id)] || $ref($id) != $v} {
10189 redrawtags $id
10192 if {$oldmainhead ne $mainheadid} {
10193 redrawtags $oldmainhead
10194 redrawtags $mainheadid
10196 run refill_reflist
10199 proc listrefs {id} {
10200 global idtags idheads idotherrefs
10202 set x {}
10203 if {[info exists idtags($id)]} {
10204 set x $idtags($id)
10206 set y {}
10207 if {[info exists idheads($id)]} {
10208 set y $idheads($id)
10210 set z {}
10211 if {[info exists idotherrefs($id)]} {
10212 set z $idotherrefs($id)
10214 return [list $x $y $z]
10217 proc showtag {tag isnew} {
10218 global ctext tagcontents tagids linknum tagobjid
10220 if {$isnew} {
10221 addtohistory [list showtag $tag 0]
10223 $ctext conf -state normal
10224 clear_ctext
10225 settabs 0
10226 set linknum 0
10227 if {![info exists tagcontents($tag)]} {
10228 catch {
10229 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10232 if {[info exists tagcontents($tag)]} {
10233 set text $tagcontents($tag)
10234 } else {
10235 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10237 appendwithlinks $text {}
10238 $ctext conf -state disabled
10239 init_flist {}
10242 proc doquit {} {
10243 global stopped
10244 global gitktmpdir
10246 set stopped 100
10247 savestuff .
10248 destroy .
10250 if {[info exists gitktmpdir]} {
10251 catch {file delete -force $gitktmpdir}
10255 proc mkfontdisp {font top which} {
10256 global fontattr fontpref $font
10258 set fontpref($font) [set $font]
10259 button $top.${font}but -text $which -font optionfont \
10260 -command [list choosefont $font $which]
10261 label $top.$font -relief flat -font $font \
10262 -text $fontattr($font,family) -justify left
10263 grid x $top.${font}but $top.$font -sticky w
10266 proc choosefont {font which} {
10267 global fontparam fontlist fonttop fontattr
10268 global prefstop
10270 set fontparam(which) $which
10271 set fontparam(font) $font
10272 set fontparam(family) [font actual $font -family]
10273 set fontparam(size) $fontattr($font,size)
10274 set fontparam(weight) $fontattr($font,weight)
10275 set fontparam(slant) $fontattr($font,slant)
10276 set top .gitkfont
10277 set fonttop $top
10278 if {![winfo exists $top]} {
10279 font create sample
10280 eval font config sample [font actual $font]
10281 toplevel $top
10282 make_transient $top $prefstop
10283 wm title $top [mc "Gitk font chooser"]
10284 label $top.l -textvariable fontparam(which)
10285 pack $top.l -side top
10286 set fontlist [lsort [font families]]
10287 frame $top.f
10288 listbox $top.f.fam -listvariable fontlist \
10289 -yscrollcommand [list $top.f.sb set]
10290 bind $top.f.fam <<ListboxSelect>> selfontfam
10291 scrollbar $top.f.sb -command [list $top.f.fam yview]
10292 pack $top.f.sb -side right -fill y
10293 pack $top.f.fam -side left -fill both -expand 1
10294 pack $top.f -side top -fill both -expand 1
10295 frame $top.g
10296 spinbox $top.g.size -from 4 -to 40 -width 4 \
10297 -textvariable fontparam(size) \
10298 -validatecommand {string is integer -strict %s}
10299 checkbutton $top.g.bold -padx 5 \
10300 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10301 -variable fontparam(weight) -onvalue bold -offvalue normal
10302 checkbutton $top.g.ital -padx 5 \
10303 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10304 -variable fontparam(slant) -onvalue italic -offvalue roman
10305 pack $top.g.size $top.g.bold $top.g.ital -side left
10306 pack $top.g -side top
10307 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10308 -background white
10309 $top.c create text 100 25 -anchor center -text $which -font sample \
10310 -fill black -tags text
10311 bind $top.c <Configure> [list centertext $top.c]
10312 pack $top.c -side top -fill x
10313 frame $top.buts
10314 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10315 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10316 bind $top <Key-Return> fontok
10317 bind $top <Key-Escape> fontcan
10318 grid $top.buts.ok $top.buts.can
10319 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10320 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10321 pack $top.buts -side bottom -fill x
10322 trace add variable fontparam write chg_fontparam
10323 } else {
10324 raise $top
10325 $top.c itemconf text -text $which
10327 set i [lsearch -exact $fontlist $fontparam(family)]
10328 if {$i >= 0} {
10329 $top.f.fam selection set $i
10330 $top.f.fam see $i
10334 proc centertext {w} {
10335 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10338 proc fontok {} {
10339 global fontparam fontpref prefstop
10341 set f $fontparam(font)
10342 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10343 if {$fontparam(weight) eq "bold"} {
10344 lappend fontpref($f) "bold"
10346 if {$fontparam(slant) eq "italic"} {
10347 lappend fontpref($f) "italic"
10349 set w $prefstop.$f
10350 $w conf -text $fontparam(family) -font $fontpref($f)
10352 fontcan
10355 proc fontcan {} {
10356 global fonttop fontparam
10358 if {[info exists fonttop]} {
10359 catch {destroy $fonttop}
10360 catch {font delete sample}
10361 unset fonttop
10362 unset fontparam
10366 proc selfontfam {} {
10367 global fonttop fontparam
10369 set i [$fonttop.f.fam curselection]
10370 if {$i ne {}} {
10371 set fontparam(family) [$fonttop.f.fam get $i]
10375 proc chg_fontparam {v sub op} {
10376 global fontparam
10378 font config sample -$sub $fontparam($sub)
10381 proc doprefs {} {
10382 global maxwidth maxgraphpct
10383 global oldprefs prefstop showneartags showlocalchanges
10384 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10385 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10387 set top .gitkprefs
10388 set prefstop $top
10389 if {[winfo exists $top]} {
10390 raise $top
10391 return
10393 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10394 limitdiffs tabstop perfile_attrs} {
10395 set oldprefs($v) [set $v]
10397 toplevel $top
10398 wm title $top [mc "Gitk preferences"]
10399 make_transient $top .
10400 label $top.ldisp -text [mc "Commit list display options"]
10401 grid $top.ldisp - -sticky w -pady 10
10402 label $top.spacer -text " "
10403 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10404 -font optionfont
10405 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10406 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10407 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10408 -font optionfont
10409 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10410 grid x $top.maxpctl $top.maxpct -sticky w
10411 checkbutton $top.showlocal -text [mc "Show local changes"] \
10412 -font optionfont -variable showlocalchanges
10413 grid x $top.showlocal -sticky w
10414 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10415 -font optionfont -variable autoselect
10416 grid x $top.autoselect -sticky w
10418 label $top.ddisp -text [mc "Diff display options"]
10419 grid $top.ddisp - -sticky w -pady 10
10420 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10421 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10422 grid x $top.tabstopl $top.tabstop -sticky w
10423 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10424 -font optionfont -variable showneartags
10425 grid x $top.ntag -sticky w
10426 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10427 -font optionfont -variable limitdiffs
10428 grid x $top.ldiff -sticky w
10429 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10430 -font optionfont -variable perfile_attrs
10431 grid x $top.lattr -sticky w
10433 entry $top.extdifft -textvariable extdifftool
10434 frame $top.extdifff
10435 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10436 -padx 10
10437 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10438 -command choose_extdiff
10439 pack $top.extdifff.l $top.extdifff.b -side left
10440 grid x $top.extdifff $top.extdifft -sticky w
10442 label $top.cdisp -text [mc "Colors: press to choose"]
10443 grid $top.cdisp - -sticky w -pady 10
10444 label $top.bg -padx 40 -relief sunk -background $bgcolor
10445 button $top.bgbut -text [mc "Background"] -font optionfont \
10446 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10447 grid x $top.bgbut $top.bg -sticky w
10448 label $top.fg -padx 40 -relief sunk -background $fgcolor
10449 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10450 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10451 grid x $top.fgbut $top.fg -sticky w
10452 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10453 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10454 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10455 [list $ctext tag conf d0 -foreground]]
10456 grid x $top.diffoldbut $top.diffold -sticky w
10457 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10458 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10459 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10460 [list $ctext tag conf dresult -foreground]]
10461 grid x $top.diffnewbut $top.diffnew -sticky w
10462 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10463 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10464 -command [list choosecolor diffcolors 2 $top.hunksep \
10465 [mc "diff hunk header"] \
10466 [list $ctext tag conf hunksep -foreground]]
10467 grid x $top.hunksepbut $top.hunksep -sticky w
10468 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10469 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10470 -command [list choosecolor markbgcolor {} $top.markbgsep \
10471 [mc "marked line background"] \
10472 [list $ctext tag conf omark -background]]
10473 grid x $top.markbgbut $top.markbgsep -sticky w
10474 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10475 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10476 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10477 grid x $top.selbgbut $top.selbgsep -sticky w
10479 label $top.cfont -text [mc "Fonts: press to choose"]
10480 grid $top.cfont - -sticky w -pady 10
10481 mkfontdisp mainfont $top [mc "Main font"]
10482 mkfontdisp textfont $top [mc "Diff display font"]
10483 mkfontdisp uifont $top [mc "User interface font"]
10485 frame $top.buts
10486 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10487 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10488 bind $top <Key-Return> prefsok
10489 bind $top <Key-Escape> prefscan
10490 grid $top.buts.ok $top.buts.can
10491 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10492 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10493 grid $top.buts - - -pady 10 -sticky ew
10494 bind $top <Visibility> "focus $top.buts.ok"
10497 proc choose_extdiff {} {
10498 global extdifftool
10500 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10501 if {$prog ne {}} {
10502 set extdifftool $prog
10506 proc choosecolor {v vi w x cmd} {
10507 global $v
10509 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10510 -title [mc "Gitk: choose color for %s" $x]]
10511 if {$c eq {}} return
10512 $w conf -background $c
10513 lset $v $vi $c
10514 eval $cmd $c
10517 proc setselbg {c} {
10518 global bglist cflist
10519 foreach w $bglist {
10520 $w configure -selectbackground $c
10522 $cflist tag configure highlight \
10523 -background [$cflist cget -selectbackground]
10524 allcanvs itemconf secsel -fill $c
10527 proc setbg {c} {
10528 global bglist
10530 foreach w $bglist {
10531 $w conf -background $c
10535 proc setfg {c} {
10536 global fglist canv
10538 foreach w $fglist {
10539 $w conf -foreground $c
10541 allcanvs itemconf text -fill $c
10542 $canv itemconf circle -outline $c
10543 $canv itemconf markid -outline $c
10546 proc prefscan {} {
10547 global oldprefs prefstop
10549 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10550 limitdiffs tabstop perfile_attrs} {
10551 global $v
10552 set $v $oldprefs($v)
10554 catch {destroy $prefstop}
10555 unset prefstop
10556 fontcan
10559 proc prefsok {} {
10560 global maxwidth maxgraphpct
10561 global oldprefs prefstop showneartags showlocalchanges
10562 global fontpref mainfont textfont uifont
10563 global limitdiffs treediffs perfile_attrs
10565 catch {destroy $prefstop}
10566 unset prefstop
10567 fontcan
10568 set fontchanged 0
10569 if {$mainfont ne $fontpref(mainfont)} {
10570 set mainfont $fontpref(mainfont)
10571 parsefont mainfont $mainfont
10572 eval font configure mainfont [fontflags mainfont]
10573 eval font configure mainfontbold [fontflags mainfont 1]
10574 setcoords
10575 set fontchanged 1
10577 if {$textfont ne $fontpref(textfont)} {
10578 set textfont $fontpref(textfont)
10579 parsefont textfont $textfont
10580 eval font configure textfont [fontflags textfont]
10581 eval font configure textfontbold [fontflags textfont 1]
10583 if {$uifont ne $fontpref(uifont)} {
10584 set uifont $fontpref(uifont)
10585 parsefont uifont $uifont
10586 eval font configure uifont [fontflags uifont]
10588 settabs
10589 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10590 if {$showlocalchanges} {
10591 doshowlocalchanges
10592 } else {
10593 dohidelocalchanges
10596 if {$limitdiffs != $oldprefs(limitdiffs) ||
10597 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10598 # treediffs elements are limited by path;
10599 # won't have encodings cached if perfile_attrs was just turned on
10600 catch {unset treediffs}
10602 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10603 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10604 redisplay
10605 } elseif {$showneartags != $oldprefs(showneartags) ||
10606 $limitdiffs != $oldprefs(limitdiffs)} {
10607 reselectline
10611 proc formatdate {d} {
10612 global datetimeformat
10613 if {$d ne {}} {
10614 set d [clock format $d -format $datetimeformat]
10616 return $d
10619 # This list of encoding names and aliases is distilled from
10620 # http://www.iana.org/assignments/character-sets.
10621 # Not all of them are supported by Tcl.
10622 set encoding_aliases {
10623 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10624 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10625 { ISO-10646-UTF-1 csISO10646UTF1 }
10626 { ISO_646.basic:1983 ref csISO646basic1983 }
10627 { INVARIANT csINVARIANT }
10628 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10629 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10630 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10631 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10632 { NATS-DANO iso-ir-9-1 csNATSDANO }
10633 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10634 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10635 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10636 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10637 { ISO-2022-KR csISO2022KR }
10638 { EUC-KR csEUCKR }
10639 { ISO-2022-JP csISO2022JP }
10640 { ISO-2022-JP-2 csISO2022JP2 }
10641 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10642 csISO13JISC6220jp }
10643 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10644 { IT iso-ir-15 ISO646-IT csISO15Italian }
10645 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10646 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10647 { greek7-old iso-ir-18 csISO18Greek7Old }
10648 { latin-greek iso-ir-19 csISO19LatinGreek }
10649 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10650 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10651 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10652 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10653 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10654 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10655 { INIS iso-ir-49 csISO49INIS }
10656 { INIS-8 iso-ir-50 csISO50INIS8 }
10657 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10658 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10659 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10660 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10661 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10662 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10663 csISO60Norwegian1 }
10664 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10665 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10666 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10667 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10668 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10669 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10670 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10671 { greek7 iso-ir-88 csISO88Greek7 }
10672 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10673 { iso-ir-90 csISO90 }
10674 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10675 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10676 csISO92JISC62991984b }
10677 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10678 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10679 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10680 csISO95JIS62291984handadd }
10681 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10682 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10683 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10684 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10685 CP819 csISOLatin1 }
10686 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10687 { T.61-7bit iso-ir-102 csISO102T617bit }
10688 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10689 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10690 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10691 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10692 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10693 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10694 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10695 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10696 arabic csISOLatinArabic }
10697 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10698 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10699 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10700 greek greek8 csISOLatinGreek }
10701 { T.101-G2 iso-ir-128 csISO128T101G2 }
10702 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10703 csISOLatinHebrew }
10704 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10705 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10706 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10707 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10708 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10709 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10710 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10711 csISOLatinCyrillic }
10712 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10713 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10714 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10715 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10716 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10717 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10718 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10719 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10720 { ISO_10367-box iso-ir-155 csISO10367Box }
10721 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10722 { latin-lap lap iso-ir-158 csISO158Lap }
10723 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10724 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10725 { us-dk csUSDK }
10726 { dk-us csDKUS }
10727 { JIS_X0201 X0201 csHalfWidthKatakana }
10728 { KSC5636 ISO646-KR csKSC5636 }
10729 { ISO-10646-UCS-2 csUnicode }
10730 { ISO-10646-UCS-4 csUCS4 }
10731 { DEC-MCS dec csDECMCS }
10732 { hp-roman8 roman8 r8 csHPRoman8 }
10733 { macintosh mac csMacintosh }
10734 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10735 csIBM037 }
10736 { IBM038 EBCDIC-INT cp038 csIBM038 }
10737 { IBM273 CP273 csIBM273 }
10738 { IBM274 EBCDIC-BE CP274 csIBM274 }
10739 { IBM275 EBCDIC-BR cp275 csIBM275 }
10740 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10741 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10742 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10743 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10744 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10745 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10746 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10747 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10748 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10749 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10750 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10751 { IBM437 cp437 437 csPC8CodePage437 }
10752 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10753 { IBM775 cp775 csPC775Baltic }
10754 { IBM850 cp850 850 csPC850Multilingual }
10755 { IBM851 cp851 851 csIBM851 }
10756 { IBM852 cp852 852 csPCp852 }
10757 { IBM855 cp855 855 csIBM855 }
10758 { IBM857 cp857 857 csIBM857 }
10759 { IBM860 cp860 860 csIBM860 }
10760 { IBM861 cp861 861 cp-is csIBM861 }
10761 { IBM862 cp862 862 csPC862LatinHebrew }
10762 { IBM863 cp863 863 csIBM863 }
10763 { IBM864 cp864 csIBM864 }
10764 { IBM865 cp865 865 csIBM865 }
10765 { IBM866 cp866 866 csIBM866 }
10766 { IBM868 CP868 cp-ar csIBM868 }
10767 { IBM869 cp869 869 cp-gr csIBM869 }
10768 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10769 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10770 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10771 { IBM891 cp891 csIBM891 }
10772 { IBM903 cp903 csIBM903 }
10773 { IBM904 cp904 904 csIBBM904 }
10774 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10775 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10776 { IBM1026 CP1026 csIBM1026 }
10777 { EBCDIC-AT-DE csIBMEBCDICATDE }
10778 { EBCDIC-AT-DE-A csEBCDICATDEA }
10779 { EBCDIC-CA-FR csEBCDICCAFR }
10780 { EBCDIC-DK-NO csEBCDICDKNO }
10781 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10782 { EBCDIC-FI-SE csEBCDICFISE }
10783 { EBCDIC-FI-SE-A csEBCDICFISEA }
10784 { EBCDIC-FR csEBCDICFR }
10785 { EBCDIC-IT csEBCDICIT }
10786 { EBCDIC-PT csEBCDICPT }
10787 { EBCDIC-ES csEBCDICES }
10788 { EBCDIC-ES-A csEBCDICESA }
10789 { EBCDIC-ES-S csEBCDICESS }
10790 { EBCDIC-UK csEBCDICUK }
10791 { EBCDIC-US csEBCDICUS }
10792 { UNKNOWN-8BIT csUnknown8BiT }
10793 { MNEMONIC csMnemonic }
10794 { MNEM csMnem }
10795 { VISCII csVISCII }
10796 { VIQR csVIQR }
10797 { KOI8-R csKOI8R }
10798 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10799 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10800 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10801 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10802 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10803 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10804 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10805 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10806 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10807 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10808 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10809 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10810 { IBM1047 IBM-1047 }
10811 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10812 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10813 { UNICODE-1-1 csUnicode11 }
10814 { CESU-8 csCESU-8 }
10815 { BOCU-1 csBOCU-1 }
10816 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10817 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10818 l8 }
10819 { ISO-8859-15 ISO_8859-15 Latin-9 }
10820 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10821 { GBK CP936 MS936 windows-936 }
10822 { JIS_Encoding csJISEncoding }
10823 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10824 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10825 EUC-JP }
10826 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10827 { ISO-10646-UCS-Basic csUnicodeASCII }
10828 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10829 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10830 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10831 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10832 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10833 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10834 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10835 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10836 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10837 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10838 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10839 { Ventura-US csVenturaUS }
10840 { Ventura-International csVenturaInternational }
10841 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10842 { PC8-Turkish csPC8Turkish }
10843 { IBM-Symbols csIBMSymbols }
10844 { IBM-Thai csIBMThai }
10845 { HP-Legal csHPLegal }
10846 { HP-Pi-font csHPPiFont }
10847 { HP-Math8 csHPMath8 }
10848 { Adobe-Symbol-Encoding csHPPSMath }
10849 { HP-DeskTop csHPDesktop }
10850 { Ventura-Math csVenturaMath }
10851 { Microsoft-Publishing csMicrosoftPublishing }
10852 { Windows-31J csWindows31J }
10853 { GB2312 csGB2312 }
10854 { Big5 csBig5 }
10857 proc tcl_encoding {enc} {
10858 global encoding_aliases tcl_encoding_cache
10859 if {[info exists tcl_encoding_cache($enc)]} {
10860 return $tcl_encoding_cache($enc)
10862 set names [encoding names]
10863 set lcnames [string tolower $names]
10864 set enc [string tolower $enc]
10865 set i [lsearch -exact $lcnames $enc]
10866 if {$i < 0} {
10867 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10868 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10869 set i [lsearch -exact $lcnames $encx]
10872 if {$i < 0} {
10873 foreach l $encoding_aliases {
10874 set ll [string tolower $l]
10875 if {[lsearch -exact $ll $enc] < 0} continue
10876 # look through the aliases for one that tcl knows about
10877 foreach e $ll {
10878 set i [lsearch -exact $lcnames $e]
10879 if {$i < 0} {
10880 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10881 set i [lsearch -exact $lcnames $ex]
10884 if {$i >= 0} break
10886 break
10889 set tclenc {}
10890 if {$i >= 0} {
10891 set tclenc [lindex $names $i]
10893 set tcl_encoding_cache($enc) $tclenc
10894 return $tclenc
10897 proc gitattr {path attr default} {
10898 global path_attr_cache
10899 if {[info exists path_attr_cache($attr,$path)]} {
10900 set r $path_attr_cache($attr,$path)
10901 } else {
10902 set r "unspecified"
10903 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10904 regexp "(.*): encoding: (.*)" $line m f r
10906 set path_attr_cache($attr,$path) $r
10908 if {$r eq "unspecified"} {
10909 return $default
10911 return $r
10914 proc cache_gitattr {attr pathlist} {
10915 global path_attr_cache
10916 set newlist {}
10917 foreach path $pathlist {
10918 if {![info exists path_attr_cache($attr,$path)]} {
10919 lappend newlist $path
10922 set lim 1000
10923 if {[tk windowingsystem] == "win32"} {
10924 # windows has a 32k limit on the arguments to a command...
10925 set lim 30
10927 while {$newlist ne {}} {
10928 set head [lrange $newlist 0 [expr {$lim - 1}]]
10929 set newlist [lrange $newlist $lim end]
10930 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10931 foreach row [split $rlist "\n"] {
10932 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10933 if {[string index $path 0] eq "\""} {
10934 set path [encoding convertfrom [lindex $path 0]]
10936 set path_attr_cache($attr,$path) $value
10943 proc get_path_encoding {path} {
10944 global gui_encoding perfile_attrs
10945 set tcl_enc $gui_encoding
10946 if {$path ne {} && $perfile_attrs} {
10947 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10948 if {$enc2 ne {}} {
10949 set tcl_enc $enc2
10952 return $tcl_enc
10955 # First check that Tcl/Tk is recent enough
10956 if {[catch {package require Tk 8.4} err]} {
10957 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10958 Gitk requires at least Tcl/Tk 8.4."]
10959 exit 1
10962 # defaults...
10963 set wrcomcmd "git diff-tree --stdin -p --pretty"
10965 set gitencoding {}
10966 catch {
10967 set gitencoding [exec git config --get i18n.commitencoding]
10969 catch {
10970 set gitencoding [exec git config --get i18n.logoutputencoding]
10972 if {$gitencoding == ""} {
10973 set gitencoding "utf-8"
10975 set tclencoding [tcl_encoding $gitencoding]
10976 if {$tclencoding == {}} {
10977 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10980 set gui_encoding [encoding system]
10981 catch {
10982 set enc [exec git config --get gui.encoding]
10983 if {$enc ne {}} {
10984 set tclenc [tcl_encoding $enc]
10985 if {$tclenc ne {}} {
10986 set gui_encoding $tclenc
10987 } else {
10988 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10993 if {[tk windowingsystem] eq "aqua"} {
10994 set mainfont {{Lucida Grande} 9}
10995 set textfont {Monaco 9}
10996 set uifont {{Lucida Grande} 9 bold}
10997 } else {
10998 set mainfont {Helvetica 9}
10999 set textfont {Courier 9}
11000 set uifont {Helvetica 9 bold}
11002 set tabstop 8
11003 set findmergefiles 0
11004 set maxgraphpct 50
11005 set maxwidth 16
11006 set revlistorder 0
11007 set fastdate 0
11008 set uparrowlen 5
11009 set downarrowlen 5
11010 set mingaplen 100
11011 set cmitmode "patch"
11012 set wrapcomment "none"
11013 set showneartags 1
11014 set maxrefs 20
11015 set maxlinelen 200
11016 set showlocalchanges 1
11017 set limitdiffs 1
11018 set datetimeformat "%Y-%m-%d %H:%M:%S"
11019 set autoselect 1
11020 set perfile_attrs 0
11022 if {[tk windowingsystem] eq "aqua"} {
11023 set extdifftool "opendiff"
11024 } else {
11025 set extdifftool "meld"
11028 set colors {green red blue magenta darkgrey brown orange}
11029 set bgcolor white
11030 set fgcolor black
11031 set diffcolors {red "#00a000" blue}
11032 set diffcontext 3
11033 set ignorespace 0
11034 set selectbgcolor gray85
11035 set markbgcolor "#e0e0ff"
11037 set circlecolors {white blue gray blue blue}
11039 # button for popping up context menus
11040 if {[tk windowingsystem] eq "aqua"} {
11041 set ctxbut <Button-2>
11042 } else {
11043 set ctxbut <Button-3>
11046 ## For msgcat loading, first locate the installation location.
11047 if { [info exists ::env(GITK_MSGSDIR)] } {
11048 ## Msgsdir was manually set in the environment.
11049 set gitk_msgsdir $::env(GITK_MSGSDIR)
11050 } else {
11051 ## Let's guess the prefix from argv0.
11052 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11053 set gitk_libdir [file join $gitk_prefix share gitk lib]
11054 set gitk_msgsdir [file join $gitk_libdir msgs]
11055 unset gitk_prefix
11058 ## Internationalization (i18n) through msgcat and gettext. See
11059 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11060 package require msgcat
11061 namespace import ::msgcat::mc
11062 ## And eventually load the actual message catalog
11063 ::msgcat::mcload $gitk_msgsdir
11065 catch {source ~/.gitk}
11067 font create optionfont -family sans-serif -size -12
11069 parsefont mainfont $mainfont
11070 eval font create mainfont [fontflags mainfont]
11071 eval font create mainfontbold [fontflags mainfont 1]
11073 parsefont textfont $textfont
11074 eval font create textfont [fontflags textfont]
11075 eval font create textfontbold [fontflags textfont 1]
11077 parsefont uifont $uifont
11078 eval font create uifont [fontflags uifont]
11080 setoptions
11082 # check that we can find a .git directory somewhere...
11083 if {[catch {set gitdir [gitdir]}]} {
11084 show_error {} . [mc "Cannot find a git repository here."]
11085 exit 1
11087 if {![file isdirectory $gitdir]} {
11088 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11089 exit 1
11092 set selecthead {}
11093 set selectheadid {}
11095 set revtreeargs {}
11096 set cmdline_files {}
11097 set i 0
11098 set revtreeargscmd {}
11099 foreach arg $argv {
11100 switch -glob -- $arg {
11101 "" { }
11102 "--" {
11103 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11104 break
11106 "--select-commit=*" {
11107 set selecthead [string range $arg 16 end]
11109 "--argscmd=*" {
11110 set revtreeargscmd [string range $arg 10 end]
11112 default {
11113 lappend revtreeargs $arg
11116 incr i
11119 if {$selecthead eq "HEAD"} {
11120 set selecthead {}
11123 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11124 # no -- on command line, but some arguments (other than --argscmd)
11125 if {[catch {
11126 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11127 set cmdline_files [split $f "\n"]
11128 set n [llength $cmdline_files]
11129 set revtreeargs [lrange $revtreeargs 0 end-$n]
11130 # Unfortunately git rev-parse doesn't produce an error when
11131 # something is both a revision and a filename. To be consistent
11132 # with git log and git rev-list, check revtreeargs for filenames.
11133 foreach arg $revtreeargs {
11134 if {[file exists $arg]} {
11135 show_error {} . [mc "Ambiguous argument '%s': both revision\
11136 and filename" $arg]
11137 exit 1
11140 } err]} {
11141 # unfortunately we get both stdout and stderr in $err,
11142 # so look for "fatal:".
11143 set i [string first "fatal:" $err]
11144 if {$i > 0} {
11145 set err [string range $err [expr {$i + 6}] end]
11147 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11148 exit 1
11152 set nullid "0000000000000000000000000000000000000000"
11153 set nullid2 "0000000000000000000000000000000000000001"
11154 set nullfile "/dev/null"
11156 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11157 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11159 set runq {}
11160 set history {}
11161 set historyindex 0
11162 set fh_serial 0
11163 set nhl_names {}
11164 set highlight_paths {}
11165 set findpattern {}
11166 set searchdirn -forwards
11167 set boldids {}
11168 set boldnameids {}
11169 set diffelide {0 0}
11170 set markingmatches 0
11171 set linkentercount 0
11172 set need_redisplay 0
11173 set nrows_drawn 0
11174 set firsttabstop 0
11176 set nextviewnum 1
11177 set curview 0
11178 set selectedview 0
11179 set selectedhlview [mc "None"]
11180 set highlight_related [mc "None"]
11181 set highlight_files {}
11182 set viewfiles(0) {}
11183 set viewperm(0) 0
11184 set viewargs(0) {}
11185 set viewargscmd(0) {}
11187 set selectedline {}
11188 set numcommits 0
11189 set loginstance 0
11190 set cmdlineok 0
11191 set stopped 0
11192 set stuffsaved 0
11193 set patchnum 0
11194 set lserial 0
11195 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11196 setcoords
11197 makewindow
11198 catch {
11199 image create photo gitlogo -width 16 -height 16
11201 image create photo gitlogominus -width 4 -height 2
11202 gitlogominus put #C00000 -to 0 0 4 2
11203 gitlogo copy gitlogominus -to 1 5
11204 gitlogo copy gitlogominus -to 6 5
11205 gitlogo copy gitlogominus -to 11 5
11206 image delete gitlogominus
11208 image create photo gitlogoplus -width 4 -height 4
11209 gitlogoplus put #008000 -to 1 0 3 4
11210 gitlogoplus put #008000 -to 0 1 4 3
11211 gitlogo copy gitlogoplus -to 1 9
11212 gitlogo copy gitlogoplus -to 6 9
11213 gitlogo copy gitlogoplus -to 11 9
11214 image delete gitlogoplus
11216 image create photo gitlogo32 -width 32 -height 32
11217 gitlogo32 copy gitlogo -zoom 2 2
11219 wm iconphoto . -default gitlogo gitlogo32
11221 # wait for the window to become visible
11222 tkwait visibility .
11223 wm title . "[file tail $argv0]: [file tail [pwd]]"
11224 update
11225 readrefs
11227 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11228 # create a view for the files/dirs specified on the command line
11229 set curview 1
11230 set selectedview 1
11231 set nextviewnum 2
11232 set viewname(1) [mc "Command line"]
11233 set viewfiles(1) $cmdline_files
11234 set viewargs(1) $revtreeargs
11235 set viewargscmd(1) $revtreeargscmd
11236 set viewperm(1) 0
11237 set vdatemode(1) 0
11238 addviewmenu 1
11239 .bar.view entryconf [mca "Edit view..."] -state normal
11240 .bar.view entryconf [mca "Delete view"] -state normal
11243 if {[info exists permviews]} {
11244 foreach v $permviews {
11245 set n $nextviewnum
11246 incr nextviewnum
11247 set viewname($n) [lindex $v 0]
11248 set viewfiles($n) [lindex $v 1]
11249 set viewargs($n) [lindex $v 2]
11250 set viewargscmd($n) [lindex $v 3]
11251 set viewperm($n) 1
11252 addviewmenu $n
11256 if {[tk windowingsystem] eq "win32"} {
11257 focus -force .
11260 getcommits {}