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]
16 }
17 }
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
31 }
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
34 }
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
38 }
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
46 }
47 lappend runq [list $fd $script]
48 }
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
58 }
59 }
60 }
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]
83 }
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
86 }
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
89 }
90 if {$runq ne {}} {
91 after idle dorunq
92 }
93 }
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
102 }
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
115 }
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
124 }
125 }
126 catch {close $fd}
127 return $mlist
128 }
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
149 }
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
157 }
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
167 }
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.
177 }
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
184 }
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
195 }
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
202 }
203 "--not" - "--all" {
204 lappend revargs $arg
205 }
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
210 }
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
219 }
220 lappend glflags $arg
221 }
222 default {
223 # Non-flag arguments specify commits or ranges of commits
224 if {[string match "*...*" $arg]} {
225 lappend revargs --gitk-symmetric-diff-marker
226 }
227 lappend revargs $arg
228 }
229 }
230 }
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
237 }
239 proc parseviewrevs {view revs} {
240 global vposids vnegids
242 if {$revs eq {}} {
243 set revs HEAD
244 }
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 ", "]"
260 }
261 } else {
262 set err [join [lrange $errlines $l end] "\n"]
263 }
264 break
265 }
266 lappend badrev $line
267 }
268 }
269 error_popup "[mc "Error parsing revisions:"] $err"
270 return {}
271 }
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
284 }
285 }
286 lappend neg [string range $id 1 end]
287 } else {
288 if {$sdm != 2} {
289 lappend ret $id
290 } else {
291 lset ret end $id...[lindex $ret end]
292 }
293 lappend pos $id
294 }
295 incr sdm -1
296 }
297 set vposids($view) $pos
298 set vnegids($view) $neg
299 return $ret
300 }
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
326 }
327 set args [concat $args [split $str "\n"]]
328 }
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."]
342 }
343 return 0
344 }
345 }
346 set vfilelimit($view) $files
348 if {$vcanopt($view)} {
349 set revs [parseviewrevs $view $vrevs($view)]
350 if {$revs eq {}} {
351 return 0
352 }
353 set args [concat $vflags($view) $revs]
354 } else {
355 set args $vorigargs($view)
356 }
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
364 }
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
371 }
372 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
373 interestedin $viewmainheadid($view) dodiffindex
374 }
375 fconfigure $fd -blocking 0 -translation lf -eofchar {}
376 if {$tclencoding != {}} {
377 fconfigure $fd -encoding $tclencoding
378 }
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
384 }
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
397 }
398 }
399 catch {close $fd}
400 nukefile $fd
401 unset commfd($inst)
402 unset leftover($inst)
403 }
405 proc stop_backends {} {
406 global commfd
408 foreach inst [array names commfd] {
409 stop_instance $inst
410 }
411 }
413 proc stop_rev_list {view} {
414 global viewinstances
416 foreach inst $viewinstances($view) {
417 stop_instance $inst
418 }
419 set viewinstances($view) {}
420 }
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
431 }
432 }
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"]
444 }
445 }
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
461 }
462 set viewmainheadid($view) $mainheadid
463 set viewmainheadid_orig($view) $mainheadid
464 if {$vfilelimit($view) ne {}} {
465 get_viewmainhead $view
466 }
467 }
468 if {$showlocalchanges} {
469 doshowlocalchanges
470 }
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
477 }
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
492 }
493 } else {
494 lappend $newrevs $rev
495 }
496 }
497 if {$npos == 0} return
498 set revs $newrevs
499 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
500 }
501 set args [concat $vflags($view) $revs --not $oldpos]
502 } else {
503 set args $vorigargs($view)
504 }
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
511 }
512 if {$viewactive($view) == 0} {
513 set startmsecs [clock clicks -milliseconds]
514 }
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
520 }
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
528 }
529 }
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
539 }
541 if {!$viewcomplete($curview)} {
542 stop_rev_list $curview
543 }
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
553 }
554 clear_display
555 catch {unset commitinterest}
556 catch {unset cached_commitrow}
557 catch {unset targetid}
558 setcanvscroll
559 getcommits $selid
560 return 0
561 }
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]
572 }
573 return [format "z%.8x" $n]
574 }
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}
595 }
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)
604 }
605 # some commits might have children but haven't been seen yet
606 foreach vid [array names children $view,*] {
607 unset children($vid)
608 }
609 foreach va [array names varccommits $view,*] {
610 unset varccommits($va)
611 }
612 foreach vd [array names vseedcount $view,*] {
613 unset vseedcount($vd)
614 }
615 catch {unset ordertok}
616 }
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]
627 }
628 return $ret
629 }
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
641 }
642 set cdate [lindex $commitinfo($id) 4]
643 if {![string is integer -strict $cdate]} {
644 set cdate 0
645 }
646 if {![info exists vseedcount($view,$cdate)]} {
647 set vseedcount($view,$cdate) -1
648 }
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 {}
654 }
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]
663 }
664 }
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]
669 }
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]
676 }
677 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
678 set c $b
679 set b [lindex $vleftptr($view) $c]
680 }
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
687 }
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
693 }
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
702 }
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
724 }
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
734 }
735 if {[string compare $otok $vtokmod($v)] <= 0} {
736 modify_arc $v $oa
737 }
738 }
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
756 }
757 }
758 }
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]
766 }
767 }
768 set a $b
769 }
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)]
776 }
777 set oldtok [lindex $varctok($v) $a]
778 if {!$vdatemode($v)} {
779 set tok {}
780 } else {
781 set tok $oldtok
782 }
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]
791 }
792 }
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]
797 }
798 if {$tok eq $oldtok} {
799 continue
800 }
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
807 }
808 }
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
814 }
815 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
816 modify_arc $v $b
817 }
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
824 }
825 if {$d != 0} {
826 lset vbackptr($v) $d $c
827 }
828 if {[lindex $vlastins($v) $b] == $a} {
829 lset vlastins($v) $b $c
830 }
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]
839 }
840 while {$b != 0 && \
841 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
842 set c $b
843 set b [lindex $vleftptr($v) $c]
844 }
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
851 }
852 lset vleftptr($v) $a $b
853 if {$b != 0} {
854 lset vbackptr($v) $b $a
855 }
856 lset vlastins($v) $ka $a
857 }
858 }
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)]
863 }
864 }
865 set t2 [clock clicks -milliseconds]
866 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
867 }
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)
879 }
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
885 }
886 }
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
902 }
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}
908 }
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
917 }
918 }
919 }
920 }
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
932 }
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
945 }
946 }
947 setcanvscroll
948 drawvisible
949 }
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
960 }
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
967 }
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]
977 }
978 modify_arc $v $a $i
979 if {[info exist currentid] && $id eq $currentid} {
980 unset currentid
981 set selectedline {}
982 }
983 if {[info exists targetid] && $targetid eq $id} {
984 set targetid $p
985 }
986 setcanvscroll
987 drawvisible
988 }
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
996 }
997 }
998 return {}
999 }
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
1009 }
1010 }
1011 return {}
1012 }
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)]]
1019 }
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
1032 }
1033 }
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 {}
1040 }
1041 set r 0
1042 if {$a != 0} {
1043 if {$lim eq {}} {
1044 set lim [llength $varccommits($v,$a)]
1045 }
1046 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1047 }
1048 set vrowmod($v) $r
1049 undolayout $r
1050 }
1051 }
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}]]
1064 }
1065 catch {unset cached_commitrow}
1066 }
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]
1073 }
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]
1088 }
1089 set row [lindex $varcrow($v) $a]
1090 }
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]
1102 }
1103 if {$a == 0} break
1104 }
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
1111 }
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]
1117 }
1118 }
1120 # Test whether view $v contains commit $id
1121 proc commitinview {id v} {
1122 global varcid
1124 return [info exists varcid($v,$id)]
1125 }
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 {}
1136 }
1137 set a $varcid($v,$id)
1138 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1139 update_arcrows $v
1140 }
1141 if {[info exists cached_commitrow($id)]} {
1142 return $cached_commitrow($id)
1143 }
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 {}
1148 }
1149 incr i [lindex $varcrow($v) $a]
1150 set cached_commitrow($id) $i
1151 return $i
1152 }
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
1162 }
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}]
1166 }
1167 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1168 }
1170 proc bsearch {l elt} {
1171 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1172 return 0
1173 }
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
1185 }
1186 }
1187 return $lo
1188 }
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
1198 }
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}]]
1214 }
1215 foreach id $varccommits($curview,$a) {
1216 lappend displayorder $id
1217 lappend parentlist $parents($curview,$id)
1218 }
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
1225 }
1226 }
1227 incr r $al
1228 }
1229 }
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]
1238 }
1239 return $id
1240 }
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]
1262 }
1263 set varcid($v,$p) $b
1264 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1265 modify_arc $v $b
1266 }
1267 lappend varccommits($v,$b) $p
1268 incr commitidx($v)
1269 set scripts [check_interest $p $scripts]
1270 }
1271 }
1272 if {$missing_parents > 0} {
1273 foreach s $scripts {
1274 eval $s
1275 }
1276 }
1277 }
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"
1289 }
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)]
1295 }
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}]
1302 }
1303 }
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
1314 }
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
1327 }
1328 }
1329 if {$newlist ne {}} {
1330 set commitinterest($prefix) $newlist
1331 } else {
1332 unset commitinterest($prefix)
1333 }
1334 }
1335 return $scripts
1336 }
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"
1349 }
1350 if {$stuff == {}} {
1351 if {![eof $fd]} {
1352 return 1
1353 }
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]
1360 }
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"
1367 }
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.)"
1375 }
1376 } else {
1377 set err "Error reading commits$fv: $err"
1378 }
1379 error_popup $err
1380 }
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
1387 }
1388 if {$view == $curview} {
1389 run chewcommits
1390 }
1391 return 0
1392 }
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
1401 }
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}]]
1408 }
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}
1421 }
1422 set ids [string range $ids 1 end]
1423 }
1424 set ok 1
1425 foreach id $ids {
1426 if {[string length $id] != 40} {
1427 set ok 0
1428 break
1429 }
1430 }
1431 }
1432 if {!$ok} {
1433 set shortcmit $cmit
1434 if {[string length $shortcmit] > 80} {
1435 set shortcmit "[string range $shortcmit 0 80]..."
1436 }
1437 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1438 exit 1
1439 }
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
1458 }
1459 }
1460 }
1462 set a 0
1463 if {[info exists varcid($vid)]} {
1464 if {$cmitlisted($vid) || !$listed} continue
1465 set a $varcid($vid)
1466 }
1467 if {$listed} {
1468 set olds [lrange $ids 1 end]
1469 } else {
1470 set olds {}
1471 }
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)
1483 }
1484 }
1485 if {$a == 0} {
1486 # new arc
1487 set a [newvarc $view $id]
1488 }
1489 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1490 modify_arc $view $a
1491 }
1492 if {![info exists varcid($vid)]} {
1493 set varcid($vid) $a
1494 lappend varccommits($view,$a) $id
1495 incr commitidx($view)
1496 }
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}
1507 }
1508 if {[info exists varcid($view,$p)]} {
1509 fix_reversal $p $a $view
1510 }
1511 }
1512 incr i
1513 }
1515 set scripts [check_interest $id $scripts]
1516 set gotsome 1
1517 }
1518 if {$gotsome} {
1519 global numcommits hlview
1521 if {$view == $curview} {
1522 set numcommits $commitidx($view)
1523 run chewcommits
1524 }
1525 if {[info exists hlview] && $view == $hlview} {
1526 # we never actually get here...
1527 run vhighlightmore
1528 }
1529 foreach s $scripts {
1530 eval $s
1531 }
1532 }
1533 return 2
1534 }
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
1554 }
1555 }
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"]
1562 }
1563 notbusy layout
1564 }
1565 return 0
1566 }
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
1577 }
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
1584 }
1586 proc readcommit {id} {
1587 if {[catch {set contents [do_readcommit $id]}]} return
1588 parsecommit $id $contents 1
1589 }
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]
1605 }
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] " "]
1617 }
1618 }
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]
1625 }
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]]
1630 }
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"
1639 }
1640 set comment $newcomment
1641 }
1642 if {$comdate != {}} {
1643 set cdate($id) $comdate
1644 }
1645 set commitinfo($id) [list $headline $auname $audate \
1646 $comname $comdate $comment]
1647 }
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"]]
1658 }
1659 }
1660 return 1
1661 }
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]
1672 }
1673 return $ids
1674 }
1676 proc readrefs {} {
1677 global tagids idtags headids idheads tagobjid
1678 global otherrefids idotherrefs mainhead mainheadid
1679 global selecthead selectheadid
1680 global hideremotes
1682 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1683 catch {unset $v}
1684 }
1685 set refd [open [list | git show-ref -d] r]
1686 while {[gets $refd line] >= 0} {
1687 if {[string index $line 40] ne " "} continue
1688 set id [string range $line 0 39]
1689 set ref [string range $line 41 end]
1690 if {![string match "refs/*" $ref]} continue
1691 set name [string range $ref 5 end]
1692 if {[string match "remotes/*" $name]} {
1693 if {![string match "*/HEAD" $name] && !$hideremotes} {
1694 set headids($name) $id
1695 lappend idheads($id) $name
1696 }
1697 } elseif {[string match "heads/*" $name]} {
1698 set name [string range $name 6 end]
1699 set headids($name) $id
1700 lappend idheads($id) $name
1701 } elseif {[string match "tags/*" $name]} {
1702 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1703 # which is what we want since the former is the commit ID
1704 set name [string range $name 5 end]
1705 if {[string match "*^{}" $name]} {
1706 set name [string range $name 0 end-3]
1707 } else {
1708 set tagobjid($name) $id
1709 }
1710 set tagids($name) $id
1711 lappend idtags($id) $name
1712 } else {
1713 set otherrefids($name) $id
1714 lappend idotherrefs($id) $name
1715 }
1716 }
1717 catch {close $refd}
1718 set mainhead {}
1719 set mainheadid {}
1720 catch {
1721 set mainheadid [exec git rev-parse HEAD]
1722 set thehead [exec git symbolic-ref HEAD]
1723 if {[string match "refs/heads/*" $thehead]} {
1724 set mainhead [string range $thehead 11 end]
1725 }
1726 }
1727 set selectheadid {}
1728 if {$selecthead ne {}} {
1729 catch {
1730 set selectheadid [exec git rev-parse --verify $selecthead]
1731 }
1732 }
1733 }
1735 # skip over fake commits
1736 proc first_real_row {} {
1737 global nullid nullid2 numcommits
1739 for {set row 0} {$row < $numcommits} {incr row} {
1740 set id [commitonrow $row]
1741 if {$id ne $nullid && $id ne $nullid2} {
1742 break
1743 }
1744 }
1745 return $row
1746 }
1748 # update things for a head moved to a child of its previous location
1749 proc movehead {id name} {
1750 global headids idheads
1752 removehead $headids($name) $name
1753 set headids($name) $id
1754 lappend idheads($id) $name
1755 }
1757 # update things when a head has been removed
1758 proc removehead {id name} {
1759 global headids idheads
1761 if {$idheads($id) eq $name} {
1762 unset idheads($id)
1763 } else {
1764 set i [lsearch -exact $idheads($id) $name]
1765 if {$i >= 0} {
1766 set idheads($id) [lreplace $idheads($id) $i $i]
1767 }
1768 }
1769 unset headids($name)
1770 }
1772 proc make_transient {window origin} {
1773 global have_tk85
1775 # In MacOS Tk 8.4 transient appears to work by setting
1776 # overrideredirect, which is utterly useless, since the
1777 # windows get no border, and are not even kept above
1778 # the parent.
1779 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1781 wm transient $window $origin
1783 # Windows fails to place transient windows normally, so
1784 # schedule a callback to center them on the parent.
1785 if {[tk windowingsystem] eq {win32}} {
1786 after idle [list tk::PlaceWindow $window widget $origin]
1787 }
1788 }
1790 proc show_error {w top msg {mc mc}} {
1791 message $w.m -text $msg -justify center -aspect 400
1792 pack $w.m -side top -fill x -padx 20 -pady 20
1793 button $w.ok -text [$mc OK] -command "destroy $top"
1794 pack $w.ok -side bottom -fill x
1795 bind $top <Visibility> "grab $top; focus $top"
1796 bind $top <Key-Return> "destroy $top"
1797 bind $top <Key-space> "destroy $top"
1798 bind $top <Key-Escape> "destroy $top"
1799 tkwait window $top
1800 }
1802 proc error_popup {msg {owner .}} {
1803 set w .error
1804 toplevel $w
1805 make_transient $w $owner
1806 show_error $w $w $msg
1807 }
1809 proc confirm_popup {msg {owner .}} {
1810 global confirm_ok
1811 set confirm_ok 0
1812 set w .confirm
1813 toplevel $w
1814 make_transient $w $owner
1815 message $w.m -text $msg -justify center -aspect 400
1816 pack $w.m -side top -fill x -padx 20 -pady 20
1817 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1818 pack $w.ok -side left -fill x
1819 button $w.cancel -text [mc Cancel] -command "destroy $w"
1820 pack $w.cancel -side right -fill x
1821 bind $w <Visibility> "grab $w; focus $w"
1822 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1823 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1824 bind $w <Key-Escape> "destroy $w"
1825 tkwait window $w
1826 return $confirm_ok
1827 }
1829 proc setoptions {} {
1830 option add *Panedwindow.showHandle 1 startupFile
1831 option add *Panedwindow.sashRelief raised startupFile
1832 option add *Button.font uifont startupFile
1833 option add *Checkbutton.font uifont startupFile
1834 option add *Radiobutton.font uifont startupFile
1835 if {[tk windowingsystem] ne "aqua"} {
1836 option add *Menu.font uifont startupFile
1837 }
1838 option add *Menubutton.font uifont startupFile
1839 option add *Label.font uifont startupFile
1840 option add *Message.font uifont startupFile
1841 option add *Entry.font uifont startupFile
1842 }
1844 # Make a menu and submenus.
1845 # m is the window name for the menu, items is the list of menu items to add.
1846 # Each item is a list {mc label type description options...}
1847 # mc is ignored; it's so we can put mc there to alert xgettext
1848 # label is the string that appears in the menu
1849 # type is cascade, command or radiobutton (should add checkbutton)
1850 # description depends on type; it's the sublist for cascade, the
1851 # command to invoke for command, or {variable value} for radiobutton
1852 proc makemenu {m items} {
1853 menu $m
1854 if {[tk windowingsystem] eq {aqua}} {
1855 set Meta1 Cmd
1856 } else {
1857 set Meta1 Ctrl
1858 }
1859 foreach i $items {
1860 set name [mc [lindex $i 1]]
1861 set type [lindex $i 2]
1862 set thing [lindex $i 3]
1863 set params [list $type]
1864 if {$name ne {}} {
1865 set u [string first "&" [string map {&& x} $name]]
1866 lappend params -label [string map {&& & & {}} $name]
1867 if {$u >= 0} {
1868 lappend params -underline $u
1869 }
1870 }
1871 switch -- $type {
1872 "cascade" {
1873 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1874 lappend params -menu $m.$submenu
1875 }
1876 "command" {
1877 lappend params -command $thing
1878 }
1879 "radiobutton" {
1880 lappend params -variable [lindex $thing 0] \
1881 -value [lindex $thing 1]
1882 }
1883 }
1884 set tail [lrange $i 4 end]
1885 regsub -all {\yMeta1\y} $tail $Meta1 tail
1886 eval $m add $params $tail
1887 if {$type eq "cascade"} {
1888 makemenu $m.$submenu $thing
1889 }
1890 }
1891 }
1893 # translate string and remove ampersands
1894 proc mca {str} {
1895 return [string map {&& & & {}} [mc $str]]
1896 }
1898 proc makewindow {} {
1899 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1900 global tabstop
1901 global findtype findtypemenu findloc findstring fstring geometry
1902 global entries sha1entry sha1string sha1but
1903 global diffcontextstring diffcontext
1904 global ignorespace
1905 global maincursor textcursor curtextcursor
1906 global rowctxmenu fakerowmenu mergemax wrapcomment
1907 global highlight_files gdttype
1908 global searchstring sstring
1909 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1910 global headctxmenu progresscanv progressitem progresscoords statusw
1911 global fprogitem fprogcoord lastprogupdate progupdatepending
1912 global rprogitem rprogcoord rownumsel numcommits
1913 global have_tk85
1915 # The "mc" arguments here are purely so that xgettext
1916 # sees the following string as needing to be translated
1917 set file {
1918 mc "File" cascade {
1919 {mc "Update" command updatecommits -accelerator F5}
1920 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1921 {mc "Reread references" command rereadrefs}
1922 {mc "List references" command showrefs -accelerator F2}
1923 {xx "" separator}
1924 {mc "Start git gui" command {exec git gui &}}
1925 {xx "" separator}
1926 {mc "Quit" command doquit -accelerator Meta1-Q}
1927 }}
1928 set edit {
1929 mc "Edit" cascade {
1930 {mc "Preferences" command doprefs}
1931 }}
1932 set view {
1933 mc "View" cascade {
1934 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1935 {mc "Edit view..." command editview -state disabled -accelerator F4}
1936 {mc "Delete view" command delview -state disabled}
1937 {xx "" separator}
1938 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1939 }}
1940 if {[tk windowingsystem] ne "aqua"} {
1941 set help {
1942 mc "Help" cascade {
1943 {mc "About gitk" command about}
1944 {mc "Key bindings" command keys}
1945 }}
1946 set bar [list $file $edit $view $help]
1947 } else {
1948 proc ::tk::mac::ShowPreferences {} {doprefs}
1949 proc ::tk::mac::Quit {} {doquit}
1950 lset file end [lreplace [lindex $file end] end-1 end]
1951 set apple {
1952 xx "Apple" cascade {
1953 {mc "About gitk" command about}
1954 {xx "" separator}
1955 }}
1956 set help {
1957 mc "Help" cascade {
1958 {mc "Key bindings" command keys}
1959 }}
1960 set bar [list $apple $file $view $help]
1961 }
1962 makemenu .bar $bar
1963 . configure -menu .bar
1965 # the gui has upper and lower half, parts of a paned window.
1966 panedwindow .ctop -orient vertical
1968 # possibly use assumed geometry
1969 if {![info exists geometry(pwsash0)]} {
1970 set geometry(topheight) [expr {15 * $linespc}]
1971 set geometry(topwidth) [expr {80 * $charspc}]
1972 set geometry(botheight) [expr {15 * $linespc}]
1973 set geometry(botwidth) [expr {50 * $charspc}]
1974 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1975 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1976 }
1978 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1979 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1980 frame .tf.histframe
1981 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1983 # create three canvases
1984 set cscroll .tf.histframe.csb
1985 set canv .tf.histframe.pwclist.canv
1986 canvas $canv \
1987 -selectbackground $selectbgcolor \
1988 -background $bgcolor -bd 0 \
1989 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1990 .tf.histframe.pwclist add $canv
1991 set canv2 .tf.histframe.pwclist.canv2
1992 canvas $canv2 \
1993 -selectbackground $selectbgcolor \
1994 -background $bgcolor -bd 0 -yscrollincr $linespc
1995 .tf.histframe.pwclist add $canv2
1996 set canv3 .tf.histframe.pwclist.canv3
1997 canvas $canv3 \
1998 -selectbackground $selectbgcolor \
1999 -background $bgcolor -bd 0 -yscrollincr $linespc
2000 .tf.histframe.pwclist add $canv3
2001 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2002 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2004 # a scroll bar to rule them
2005 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
2006 pack $cscroll -side right -fill y
2007 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2008 lappend bglist $canv $canv2 $canv3
2009 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2011 # we have two button bars at bottom of top frame. Bar 1
2012 frame .tf.bar
2013 frame .tf.lbar -height 15
2015 set sha1entry .tf.bar.sha1
2016 set entries $sha1entry
2017 set sha1but .tf.bar.sha1label
2018 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2019 -command gotocommit -width 8
2020 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2021 pack .tf.bar.sha1label -side left
2022 entry $sha1entry -width 40 -font textfont -textvariable sha1string
2023 trace add variable sha1string write sha1change
2024 pack $sha1entry -side left -pady 2
2026 image create bitmap bm-left -data {
2027 #define left_width 16
2028 #define left_height 16
2029 static unsigned char left_bits[] = {
2030 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2031 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2032 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2033 }
2034 image create bitmap bm-right -data {
2035 #define right_width 16
2036 #define right_height 16
2037 static unsigned char right_bits[] = {
2038 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2039 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2040 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2041 }
2042 button .tf.bar.leftbut -image bm-left -command goback \
2043 -state disabled -width 26
2044 pack .tf.bar.leftbut -side left -fill y
2045 button .tf.bar.rightbut -image bm-right -command goforw \
2046 -state disabled -width 26
2047 pack .tf.bar.rightbut -side left -fill y
2049 label .tf.bar.rowlabel -text [mc "Row"]
2050 set rownumsel {}
2051 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2052 -relief sunken -anchor e
2053 label .tf.bar.rowlabel2 -text "/"
2054 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2055 -relief sunken -anchor e
2056 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2057 -side left
2058 global selectedline
2059 trace add variable selectedline write selectedline_change
2061 # Status label and progress bar
2062 set statusw .tf.bar.status
2063 label $statusw -width 15 -relief sunken
2064 pack $statusw -side left -padx 5
2065 set h [expr {[font metrics uifont -linespace] + 2}]
2066 set progresscanv .tf.bar.progress
2067 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2068 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2069 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2070 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2071 pack $progresscanv -side right -expand 1 -fill x
2072 set progresscoords {0 0}
2073 set fprogcoord 0
2074 set rprogcoord 0
2075 bind $progresscanv <Configure> adjustprogress
2076 set lastprogupdate [clock clicks -milliseconds]
2077 set progupdatepending 0
2079 # build up the bottom bar of upper window
2080 label .tf.lbar.flabel -text "[mc "Find"] "
2081 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2082 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2083 label .tf.lbar.flab2 -text " [mc "commit"] "
2084 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2085 -side left -fill y
2086 set gdttype [mc "containing:"]
2087 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2088 [mc "containing:"] \
2089 [mc "touching paths:"] \
2090 [mc "adding/removing string:"]]
2091 trace add variable gdttype write gdttype_change
2092 pack .tf.lbar.gdttype -side left -fill y
2094 set findstring {}
2095 set fstring .tf.lbar.findstring
2096 lappend entries $fstring
2097 entry $fstring -width 30 -font textfont -textvariable findstring
2098 trace add variable findstring write find_change
2099 set findtype [mc "Exact"]
2100 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2101 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2102 trace add variable findtype write findcom_change
2103 set findloc [mc "All fields"]
2104 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2105 [mc "Comments"] [mc "Author"] [mc "Committer"]
2106 trace add variable findloc write find_change
2107 pack .tf.lbar.findloc -side right
2108 pack .tf.lbar.findtype -side right
2109 pack $fstring -side left -expand 1 -fill x
2111 # Finish putting the upper half of the viewer together
2112 pack .tf.lbar -in .tf -side bottom -fill x
2113 pack .tf.bar -in .tf -side bottom -fill x
2114 pack .tf.histframe -fill both -side top -expand 1
2115 .ctop add .tf
2116 .ctop paneconfigure .tf -height $geometry(topheight)
2117 .ctop paneconfigure .tf -width $geometry(topwidth)
2119 # now build up the bottom
2120 panedwindow .pwbottom -orient horizontal
2122 # lower left, a text box over search bar, scroll bar to the right
2123 # if we know window height, then that will set the lower text height, otherwise
2124 # we set lower text height which will drive window height
2125 if {[info exists geometry(main)]} {
2126 frame .bleft -width $geometry(botwidth)
2127 } else {
2128 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2129 }
2130 frame .bleft.top
2131 frame .bleft.mid
2132 frame .bleft.bottom
2134 button .bleft.top.search -text [mc "Search"] -command dosearch
2135 pack .bleft.top.search -side left -padx 5
2136 set sstring .bleft.top.sstring
2137 entry $sstring -width 20 -font textfont -textvariable searchstring
2138 lappend entries $sstring
2139 trace add variable searchstring write incrsearch
2140 pack $sstring -side left -expand 1 -fill x
2141 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2142 -command changediffdisp -variable diffelide -value {0 0}
2143 radiobutton .bleft.mid.old -text [mc "Old version"] \
2144 -command changediffdisp -variable diffelide -value {0 1}
2145 radiobutton .bleft.mid.new -text [mc "New version"] \
2146 -command changediffdisp -variable diffelide -value {1 0}
2147 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2148 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2149 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2150 -from 0 -increment 1 -to 10000000 \
2151 -validate all -validatecommand "diffcontextvalidate %P" \
2152 -textvariable diffcontextstring
2153 .bleft.mid.diffcontext set $diffcontext
2154 trace add variable diffcontextstring write diffcontextchange
2155 lappend entries .bleft.mid.diffcontext
2156 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2157 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2158 -command changeignorespace -variable ignorespace
2159 pack .bleft.mid.ignspace -side left -padx 5
2160 set ctext .bleft.bottom.ctext
2161 text $ctext -background $bgcolor -foreground $fgcolor \
2162 -state disabled -font textfont \
2163 -yscrollcommand scrolltext -wrap none \
2164 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2165 if {$have_tk85} {
2166 $ctext conf -tabstyle wordprocessor
2167 }
2168 scrollbar .bleft.bottom.sb -command "$ctext yview"
2169 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2170 -width 10
2171 pack .bleft.top -side top -fill x
2172 pack .bleft.mid -side top -fill x
2173 grid $ctext .bleft.bottom.sb -sticky nsew
2174 grid .bleft.bottom.sbhorizontal -sticky ew
2175 grid columnconfigure .bleft.bottom 0 -weight 1
2176 grid rowconfigure .bleft.bottom 0 -weight 1
2177 grid rowconfigure .bleft.bottom 1 -weight 0
2178 pack .bleft.bottom -side top -fill both -expand 1
2179 lappend bglist $ctext
2180 lappend fglist $ctext
2182 $ctext tag conf comment -wrap $wrapcomment
2183 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2184 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2185 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2186 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2187 $ctext tag conf m0 -fore red
2188 $ctext tag conf m1 -fore blue
2189 $ctext tag conf m2 -fore green
2190 $ctext tag conf m3 -fore purple
2191 $ctext tag conf m4 -fore brown
2192 $ctext tag conf m5 -fore "#009090"
2193 $ctext tag conf m6 -fore magenta
2194 $ctext tag conf m7 -fore "#808000"
2195 $ctext tag conf m8 -fore "#009000"
2196 $ctext tag conf m9 -fore "#ff0080"
2197 $ctext tag conf m10 -fore cyan
2198 $ctext tag conf m11 -fore "#b07070"
2199 $ctext tag conf m12 -fore "#70b0f0"
2200 $ctext tag conf m13 -fore "#70f0b0"
2201 $ctext tag conf m14 -fore "#f0b070"
2202 $ctext tag conf m15 -fore "#ff70b0"
2203 $ctext tag conf mmax -fore darkgrey
2204 set mergemax 16
2205 $ctext tag conf mresult -font textfontbold
2206 $ctext tag conf msep -font textfontbold
2207 $ctext tag conf found -back yellow
2209 .pwbottom add .bleft
2210 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2212 # lower right
2213 frame .bright
2214 frame .bright.mode
2215 radiobutton .bright.mode.patch -text [mc "Patch"] \
2216 -command reselectline -variable cmitmode -value "patch"
2217 radiobutton .bright.mode.tree -text [mc "Tree"] \
2218 -command reselectline -variable cmitmode -value "tree"
2219 grid .bright.mode.patch .bright.mode.tree -sticky ew
2220 pack .bright.mode -side top -fill x
2221 set cflist .bright.cfiles
2222 set indent [font measure mainfont "nn"]
2223 text $cflist \
2224 -selectbackground $selectbgcolor \
2225 -background $bgcolor -foreground $fgcolor \
2226 -font mainfont \
2227 -tabs [list $indent [expr {2 * $indent}]] \
2228 -yscrollcommand ".bright.sb set" \
2229 -cursor [. cget -cursor] \
2230 -spacing1 1 -spacing3 1
2231 lappend bglist $cflist
2232 lappend fglist $cflist
2233 scrollbar .bright.sb -command "$cflist yview"
2234 pack .bright.sb -side right -fill y
2235 pack $cflist -side left -fill both -expand 1
2236 $cflist tag configure highlight \
2237 -background [$cflist cget -selectbackground]
2238 $cflist tag configure bold -font mainfontbold
2240 .pwbottom add .bright
2241 .ctop add .pwbottom
2243 # restore window width & height if known
2244 if {[info exists geometry(main)]} {
2245 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2246 if {$w > [winfo screenwidth .]} {
2247 set w [winfo screenwidth .]
2248 }
2249 if {$h > [winfo screenheight .]} {
2250 set h [winfo screenheight .]
2251 }
2252 wm geometry . "${w}x$h"
2253 }
2254 }
2256 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2257 wm state . $geometry(state)
2258 }
2260 if {[tk windowingsystem] eq {aqua}} {
2261 set M1B M1
2262 set ::BM "3"
2263 } else {
2264 set M1B Control
2265 set ::BM "2"
2266 }
2268 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2269 pack .ctop -fill both -expand 1
2270 bindall <1> {selcanvline %W %x %y}
2271 #bindall <B1-Motion> {selcanvline %W %x %y}
2272 if {[tk windowingsystem] == "win32"} {
2273 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2274 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2275 } else {
2276 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2277 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2278 if {[tk windowingsystem] eq "aqua"} {
2279 bindall <MouseWheel> {
2280 set delta [expr {- (%D)}]
2281 allcanvs yview scroll $delta units
2282 }
2283 bindall <Shift-MouseWheel> {
2284 set delta [expr {- (%D)}]
2285 $canv xview scroll $delta units
2286 }
2287 }
2288 }
2289 bindall <$::BM> "canvscan mark %W %x %y"
2290 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2291 bindkey <Home> selfirstline
2292 bindkey <End> sellastline
2293 bind . <Key-Up> "selnextline -1"
2294 bind . <Key-Down> "selnextline 1"
2295 bind . <Shift-Key-Up> "dofind -1 0"
2296 bind . <Shift-Key-Down> "dofind 1 0"
2297 bindkey <Key-Right> "goforw"
2298 bindkey <Key-Left> "goback"
2299 bind . <Key-Prior> "selnextpage -1"
2300 bind . <Key-Next> "selnextpage 1"
2301 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2302 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2303 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2304 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2305 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2306 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2307 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2308 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2309 bindkey <Key-space> "$ctext yview scroll 1 pages"
2310 bindkey p "selnextline -1"
2311 bindkey n "selnextline 1"
2312 bindkey z "goback"
2313 bindkey x "goforw"
2314 bindkey i "selnextline -1"
2315 bindkey k "selnextline 1"
2316 bindkey j "goback"
2317 bindkey l "goforw"
2318 bindkey b prevfile
2319 bindkey d "$ctext yview scroll 18 units"
2320 bindkey u "$ctext yview scroll -18 units"
2321 bindkey / {focus $fstring}
2322 bindkey <Key-KP_Divide> {focus $fstring}
2323 bindkey <Key-Return> {dofind 1 1}
2324 bindkey ? {dofind -1 1}
2325 bindkey f nextfile
2326 bind . <F5> updatecommits
2327 bind . <$M1B-F5> reloadcommits
2328 bind . <F2> showrefs
2329 bind . <Shift-F4> {newview 0}
2330 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2331 bind . <F4> edit_or_newview
2332 bind . <$M1B-q> doquit
2333 bind . <$M1B-f> {dofind 1 1}
2334 bind . <$M1B-g> {dofind 1 0}
2335 bind . <$M1B-r> dosearchback
2336 bind . <$M1B-s> dosearch
2337 bind . <$M1B-equal> {incrfont 1}
2338 bind . <$M1B-plus> {incrfont 1}
2339 bind . <$M1B-KP_Add> {incrfont 1}
2340 bind . <$M1B-minus> {incrfont -1}
2341 bind . <$M1B-KP_Subtract> {incrfont -1}
2342 wm protocol . WM_DELETE_WINDOW doquit
2343 bind . <Destroy> {stop_backends}
2344 bind . <Button-1> "click %W"
2345 bind $fstring <Key-Return> {dofind 1 1}
2346 bind $sha1entry <Key-Return> {gotocommit; break}
2347 bind $sha1entry <<PasteSelection>> clearsha1
2348 bind $cflist <1> {sel_flist %W %x %y; break}
2349 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2350 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2351 global ctxbut
2352 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2353 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2355 set maincursor [. cget -cursor]
2356 set textcursor [$ctext cget -cursor]
2357 set curtextcursor $textcursor
2359 set rowctxmenu .rowctxmenu
2360 makemenu $rowctxmenu {
2361 {mc "Diff this -> selected" command {diffvssel 0}}
2362 {mc "Diff selected -> this" command {diffvssel 1}}
2363 {mc "Make patch" command mkpatch}
2364 {mc "Create tag" command mktag}
2365 {mc "Write commit to file" command writecommit}
2366 {mc "Create new branch" command mkbranch}
2367 {mc "Cherry-pick this commit" command cherrypick}
2368 {mc "Reset HEAD branch to here" command resethead}
2369 {mc "Mark this commit" command markhere}
2370 {mc "Return to mark" command gotomark}
2371 {mc "Find descendant of this and mark" command find_common_desc}
2372 {mc "Compare with marked commit" command compare_commits}
2373 }
2374 $rowctxmenu configure -tearoff 0
2376 set fakerowmenu .fakerowmenu
2377 makemenu $fakerowmenu {
2378 {mc "Diff this -> selected" command {diffvssel 0}}
2379 {mc "Diff selected -> this" command {diffvssel 1}}
2380 {mc "Make patch" command mkpatch}
2381 }
2382 $fakerowmenu configure -tearoff 0
2384 set headctxmenu .headctxmenu
2385 makemenu $headctxmenu {
2386 {mc "Check out this branch" command cobranch}
2387 {mc "Remove this branch" command rmbranch}
2388 }
2389 $headctxmenu configure -tearoff 0
2391 global flist_menu
2392 set flist_menu .flistctxmenu
2393 makemenu $flist_menu {
2394 {mc "Highlight this too" command {flist_hl 0}}
2395 {mc "Highlight this only" command {flist_hl 1}}
2396 {mc "External diff" command {external_diff}}
2397 {mc "Blame parent commit" command {external_blame 1}}
2398 }
2399 $flist_menu configure -tearoff 0
2401 global diff_menu
2402 set diff_menu .diffctxmenu
2403 makemenu $diff_menu {
2404 {mc "Show origin of this line" command show_line_source}
2405 {mc "Run git gui blame on this line" command {external_blame_diff}}
2406 }
2407 $diff_menu configure -tearoff 0
2408 }
2410 # Windows sends all mouse wheel events to the current focused window, not
2411 # the one where the mouse hovers, so bind those events here and redirect
2412 # to the correct window
2413 proc windows_mousewheel_redirector {W X Y D} {
2414 global canv canv2 canv3
2415 set w [winfo containing -displayof $W $X $Y]
2416 if {$w ne ""} {
2417 set u [expr {$D < 0 ? 5 : -5}]
2418 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2419 allcanvs yview scroll $u units
2420 } else {
2421 catch {
2422 $w yview scroll $u units
2423 }
2424 }
2425 }
2426 }
2428 # Update row number label when selectedline changes
2429 proc selectedline_change {n1 n2 op} {
2430 global selectedline rownumsel
2432 if {$selectedline eq {}} {
2433 set rownumsel {}
2434 } else {
2435 set rownumsel [expr {$selectedline + 1}]
2436 }
2437 }
2439 # mouse-2 makes all windows scan vertically, but only the one
2440 # the cursor is in scans horizontally
2441 proc canvscan {op w x y} {
2442 global canv canv2 canv3
2443 foreach c [list $canv $canv2 $canv3] {
2444 if {$c == $w} {
2445 $c scan $op $x $y
2446 } else {
2447 $c scan $op 0 $y
2448 }
2449 }
2450 }
2452 proc scrollcanv {cscroll f0 f1} {
2453 $cscroll set $f0 $f1
2454 drawvisible
2455 flushhighlights
2456 }
2458 # when we make a key binding for the toplevel, make sure
2459 # it doesn't get triggered when that key is pressed in the
2460 # find string entry widget.
2461 proc bindkey {ev script} {
2462 global entries
2463 bind . $ev $script
2464 set escript [bind Entry $ev]
2465 if {$escript == {}} {
2466 set escript [bind Entry <Key>]
2467 }
2468 foreach e $entries {
2469 bind $e $ev "$escript; break"
2470 }
2471 }
2473 # set the focus back to the toplevel for any click outside
2474 # the entry widgets
2475 proc click {w} {
2476 global ctext entries
2477 foreach e [concat $entries $ctext] {
2478 if {$w == $e} return
2479 }
2480 focus .
2481 }
2483 # Adjust the progress bar for a change in requested extent or canvas size
2484 proc adjustprogress {} {
2485 global progresscanv progressitem progresscoords
2486 global fprogitem fprogcoord lastprogupdate progupdatepending
2487 global rprogitem rprogcoord
2489 set w [expr {[winfo width $progresscanv] - 4}]
2490 set x0 [expr {$w * [lindex $progresscoords 0]}]
2491 set x1 [expr {$w * [lindex $progresscoords 1]}]
2492 set h [winfo height $progresscanv]
2493 $progresscanv coords $progressitem $x0 0 $x1 $h
2494 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2495 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2496 set now [clock clicks -milliseconds]
2497 if {$now >= $lastprogupdate + 100} {
2498 set progupdatepending 0
2499 update
2500 } elseif {!$progupdatepending} {
2501 set progupdatepending 1
2502 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2503 }
2504 }
2506 proc doprogupdate {} {
2507 global lastprogupdate progupdatepending
2509 if {$progupdatepending} {
2510 set progupdatepending 0
2511 set lastprogupdate [clock clicks -milliseconds]
2512 update
2513 }
2514 }
2516 proc savestuff {w} {
2517 global canv canv2 canv3 mainfont textfont uifont tabstop
2518 global stuffsaved findmergefiles maxgraphpct
2519 global maxwidth showneartags showlocalchanges
2520 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2521 global cmitmode wrapcomment datetimeformat limitdiffs
2522 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2523 global autoselect extdifftool perfile_attrs markbgcolor
2524 global hideremotes
2526 if {$stuffsaved} return
2527 if {![winfo viewable .]} return
2528 catch {
2529 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2530 set f [open "~/.gitk-new" w]
2531 if {$::tcl_platform(platform) eq {windows}} {
2532 file attributes "~/.gitk-new" -hidden true
2533 }
2534 puts $f [list set mainfont $mainfont]
2535 puts $f [list set textfont $textfont]
2536 puts $f [list set uifont $uifont]
2537 puts $f [list set tabstop $tabstop]
2538 puts $f [list set findmergefiles $findmergefiles]
2539 puts $f [list set maxgraphpct $maxgraphpct]
2540 puts $f [list set maxwidth $maxwidth]
2541 puts $f [list set cmitmode $cmitmode]
2542 puts $f [list set wrapcomment $wrapcomment]
2543 puts $f [list set autoselect $autoselect]
2544 puts $f [list set showneartags $showneartags]
2545 puts $f [list set hideremotes $hideremotes]
2546 puts $f [list set showlocalchanges $showlocalchanges]
2547 puts $f [list set datetimeformat $datetimeformat]
2548 puts $f [list set limitdiffs $limitdiffs]
2549 puts $f [list set uicolor $uicolor]
2550 puts $f [list set bgcolor $bgcolor]
2551 puts $f [list set fgcolor $fgcolor]
2552 puts $f [list set colors $colors]
2553 puts $f [list set diffcolors $diffcolors]
2554 puts $f [list set markbgcolor $markbgcolor]
2555 puts $f [list set diffcontext $diffcontext]
2556 puts $f [list set selectbgcolor $selectbgcolor]
2557 puts $f [list set extdifftool $extdifftool]
2558 puts $f [list set perfile_attrs $perfile_attrs]
2560 puts $f "set geometry(main) [wm geometry .]"
2561 puts $f "set geometry(state) [wm state .]"
2562 puts $f "set geometry(topwidth) [winfo width .tf]"
2563 puts $f "set geometry(topheight) [winfo height .tf]"
2564 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2565 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2566 puts $f "set geometry(botwidth) [winfo width .bleft]"
2567 puts $f "set geometry(botheight) [winfo height .bleft]"
2569 puts -nonewline $f "set permviews {"
2570 for {set v 0} {$v < $nextviewnum} {incr v} {
2571 if {$viewperm($v)} {
2572 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2573 }
2574 }
2575 puts $f "}"
2576 close $f
2577 file rename -force "~/.gitk-new" "~/.gitk"
2578 }
2579 set stuffsaved 1
2580 }
2582 proc resizeclistpanes {win w} {
2583 global oldwidth
2584 if {[info exists oldwidth($win)]} {
2585 set s0 [$win sash coord 0]
2586 set s1 [$win sash coord 1]
2587 if {$w < 60} {
2588 set sash0 [expr {int($w/2 - 2)}]
2589 set sash1 [expr {int($w*5/6 - 2)}]
2590 } else {
2591 set factor [expr {1.0 * $w / $oldwidth($win)}]
2592 set sash0 [expr {int($factor * [lindex $s0 0])}]
2593 set sash1 [expr {int($factor * [lindex $s1 0])}]
2594 if {$sash0 < 30} {
2595 set sash0 30
2596 }
2597 if {$sash1 < $sash0 + 20} {
2598 set sash1 [expr {$sash0 + 20}]
2599 }
2600 if {$sash1 > $w - 10} {
2601 set sash1 [expr {$w - 10}]
2602 if {$sash0 > $sash1 - 20} {
2603 set sash0 [expr {$sash1 - 20}]
2604 }
2605 }
2606 }
2607 $win sash place 0 $sash0 [lindex $s0 1]
2608 $win sash place 1 $sash1 [lindex $s1 1]
2609 }
2610 set oldwidth($win) $w
2611 }
2613 proc resizecdetpanes {win w} {
2614 global oldwidth
2615 if {[info exists oldwidth($win)]} {
2616 set s0 [$win sash coord 0]
2617 if {$w < 60} {
2618 set sash0 [expr {int($w*3/4 - 2)}]
2619 } else {
2620 set factor [expr {1.0 * $w / $oldwidth($win)}]
2621 set sash0 [expr {int($factor * [lindex $s0 0])}]
2622 if {$sash0 < 45} {
2623 set sash0 45
2624 }
2625 if {$sash0 > $w - 15} {
2626 set sash0 [expr {$w - 15}]
2627 }
2628 }
2629 $win sash place 0 $sash0 [lindex $s0 1]
2630 }
2631 set oldwidth($win) $w
2632 }
2634 proc allcanvs args {
2635 global canv canv2 canv3
2636 eval $canv $args
2637 eval $canv2 $args
2638 eval $canv3 $args
2639 }
2641 proc bindall {event action} {
2642 global canv canv2 canv3
2643 bind $canv $event $action
2644 bind $canv2 $event $action
2645 bind $canv3 $event $action
2646 }
2648 proc about {} {
2649 global uifont
2650 set w .about
2651 if {[winfo exists $w]} {
2652 raise $w
2653 return
2654 }
2655 toplevel $w
2656 wm title $w [mc "About gitk"]
2657 make_transient $w .
2658 message $w.m -text [mc "
2659 Gitk - a commit viewer for git
2661 Copyright © 2005-2008 Paul Mackerras
2663 Use and redistribute under the terms of the GNU General Public License"] \
2664 -justify center -aspect 400 -border 2 -bg white -relief groove
2665 pack $w.m -side top -fill x -padx 2 -pady 2
2666 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2667 pack $w.ok -side bottom
2668 bind $w <Visibility> "focus $w.ok"
2669 bind $w <Key-Escape> "destroy $w"
2670 bind $w <Key-Return> "destroy $w"
2671 }
2673 proc keys {} {
2674 set w .keys
2675 if {[winfo exists $w]} {
2676 raise $w
2677 return
2678 }
2679 if {[tk windowingsystem] eq {aqua}} {
2680 set M1T Cmd
2681 } else {
2682 set M1T Ctrl
2683 }
2684 toplevel $w
2685 wm title $w [mc "Gitk key bindings"]
2686 make_transient $w .
2687 message $w.m -text "
2688 [mc "Gitk key bindings:"]
2690 [mc "<%s-Q> Quit" $M1T]
2691 [mc "<Home> Move to first commit"]
2692 [mc "<End> Move to last commit"]
2693 [mc "<Up>, p, i Move up one commit"]
2694 [mc "<Down>, n, k Move down one commit"]
2695 [mc "<Left>, z, j Go back in history list"]
2696 [mc "<Right>, x, l Go forward in history list"]
2697 [mc "<PageUp> Move up one page in commit list"]
2698 [mc "<PageDown> Move down one page in commit list"]
2699 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2700 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2701 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2702 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2703 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2704 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2705 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2706 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2707 [mc "<Delete>, b Scroll diff view up one page"]
2708 [mc "<Backspace> Scroll diff view up one page"]
2709 [mc "<Space> Scroll diff view down one page"]
2710 [mc "u Scroll diff view up 18 lines"]
2711 [mc "d Scroll diff view down 18 lines"]
2712 [mc "<%s-F> Find" $M1T]
2713 [mc "<%s-G> Move to next find hit" $M1T]
2714 [mc "<Return> Move to next find hit"]
2715 [mc "/ Focus the search box"]
2716 [mc "? Move to previous find hit"]
2717 [mc "f Scroll diff view to next file"]
2718 [mc "<%s-S> Search for next hit in diff view" $M1T]
2719 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2720 [mc "<%s-KP+> Increase font size" $M1T]
2721 [mc "<%s-plus> Increase font size" $M1T]
2722 [mc "<%s-KP-> Decrease font size" $M1T]
2723 [mc "<%s-minus> Decrease font size" $M1T]
2724 [mc "<F5> Update"]
2725 " \
2726 -justify left -bg white -border 2 -relief groove
2727 pack $w.m -side top -fill both -padx 2 -pady 2
2728 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2729 bind $w <Key-Escape> [list destroy $w]
2730 pack $w.ok -side bottom
2731 bind $w <Visibility> "focus $w.ok"
2732 bind $w <Key-Escape> "destroy $w"
2733 bind $w <Key-Return> "destroy $w"
2734 }
2736 # Procedures for manipulating the file list window at the
2737 # bottom right of the overall window.
2739 proc treeview {w l openlevs} {
2740 global treecontents treediropen treeheight treeparent treeindex
2742 set ix 0
2743 set treeindex() 0
2744 set lev 0
2745 set prefix {}
2746 set prefixend -1
2747 set prefendstack {}
2748 set htstack {}
2749 set ht 0
2750 set treecontents() {}
2751 $w conf -state normal
2752 foreach f $l {
2753 while {[string range $f 0 $prefixend] ne $prefix} {
2754 if {$lev <= $openlevs} {
2755 $w mark set e:$treeindex($prefix) "end -1c"
2756 $w mark gravity e:$treeindex($prefix) left
2757 }
2758 set treeheight($prefix) $ht
2759 incr ht [lindex $htstack end]
2760 set htstack [lreplace $htstack end end]
2761 set prefixend [lindex $prefendstack end]
2762 set prefendstack [lreplace $prefendstack end end]
2763 set prefix [string range $prefix 0 $prefixend]
2764 incr lev -1
2765 }
2766 set tail [string range $f [expr {$prefixend+1}] end]
2767 while {[set slash [string first "/" $tail]] >= 0} {
2768 lappend htstack $ht
2769 set ht 0
2770 lappend prefendstack $prefixend
2771 incr prefixend [expr {$slash + 1}]
2772 set d [string range $tail 0 $slash]
2773 lappend treecontents($prefix) $d
2774 set oldprefix $prefix
2775 append prefix $d
2776 set treecontents($prefix) {}
2777 set treeindex($prefix) [incr ix]
2778 set treeparent($prefix) $oldprefix
2779 set tail [string range $tail [expr {$slash+1}] end]
2780 if {$lev <= $openlevs} {
2781 set ht 1
2782 set treediropen($prefix) [expr {$lev < $openlevs}]
2783 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2784 $w mark set d:$ix "end -1c"
2785 $w mark gravity d:$ix left
2786 set str "\n"
2787 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2788 $w insert end $str
2789 $w image create end -align center -image $bm -padx 1 \
2790 -name a:$ix
2791 $w insert end $d [highlight_tag $prefix]
2792 $w mark set s:$ix "end -1c"
2793 $w mark gravity s:$ix left
2794 }
2795 incr lev
2796 }
2797 if {$tail ne {}} {
2798 if {$lev <= $openlevs} {
2799 incr ht
2800 set str "\n"
2801 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2802 $w insert end $str
2803 $w insert end $tail [highlight_tag $f]
2804 }
2805 lappend treecontents($prefix) $tail
2806 }
2807 }
2808 while {$htstack ne {}} {
2809 set treeheight($prefix) $ht
2810 incr ht [lindex $htstack end]
2811 set htstack [lreplace $htstack end end]
2812 set prefixend [lindex $prefendstack end]
2813 set prefendstack [lreplace $prefendstack end end]
2814 set prefix [string range $prefix 0 $prefixend]
2815 }
2816 $w conf -state disabled
2817 }
2819 proc linetoelt {l} {
2820 global treeheight treecontents
2822 set y 2
2823 set prefix {}
2824 while {1} {
2825 foreach e $treecontents($prefix) {
2826 if {$y == $l} {
2827 return "$prefix$e"
2828 }
2829 set n 1
2830 if {[string index $e end] eq "/"} {
2831 set n $treeheight($prefix$e)
2832 if {$y + $n > $l} {
2833 append prefix $e
2834 incr y
2835 break
2836 }
2837 }
2838 incr y $n
2839 }
2840 }
2841 }
2843 proc highlight_tree {y prefix} {
2844 global treeheight treecontents cflist
2846 foreach e $treecontents($prefix) {
2847 set path $prefix$e
2848 if {[highlight_tag $path] ne {}} {
2849 $cflist tag add bold $y.0 "$y.0 lineend"
2850 }
2851 incr y
2852 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2853 set y [highlight_tree $y $path]
2854 }
2855 }
2856 return $y
2857 }
2859 proc treeclosedir {w dir} {
2860 global treediropen treeheight treeparent treeindex
2862 set ix $treeindex($dir)
2863 $w conf -state normal
2864 $w delete s:$ix e:$ix
2865 set treediropen($dir) 0
2866 $w image configure a:$ix -image tri-rt
2867 $w conf -state disabled
2868 set n [expr {1 - $treeheight($dir)}]
2869 while {$dir ne {}} {
2870 incr treeheight($dir) $n
2871 set dir $treeparent($dir)
2872 }
2873 }
2875 proc treeopendir {w dir} {
2876 global treediropen treeheight treeparent treecontents treeindex
2878 set ix $treeindex($dir)
2879 $w conf -state normal
2880 $w image configure a:$ix -image tri-dn
2881 $w mark set e:$ix s:$ix
2882 $w mark gravity e:$ix right
2883 set lev 0
2884 set str "\n"
2885 set n [llength $treecontents($dir)]
2886 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2887 incr lev
2888 append str "\t"
2889 incr treeheight($x) $n
2890 }
2891 foreach e $treecontents($dir) {
2892 set de $dir$e
2893 if {[string index $e end] eq "/"} {
2894 set iy $treeindex($de)
2895 $w mark set d:$iy e:$ix
2896 $w mark gravity d:$iy left
2897 $w insert e:$ix $str
2898 set treediropen($de) 0
2899 $w image create e:$ix -align center -image tri-rt -padx 1 \
2900 -name a:$iy
2901 $w insert e:$ix $e [highlight_tag $de]
2902 $w mark set s:$iy e:$ix
2903 $w mark gravity s:$iy left
2904 set treeheight($de) 1
2905 } else {
2906 $w insert e:$ix $str
2907 $w insert e:$ix $e [highlight_tag $de]
2908 }
2909 }
2910 $w mark gravity e:$ix right
2911 $w conf -state disabled
2912 set treediropen($dir) 1
2913 set top [lindex [split [$w index @0,0] .] 0]
2914 set ht [$w cget -height]
2915 set l [lindex [split [$w index s:$ix] .] 0]
2916 if {$l < $top} {
2917 $w yview $l.0
2918 } elseif {$l + $n + 1 > $top + $ht} {
2919 set top [expr {$l + $n + 2 - $ht}]
2920 if {$l < $top} {
2921 set top $l
2922 }
2923 $w yview $top.0
2924 }
2925 }
2927 proc treeclick {w x y} {
2928 global treediropen cmitmode ctext cflist cflist_top
2930 if {$cmitmode ne "tree"} return
2931 if {![info exists cflist_top]} return
2932 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2933 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2934 $cflist tag add highlight $l.0 "$l.0 lineend"
2935 set cflist_top $l
2936 if {$l == 1} {
2937 $ctext yview 1.0
2938 return
2939 }
2940 set e [linetoelt $l]
2941 if {[string index $e end] ne "/"} {
2942 showfile $e
2943 } elseif {$treediropen($e)} {
2944 treeclosedir $w $e
2945 } else {
2946 treeopendir $w $e
2947 }
2948 }
2950 proc setfilelist {id} {
2951 global treefilelist cflist jump_to_here
2953 treeview $cflist $treefilelist($id) 0
2954 if {$jump_to_here ne {}} {
2955 set f [lindex $jump_to_here 0]
2956 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2957 showfile $f
2958 }
2959 }
2960 }
2962 image create bitmap tri-rt -background black -foreground blue -data {
2963 #define tri-rt_width 13
2964 #define tri-rt_height 13
2965 static unsigned char tri-rt_bits[] = {
2966 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2967 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2968 0x00, 0x00};
2969 } -maskdata {
2970 #define tri-rt-mask_width 13
2971 #define tri-rt-mask_height 13
2972 static unsigned char tri-rt-mask_bits[] = {
2973 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2974 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2975 0x08, 0x00};
2976 }
2977 image create bitmap tri-dn -background black -foreground blue -data {
2978 #define tri-dn_width 13
2979 #define tri-dn_height 13
2980 static unsigned char tri-dn_bits[] = {
2981 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2982 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2983 0x00, 0x00};
2984 } -maskdata {
2985 #define tri-dn-mask_width 13
2986 #define tri-dn-mask_height 13
2987 static unsigned char tri-dn-mask_bits[] = {
2988 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2989 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2990 0x00, 0x00};
2991 }
2993 image create bitmap reficon-T -background black -foreground yellow -data {
2994 #define tagicon_width 13
2995 #define tagicon_height 9
2996 static unsigned char tagicon_bits[] = {
2997 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2998 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2999 } -maskdata {
3000 #define tagicon-mask_width 13
3001 #define tagicon-mask_height 9
3002 static unsigned char tagicon-mask_bits[] = {
3003 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3004 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3005 }
3006 set rectdata {
3007 #define headicon_width 13
3008 #define headicon_height 9
3009 static unsigned char headicon_bits[] = {
3010 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3011 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3012 }
3013 set rectmask {
3014 #define headicon-mask_width 13
3015 #define headicon-mask_height 9
3016 static unsigned char headicon-mask_bits[] = {
3017 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3018 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3019 }
3020 image create bitmap reficon-H -background black -foreground green \
3021 -data $rectdata -maskdata $rectmask
3022 image create bitmap reficon-o -background black -foreground "#ddddff" \
3023 -data $rectdata -maskdata $rectmask
3025 proc init_flist {first} {
3026 global cflist cflist_top difffilestart
3028 $cflist conf -state normal
3029 $cflist delete 0.0 end
3030 if {$first ne {}} {
3031 $cflist insert end $first
3032 set cflist_top 1
3033 $cflist tag add highlight 1.0 "1.0 lineend"
3034 } else {
3035 catch {unset cflist_top}
3036 }
3037 $cflist conf -state disabled
3038 set difffilestart {}
3039 }
3041 proc highlight_tag {f} {
3042 global highlight_paths
3044 foreach p $highlight_paths {
3045 if {[string match $p $f]} {
3046 return "bold"
3047 }
3048 }
3049 return {}
3050 }
3052 proc highlight_filelist {} {
3053 global cmitmode cflist
3055 $cflist conf -state normal
3056 if {$cmitmode ne "tree"} {
3057 set end [lindex [split [$cflist index end] .] 0]
3058 for {set l 2} {$l < $end} {incr l} {
3059 set line [$cflist get $l.0 "$l.0 lineend"]
3060 if {[highlight_tag $line] ne {}} {
3061 $cflist tag add bold $l.0 "$l.0 lineend"
3062 }
3063 }
3064 } else {
3065 highlight_tree 2 {}
3066 }
3067 $cflist conf -state disabled
3068 }
3070 proc unhighlight_filelist {} {
3071 global cflist
3073 $cflist conf -state normal
3074 $cflist tag remove bold 1.0 end
3075 $cflist conf -state disabled
3076 }
3078 proc add_flist {fl} {
3079 global cflist
3081 $cflist conf -state normal
3082 foreach f $fl {
3083 $cflist insert end "\n"
3084 $cflist insert end $f [highlight_tag $f]
3085 }
3086 $cflist conf -state disabled
3087 }
3089 proc sel_flist {w x y} {
3090 global ctext difffilestart cflist cflist_top cmitmode
3092 if {$cmitmode eq "tree"} return
3093 if {![info exists cflist_top]} return
3094 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3095 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3096 $cflist tag add highlight $l.0 "$l.0 lineend"
3097 set cflist_top $l
3098 if {$l == 1} {
3099 $ctext yview 1.0
3100 } else {
3101 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3102 }
3103 }
3105 proc pop_flist_menu {w X Y x y} {
3106 global ctext cflist cmitmode flist_menu flist_menu_file
3107 global treediffs diffids
3109 stopfinding
3110 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3111 if {$l <= 1} return
3112 if {$cmitmode eq "tree"} {
3113 set e [linetoelt $l]
3114 if {[string index $e end] eq "/"} return
3115 } else {
3116 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3117 }
3118 set flist_menu_file $e
3119 set xdiffstate "normal"
3120 if {$cmitmode eq "tree"} {
3121 set xdiffstate "disabled"
3122 }
3123 # Disable "External diff" item in tree mode
3124 $flist_menu entryconf 2 -state $xdiffstate
3125 tk_popup $flist_menu $X $Y
3126 }
3128 proc find_ctext_fileinfo {line} {
3129 global ctext_file_names ctext_file_lines
3131 set ok [bsearch $ctext_file_lines $line]
3132 set tline [lindex $ctext_file_lines $ok]
3134 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3135 return {}
3136 } else {
3137 return [list [lindex $ctext_file_names $ok] $tline]
3138 }
3139 }
3141 proc pop_diff_menu {w X Y x y} {
3142 global ctext diff_menu flist_menu_file
3143 global diff_menu_txtpos diff_menu_line
3144 global diff_menu_filebase
3146 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3147 set diff_menu_line [lindex $diff_menu_txtpos 0]
3148 # don't pop up the menu on hunk-separator or file-separator lines
3149 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3150 return
3151 }
3152 stopfinding
3153 set f [find_ctext_fileinfo $diff_menu_line]
3154 if {$f eq {}} return
3155 set flist_menu_file [lindex $f 0]
3156 set diff_menu_filebase [lindex $f 1]
3157 tk_popup $diff_menu $X $Y
3158 }
3160 proc flist_hl {only} {
3161 global flist_menu_file findstring gdttype
3163 set x [shellquote $flist_menu_file]
3164 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3165 set findstring $x
3166 } else {
3167 append findstring " " $x
3168 }
3169 set gdttype [mc "touching paths:"]
3170 }
3172 proc gitknewtmpdir {} {
3173 global diffnum gitktmpdir gitdir
3175 if {![info exists gitktmpdir]} {
3176 set gitktmpdir [file join [file dirname $gitdir] \
3177 [format ".gitk-tmp.%s" [pid]]]
3178 if {[catch {file mkdir $gitktmpdir} err]} {
3179 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3180 unset gitktmpdir
3181 return {}
3182 }
3183 set diffnum 0
3184 }
3185 incr diffnum
3186 set diffdir [file join $gitktmpdir $diffnum]
3187 if {[catch {file mkdir $diffdir} err]} {
3188 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3189 return {}
3190 }
3191 return $diffdir
3192 }
3194 proc save_file_from_commit {filename output what} {
3195 global nullfile
3197 if {[catch {exec git show $filename -- > $output} err]} {
3198 if {[string match "fatal: bad revision *" $err]} {
3199 return $nullfile
3200 }
3201 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3202 return {}
3203 }
3204 return $output
3205 }
3207 proc external_diff_get_one_file {diffid filename diffdir} {
3208 global nullid nullid2 nullfile
3209 global gitdir
3211 if {$diffid == $nullid} {
3212 set difffile [file join [file dirname $gitdir] $filename]
3213 if {[file exists $difffile]} {
3214 return $difffile
3215 }
3216 return $nullfile
3217 }
3218 if {$diffid == $nullid2} {
3219 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3220 return [save_file_from_commit :$filename $difffile index]
3221 }
3222 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3223 return [save_file_from_commit $diffid:$filename $difffile \
3224 "revision $diffid"]
3225 }
3227 proc external_diff {} {
3228 global nullid nullid2
3229 global flist_menu_file
3230 global diffids
3231 global extdifftool
3233 if {[llength $diffids] == 1} {
3234 # no reference commit given
3235 set diffidto [lindex $diffids 0]
3236 if {$diffidto eq $nullid} {
3237 # diffing working copy with index
3238 set diffidfrom $nullid2
3239 } elseif {$diffidto eq $nullid2} {
3240 # diffing index with HEAD
3241 set diffidfrom "HEAD"
3242 } else {
3243 # use first parent commit
3244 global parentlist selectedline
3245 set diffidfrom [lindex $parentlist $selectedline 0]
3246 }
3247 } else {
3248 set diffidfrom [lindex $diffids 0]
3249 set diffidto [lindex $diffids 1]
3250 }
3252 # make sure that several diffs wont collide
3253 set diffdir [gitknewtmpdir]
3254 if {$diffdir eq {}} return
3256 # gather files to diff
3257 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3258 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3260 if {$difffromfile ne {} && $difftofile ne {}} {
3261 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3262 if {[catch {set fl [open |$cmd r]} err]} {
3263 file delete -force $diffdir
3264 error_popup "$extdifftool: [mc "command failed:"] $err"
3265 } else {
3266 fconfigure $fl -blocking 0
3267 filerun $fl [list delete_at_eof $fl $diffdir]
3268 }
3269 }
3270 }
3272 proc find_hunk_blamespec {base line} {
3273 global ctext
3275 # Find and parse the hunk header
3276 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3277 if {$s_lix eq {}} return
3279 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3280 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3281 s_line old_specs osz osz1 new_line nsz]} {
3282 return
3283 }
3285 # base lines for the parents
3286 set base_lines [list $new_line]
3287 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3288 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3289 old_spec old_line osz]} {
3290 return
3291 }
3292 lappend base_lines $old_line
3293 }
3295 # Now scan the lines to determine offset within the hunk
3296 set max_parent [expr {[llength $base_lines]-2}]
3297 set dline 0
3298 set s_lno [lindex [split $s_lix "."] 0]
3300 # Determine if the line is removed
3301 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3302 if {[string match {[-+ ]*} $chunk]} {
3303 set removed_idx [string first "-" $chunk]
3304 # Choose a parent index
3305 if {$removed_idx >= 0} {
3306 set parent $removed_idx
3307 } else {
3308 set unchanged_idx [string first " " $chunk]
3309 if {$unchanged_idx >= 0} {
3310 set parent $unchanged_idx
3311 } else {
3312 # blame the current commit
3313 set parent -1
3314 }
3315 }
3316 # then count other lines that belong to it
3317 for {set i $line} {[incr i -1] > $s_lno} {} {
3318 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3319 # Determine if the line is removed
3320 set removed_idx [string first "-" $chunk]
3321 if {$parent >= 0} {
3322 set code [string index $chunk $parent]
3323 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3324 incr dline
3325 }
3326 } else {
3327 if {$removed_idx < 0} {
3328 incr dline
3329 }
3330 }
3331 }
3332 incr parent
3333 } else {
3334 set parent 0
3335 }
3337 incr dline [lindex $base_lines $parent]
3338 return [list $parent $dline]
3339 }
3341 proc external_blame_diff {} {
3342 global currentid cmitmode
3343 global diff_menu_txtpos diff_menu_line
3344 global diff_menu_filebase flist_menu_file
3346 if {$cmitmode eq "tree"} {
3347 set parent_idx 0
3348 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3349 } else {
3350 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3351 if {$hinfo ne {}} {
3352 set parent_idx [lindex $hinfo 0]
3353 set line [lindex $hinfo 1]
3354 } else {
3355 set parent_idx 0
3356 set line 0
3357 }
3358 }
3360 external_blame $parent_idx $line
3361 }
3363 # Find the SHA1 ID of the blob for file $fname in the index
3364 # at stage 0 or 2
3365 proc index_sha1 {fname} {
3366 set f [open [list | git ls-files -s $fname] r]
3367 while {[gets $f line] >= 0} {
3368 set info [lindex [split $line "\t"] 0]
3369 set stage [lindex $info 2]
3370 if {$stage eq "0" || $stage eq "2"} {
3371 close $f
3372 return [lindex $info 1]
3373 }
3374 }
3375 close $f
3376 return {}
3377 }
3379 # Turn an absolute path into one relative to the current directory
3380 proc make_relative {f} {
3381 set elts [file split $f]
3382 set here [file split [pwd]]
3383 set ei 0
3384 set hi 0
3385 set res {}
3386 foreach d $here {
3387 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3388 lappend res ".."
3389 } else {
3390 incr ei
3391 }
3392 incr hi
3393 }
3394 set elts [concat $res [lrange $elts $ei end]]
3395 return [eval file join $elts]
3396 }
3398 proc external_blame {parent_idx {line {}}} {
3399 global flist_menu_file gitdir
3400 global nullid nullid2
3401 global parentlist selectedline currentid
3403 if {$parent_idx > 0} {
3404 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3405 } else {
3406 set base_commit $currentid
3407 }
3409 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3410 error_popup [mc "No such commit"]
3411 return
3412 }
3414 set cmdline [list git gui blame]
3415 if {$line ne {} && $line > 1} {
3416 lappend cmdline "--line=$line"
3417 }
3418 set f [file join [file dirname $gitdir] $flist_menu_file]
3419 # Unfortunately it seems git gui blame doesn't like
3420 # being given an absolute path...
3421 set f [make_relative $f]
3422 lappend cmdline $base_commit $f
3423 if {[catch {eval exec $cmdline &} err]} {
3424 error_popup "[mc "git gui blame: command failed:"] $err"
3425 }
3426 }
3428 proc show_line_source {} {
3429 global cmitmode currentid parents curview blamestuff blameinst
3430 global diff_menu_line diff_menu_filebase flist_menu_file
3431 global nullid nullid2 gitdir
3433 set from_index {}
3434 if {$cmitmode eq "tree"} {
3435 set id $currentid
3436 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3437 } else {
3438 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3439 if {$h eq {}} return
3440 set pi [lindex $h 0]
3441 if {$pi == 0} {
3442 mark_ctext_line $diff_menu_line
3443 return
3444 }
3445 incr pi -1
3446 if {$currentid eq $nullid} {
3447 if {$pi > 0} {
3448 # must be a merge in progress...
3449 if {[catch {
3450 # get the last line from .git/MERGE_HEAD
3451 set f [open [file join $gitdir MERGE_HEAD] r]
3452 set id [lindex [split [read $f] "\n"] end-1]
3453 close $f
3454 } err]} {
3455 error_popup [mc "Couldn't read merge head: %s" $err]
3456 return
3457 }
3458 } elseif {$parents($curview,$currentid) eq $nullid2} {
3459 # need to do the blame from the index
3460 if {[catch {
3461 set from_index [index_sha1 $flist_menu_file]
3462 } err]} {
3463 error_popup [mc "Error reading index: %s" $err]
3464 return
3465 }
3466 } else {
3467 set id $parents($curview,$currentid)
3468 }
3469 } else {
3470 set id [lindex $parents($curview,$currentid) $pi]
3471 }
3472 set line [lindex $h 1]
3473 }
3474 set blameargs {}
3475 if {$from_index ne {}} {
3476 lappend blameargs | git cat-file blob $from_index
3477 }
3478 lappend blameargs | git blame -p -L$line,+1
3479 if {$from_index ne {}} {
3480 lappend blameargs --contents -
3481 } else {
3482 lappend blameargs $id
3483 }
3484 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3485 if {[catch {
3486 set f [open $blameargs r]
3487 } err]} {
3488 error_popup [mc "Couldn't start git blame: %s" $err]
3489 return
3490 }
3491 nowbusy blaming [mc "Searching"]
3492 fconfigure $f -blocking 0
3493 set i [reg_instance $f]
3494 set blamestuff($i) {}
3495 set blameinst $i
3496 filerun $f [list read_line_source $f $i]
3497 }
3499 proc stopblaming {} {
3500 global blameinst
3502 if {[info exists blameinst]} {
3503 stop_instance $blameinst
3504 unset blameinst
3505 notbusy blaming
3506 }
3507 }
3509 proc read_line_source {fd inst} {
3510 global blamestuff curview commfd blameinst nullid nullid2
3512 while {[gets $fd line] >= 0} {
3513 lappend blamestuff($inst) $line
3514 }
3515 if {![eof $fd]} {
3516 return 1
3517 }
3518 unset commfd($inst)
3519 unset blameinst
3520 notbusy blaming
3521 fconfigure $fd -blocking 1
3522 if {[catch {close $fd} err]} {
3523 error_popup [mc "Error running git blame: %s" $err]
3524 return 0
3525 }
3527 set fname {}
3528 set line [split [lindex $blamestuff($inst) 0] " "]
3529 set id [lindex $line 0]
3530 set lnum [lindex $line 1]
3531 if {[string length $id] == 40 && [string is xdigit $id] &&
3532 [string is digit -strict $lnum]} {
3533 # look for "filename" line
3534 foreach l $blamestuff($inst) {
3535 if {[string match "filename *" $l]} {
3536 set fname [string range $l 9 end]
3537 break
3538 }
3539 }
3540 }
3541 if {$fname ne {}} {
3542 # all looks good, select it
3543 if {$id eq $nullid} {
3544 # blame uses all-zeroes to mean not committed,
3545 # which would mean a change in the index
3546 set id $nullid2
3547 }
3548 if {[commitinview $id $curview]} {
3549 selectline [rowofcommit $id] 1 [list $fname $lnum]
3550 } else {
3551 error_popup [mc "That line comes from commit %s, \
3552 which is not in this view" [shortids $id]]
3553 }
3554 } else {
3555 puts "oops couldn't parse git blame output"
3556 }
3557 return 0
3558 }
3560 # delete $dir when we see eof on $f (presumably because the child has exited)
3561 proc delete_at_eof {f dir} {
3562 while {[gets $f line] >= 0} {}
3563 if {[eof $f]} {
3564 if {[catch {close $f} err]} {
3565 error_popup "[mc "External diff viewer failed:"] $err"
3566 }
3567 file delete -force $dir
3568 return 0
3569 }
3570 return 1
3571 }
3573 # Functions for adding and removing shell-type quoting
3575 proc shellquote {str} {
3576 if {![string match "*\['\"\\ \t]*" $str]} {
3577 return $str
3578 }
3579 if {![string match "*\['\"\\]*" $str]} {
3580 return "\"$str\""
3581 }
3582 if {![string match "*'*" $str]} {
3583 return "'$str'"
3584 }
3585 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3586 }
3588 proc shellarglist {l} {
3589 set str {}
3590 foreach a $l {
3591 if {$str ne {}} {
3592 append str " "
3593 }
3594 append str [shellquote $a]
3595 }
3596 return $str
3597 }
3599 proc shelldequote {str} {
3600 set ret {}
3601 set used -1
3602 while {1} {
3603 incr used
3604 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3605 append ret [string range $str $used end]
3606 set used [string length $str]
3607 break
3608 }
3609 set first [lindex $first 0]
3610 set ch [string index $str $first]
3611 if {$first > $used} {
3612 append ret [string range $str $used [expr {$first - 1}]]
3613 set used $first
3614 }
3615 if {$ch eq " " || $ch eq "\t"} break
3616 incr used
3617 if {$ch eq "'"} {
3618 set first [string first "'" $str $used]
3619 if {$first < 0} {
3620 error "unmatched single-quote"
3621 }
3622 append ret [string range $str $used [expr {$first - 1}]]
3623 set used $first
3624 continue
3625 }
3626 if {$ch eq "\\"} {
3627 if {$used >= [string length $str]} {
3628 error "trailing backslash"
3629 }
3630 append ret [string index $str $used]
3631 continue
3632 }
3633 # here ch == "\""
3634 while {1} {
3635 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3636 error "unmatched double-quote"
3637 }
3638 set first [lindex $first 0]
3639 set ch [string index $str $first]
3640 if {$first > $used} {
3641 append ret [string range $str $used [expr {$first - 1}]]
3642 set used $first
3643 }
3644 if {$ch eq "\""} break
3645 incr used
3646 append ret [string index $str $used]
3647 incr used
3648 }
3649 }
3650 return [list $used $ret]
3651 }
3653 proc shellsplit {str} {
3654 set l {}
3655 while {1} {
3656 set str [string trimleft $str]
3657 if {$str eq {}} break
3658 set dq [shelldequote $str]
3659 set n [lindex $dq 0]
3660 set word [lindex $dq 1]
3661 set str [string range $str $n end]
3662 lappend l $word
3663 }
3664 return $l
3665 }
3667 # Code to implement multiple views
3669 proc newview {ishighlight} {
3670 global nextviewnum newviewname newishighlight
3671 global revtreeargs viewargscmd newviewopts curview
3673 set newishighlight $ishighlight
3674 set top .gitkview
3675 if {[winfo exists $top]} {
3676 raise $top
3677 return
3678 }
3679 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3680 set newviewopts($nextviewnum,perm) 0
3681 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3682 decode_view_opts $nextviewnum $revtreeargs
3683 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3684 }
3686 set known_view_options {
3687 {perm b . {} {mc "Remember this view"}}
3688 {reflabel l + {} {mc "References (space separated list):"}}
3689 {refs t15 .. {} {mc "Branches & tags:"}}
3690 {allrefs b *. "--all" {mc "All refs"}}
3691 {branches b . "--branches" {mc "All (local) branches"}}
3692 {tags b . "--tags" {mc "All tags"}}
3693 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3694 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3695 {author t15 .. "--author=*" {mc "Author:"}}
3696 {committer t15 . "--committer=*" {mc "Committer:"}}
3697 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3698 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3699 {changes_l l + {} {mc "Changes to Files:"}}
3700 {pickaxe_s r0 . {} {mc "Fixed String"}}
3701 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3702 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3703 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3704 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3705 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3706 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3707 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3708 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3709 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3710 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3711 {lright b . "--left-right" {mc "Mark branch sides"}}
3712 {first b . "--first-parent" {mc "Limit to first parent"}}
3713 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3714 {args t50 *. {} {mc "Additional arguments to git log:"}}
3715 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3716 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3717 }
3719 proc encode_view_opts {n} {
3720 global known_view_options newviewopts
3722 set rargs [list]
3723 foreach opt $known_view_options {
3724 set patterns [lindex $opt 3]
3725 if {$patterns eq {}} continue
3726 set pattern [lindex $patterns 0]
3728 if {[lindex $opt 1] eq "b"} {
3729 set val $newviewopts($n,[lindex $opt 0])
3730 if {$val} {
3731 lappend rargs $pattern
3732 }
3733 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3734 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3735 set val $newviewopts($n,$button_id)
3736 if {$val eq $value} {
3737 lappend rargs $pattern
3738 }
3739 } else {
3740 set val $newviewopts($n,[lindex $opt 0])
3741 set val [string trim $val]
3742 if {$val ne {}} {
3743 set pfix [string range $pattern 0 end-1]
3744 lappend rargs $pfix$val
3745 }
3746 }
3747 }
3748 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3749 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3750 }
3752 proc decode_view_opts {n view_args} {
3753 global known_view_options newviewopts
3755 foreach opt $known_view_options {
3756 set id [lindex $opt 0]
3757 if {[lindex $opt 1] eq "b"} {
3758 # Checkboxes
3759 set val 0
3760 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3761 # Radiobuttons
3762 regexp {^(.*_)} $id uselessvar id
3763 set val 0
3764 } else {
3765 # Text fields
3766 set val {}
3767 }
3768 set newviewopts($n,$id) $val
3769 }
3770 set oargs [list]
3771 set refargs [list]
3772 foreach arg $view_args {
3773 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3774 && ![info exists found(limit)]} {
3775 set newviewopts($n,limit) $cnt
3776 set found(limit) 1
3777 continue
3778 }
3779 catch { unset val }
3780 foreach opt $known_view_options {
3781 set id [lindex $opt 0]
3782 if {[info exists found($id)]} continue
3783 foreach pattern [lindex $opt 3] {
3784 if {![string match $pattern $arg]} continue
3785 if {[lindex $opt 1] eq "b"} {
3786 # Check buttons
3787 set val 1
3788 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3789 # Radio buttons
3790 regexp {^(.*_)} $id uselessvar id
3791 set val $num
3792 } else {
3793 # Text input fields
3794 set size [string length $pattern]
3795 set val [string range $arg [expr {$size-1}] end]
3796 }
3797 set newviewopts($n,$id) $val
3798 set found($id) 1
3799 break
3800 }
3801 if {[info exists val]} break
3802 }
3803 if {[info exists val]} continue
3804 if {[regexp {^-} $arg]} {
3805 lappend oargs $arg
3806 } else {
3807 lappend refargs $arg
3808 }
3809 }
3810 set newviewopts($n,refs) [shellarglist $refargs]
3811 set newviewopts($n,args) [shellarglist $oargs]
3812 }
3814 proc edit_or_newview {} {
3815 global curview
3817 if {$curview > 0} {
3818 editview
3819 } else {
3820 newview 0
3821 }
3822 }
3824 proc editview {} {
3825 global curview
3826 global viewname viewperm newviewname newviewopts
3827 global viewargs viewargscmd
3829 set top .gitkvedit-$curview
3830 if {[winfo exists $top]} {
3831 raise $top
3832 return
3833 }
3834 set newviewname($curview) $viewname($curview)
3835 set newviewopts($curview,perm) $viewperm($curview)
3836 set newviewopts($curview,cmd) $viewargscmd($curview)
3837 decode_view_opts $curview $viewargs($curview)
3838 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3839 }
3841 proc vieweditor {top n title} {
3842 global newviewname newviewopts viewfiles bgcolor
3843 global known_view_options
3845 toplevel $top
3846 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3847 make_transient $top .
3849 # View name
3850 frame $top.nfr
3851 label $top.nl -text [mc "View Name:"]
3852 entry $top.name -width 20 -textvariable newviewname($n)
3853 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3854 pack $top.nl -in $top.nfr -side left -padx {0 5}
3855 pack $top.name -in $top.nfr -side left -padx {0 25}
3857 # View options
3858 set cframe $top.nfr
3859 set cexpand 0
3860 set cnt 0
3861 foreach opt $known_view_options {
3862 set id [lindex $opt 0]
3863 set type [lindex $opt 1]
3864 set flags [lindex $opt 2]
3865 set title [eval [lindex $opt 4]]
3866 set lxpad 0
3868 if {$flags eq "+" || $flags eq "*"} {
3869 set cframe $top.fr$cnt
3870 incr cnt
3871 frame $cframe
3872 pack $cframe -in $top -fill x -pady 3 -padx 3
3873 set cexpand [expr {$flags eq "*"}]
3874 } elseif {$flags eq ".." || $flags eq "*."} {
3875 set cframe $top.fr$cnt
3876 incr cnt
3877 frame $cframe
3878 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
3879 set cexpand [expr {$flags eq "*."}]
3880 } else {
3881 set lxpad 5
3882 }
3884 if {$type eq "l"} {
3885 label $cframe.l_$id -text $title
3886 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
3887 } elseif {$type eq "b"} {
3888 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3889 pack $cframe.c_$id -in $cframe -side left \
3890 -padx [list $lxpad 0] -expand $cexpand -anchor w
3891 } elseif {[regexp {^r(\d+)$} $type type sz]} {
3892 regexp {^(.*_)} $id uselessvar button_id
3893 radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
3894 pack $cframe.c_$id -in $cframe -side left \
3895 -padx [list $lxpad 0] -expand $cexpand -anchor w
3896 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3897 message $cframe.l_$id -aspect 1500 -text $title
3898 entry $cframe.e_$id -width $sz -background $bgcolor \
3899 -textvariable newviewopts($n,$id)
3900 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3901 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3902 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3903 message $cframe.l_$id -aspect 1500 -text $title
3904 entry $cframe.e_$id -width $sz -background $bgcolor \
3905 -textvariable newviewopts($n,$id)
3906 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3907 pack $cframe.e_$id -in $cframe -side top -fill x
3908 } elseif {$type eq "path"} {
3909 message $top.l -aspect 1500 -text $title
3910 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
3911 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3912 if {[info exists viewfiles($n)]} {
3913 foreach f $viewfiles($n) {
3914 $top.t insert end $f
3915 $top.t insert end "\n"
3916 }
3917 $top.t delete {end - 1c} end
3918 $top.t mark set insert 0.0
3919 }
3920 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3921 }
3922 }
3924 frame $top.buts
3925 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3926 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3927 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3928 bind $top <Control-Return> [list newviewok $top $n]
3929 bind $top <F5> [list newviewok $top $n 1]
3930 bind $top <Escape> [list destroy $top]
3931 grid $top.buts.ok $top.buts.apply $top.buts.can
3932 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3933 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3934 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3935 pack $top.buts -in $top -side top -fill x
3936 focus $top.t
3937 }
3939 proc doviewmenu {m first cmd op argv} {
3940 set nmenu [$m index end]
3941 for {set i $first} {$i <= $nmenu} {incr i} {
3942 if {[$m entrycget $i -command] eq $cmd} {
3943 eval $m $op $i $argv
3944 break
3945 }
3946 }
3947 }
3949 proc allviewmenus {n op args} {
3950 # global viewhlmenu
3952 doviewmenu .bar.view 5 [list showview $n] $op $args
3953 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3954 }
3956 proc newviewok {top n {apply 0}} {
3957 global nextviewnum newviewperm newviewname newishighlight
3958 global viewname viewfiles viewperm selectedview curview
3959 global viewargs viewargscmd newviewopts viewhlmenu
3961 if {[catch {
3962 set newargs [encode_view_opts $n]
3963 } err]} {
3964 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3965 return
3966 }
3967 set files {}
3968 foreach f [split [$top.t get 0.0 end] "\n"] {
3969 set ft [string trim $f]
3970 if {$ft ne {}} {
3971 lappend files $ft
3972 }
3973 }
3974 if {![info exists viewfiles($n)]} {
3975 # creating a new view
3976 incr nextviewnum
3977 set viewname($n) $newviewname($n)
3978 set viewperm($n) $newviewopts($n,perm)
3979 set viewfiles($n) $files
3980 set viewargs($n) $newargs
3981 set viewargscmd($n) $newviewopts($n,cmd)
3982 addviewmenu $n
3983 if {!$newishighlight} {
3984 run showview $n
3985 } else {
3986 run addvhighlight $n
3987 }
3988 } else {
3989 # editing an existing view
3990 set viewperm($n) $newviewopts($n,perm)
3991 if {$newviewname($n) ne $viewname($n)} {
3992 set viewname($n) $newviewname($n)
3993 doviewmenu .bar.view 5 [list showview $n] \
3994 entryconf [list -label $viewname($n)]
3995 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3996 # entryconf [list -label $viewname($n) -value $viewname($n)]
3997 }
3998 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3999 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4000 set viewfiles($n) $files
4001 set viewargs($n) $newargs
4002 set viewargscmd($n) $newviewopts($n,cmd)
4003 if {$curview == $n} {
4004 run reloadcommits
4005 }
4006 }
4007 }
4008 if {$apply} return
4009 catch {destroy $top}
4010 }
4012 proc delview {} {
4013 global curview viewperm hlview selectedhlview
4015 if {$curview == 0} return
4016 if {[info exists hlview] && $hlview == $curview} {
4017 set selectedhlview [mc "None"]
4018 unset hlview
4019 }
4020 allviewmenus $curview delete
4021 set viewperm($curview) 0
4022 showview 0
4023 }
4025 proc addviewmenu {n} {
4026 global viewname viewhlmenu
4028 .bar.view add radiobutton -label $viewname($n) \
4029 -command [list showview $n] -variable selectedview -value $n
4030 #$viewhlmenu add radiobutton -label $viewname($n) \
4031 # -command [list addvhighlight $n] -variable selectedhlview
4032 }
4034 proc showview {n} {
4035 global curview cached_commitrow ordertok
4036 global displayorder parentlist rowidlist rowisopt rowfinal
4037 global colormap rowtextx nextcolor canvxmax
4038 global numcommits viewcomplete
4039 global selectedline currentid canv canvy0
4040 global treediffs
4041 global pending_select mainheadid
4042 global commitidx
4043 global selectedview
4044 global hlview selectedhlview commitinterest
4046 if {$n == $curview} return
4047 set selid {}
4048 set ymax [lindex [$canv cget -scrollregion] 3]
4049 set span [$canv yview]
4050 set ytop [expr {[lindex $span 0] * $ymax}]
4051 set ybot [expr {[lindex $span 1] * $ymax}]
4052 set yscreen [expr {($ybot - $ytop) / 2}]
4053 if {$selectedline ne {}} {
4054 set selid $currentid
4055 set y [yc $selectedline]
4056 if {$ytop < $y && $y < $ybot} {
4057 set yscreen [expr {$y - $ytop}]
4058 }
4059 } elseif {[info exists pending_select]} {
4060 set selid $pending_select
4061 unset pending_select
4062 }
4063 unselectline
4064 normalline
4065 catch {unset treediffs}
4066 clear_display
4067 if {[info exists hlview] && $hlview == $n} {
4068 unset hlview
4069 set selectedhlview [mc "None"]
4070 }
4071 catch {unset commitinterest}
4072 catch {unset cached_commitrow}
4073 catch {unset ordertok}
4075 set curview $n
4076 set selectedview $n
4077 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4078 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4080 run refill_reflist
4081 if {![info exists viewcomplete($n)]} {
4082 getcommits $selid
4083 return
4084 }
4086 set displayorder {}
4087 set parentlist {}
4088 set rowidlist {}
4089 set rowisopt {}
4090 set rowfinal {}
4091 set numcommits $commitidx($n)
4093 catch {unset colormap}
4094 catch {unset rowtextx}
4095 set nextcolor 0
4096 set canvxmax [$canv cget -width]
4097 set curview $n
4098 set row 0
4099 setcanvscroll
4100 set yf 0
4101 set row {}
4102 if {$selid ne {} && [commitinview $selid $n]} {
4103 set row [rowofcommit $selid]
4104 # try to get the selected row in the same position on the screen
4105 set ymax [lindex [$canv cget -scrollregion] 3]
4106 set ytop [expr {[yc $row] - $yscreen}]
4107 if {$ytop < 0} {
4108 set ytop 0
4109 }
4110 set yf [expr {$ytop * 1.0 / $ymax}]
4111 }
4112 allcanvs yview moveto $yf
4113 drawvisible
4114 if {$row ne {}} {
4115 selectline $row 0
4116 } elseif {!$viewcomplete($n)} {
4117 reset_pending_select $selid
4118 } else {
4119 reset_pending_select {}
4121 if {[commitinview $pending_select $curview]} {
4122 selectline [rowofcommit $pending_select] 1
4123 } else {
4124 set row [first_real_row]
4125 if {$row < $numcommits} {
4126 selectline $row 0
4127 }
4128 }
4129 }
4130 if {!$viewcomplete($n)} {
4131 if {$numcommits == 0} {
4132 show_status [mc "Reading commits..."]
4133 }
4134 } elseif {$numcommits == 0} {
4135 show_status [mc "No commits selected"]
4136 }
4137 }
4139 # Stuff relating to the highlighting facility
4141 proc ishighlighted {id} {
4142 global vhighlights fhighlights nhighlights rhighlights
4144 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4145 return $nhighlights($id)
4146 }
4147 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4148 return $vhighlights($id)
4149 }
4150 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4151 return $fhighlights($id)
4152 }
4153 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4154 return $rhighlights($id)
4155 }
4156 return 0
4157 }
4159 proc bolden {id font} {
4160 global canv linehtag currentid boldids need_redisplay markedid
4162 # need_redisplay = 1 means the display is stale and about to be redrawn
4163 if {$need_redisplay} return
4164 lappend boldids $id
4165 $canv itemconf $linehtag($id) -font $font
4166 if {[info exists currentid] && $id eq $currentid} {
4167 $canv delete secsel
4168 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4169 -outline {{}} -tags secsel \
4170 -fill [$canv cget -selectbackground]]
4171 $canv lower $t
4172 }
4173 if {[info exists markedid] && $id eq $markedid} {
4174 make_idmark $id
4175 }
4176 }
4178 proc bolden_name {id font} {
4179 global canv2 linentag currentid boldnameids need_redisplay
4181 if {$need_redisplay} return
4182 lappend boldnameids $id
4183 $canv2 itemconf $linentag($id) -font $font
4184 if {[info exists currentid] && $id eq $currentid} {
4185 $canv2 delete secsel
4186 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4187 -outline {{}} -tags secsel \
4188 -fill [$canv2 cget -selectbackground]]
4189 $canv2 lower $t
4190 }
4191 }
4193 proc unbolden {} {
4194 global boldids
4196 set stillbold {}
4197 foreach id $boldids {
4198 if {![ishighlighted $id]} {
4199 bolden $id mainfont
4200 } else {
4201 lappend stillbold $id
4202 }
4203 }
4204 set boldids $stillbold
4205 }
4207 proc addvhighlight {n} {
4208 global hlview viewcomplete curview vhl_done commitidx
4210 if {[info exists hlview]} {
4211 delvhighlight
4212 }
4213 set hlview $n
4214 if {$n != $curview && ![info exists viewcomplete($n)]} {
4215 start_rev_list $n
4216 }
4217 set vhl_done $commitidx($hlview)
4218 if {$vhl_done > 0} {
4219 drawvisible
4220 }
4221 }
4223 proc delvhighlight {} {
4224 global hlview vhighlights
4226 if {![info exists hlview]} return
4227 unset hlview
4228 catch {unset vhighlights}
4229 unbolden
4230 }
4232 proc vhighlightmore {} {
4233 global hlview vhl_done commitidx vhighlights curview
4235 set max $commitidx($hlview)
4236 set vr [visiblerows]
4237 set r0 [lindex $vr 0]
4238 set r1 [lindex $vr 1]
4239 for {set i $vhl_done} {$i < $max} {incr i} {
4240 set id [commitonrow $i $hlview]
4241 if {[commitinview $id $curview]} {
4242 set row [rowofcommit $id]
4243 if {$r0 <= $row && $row <= $r1} {
4244 if {![highlighted $row]} {
4245 bolden $id mainfontbold
4246 }
4247 set vhighlights($id) 1
4248 }
4249 }
4250 }
4251 set vhl_done $max
4252 return 0
4253 }
4255 proc askvhighlight {row id} {
4256 global hlview vhighlights iddrawn
4258 if {[commitinview $id $hlview]} {
4259 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4260 bolden $id mainfontbold
4261 }
4262 set vhighlights($id) 1
4263 } else {
4264 set vhighlights($id) 0
4265 }
4266 }
4268 proc hfiles_change {} {
4269 global highlight_files filehighlight fhighlights fh_serial
4270 global highlight_paths
4272 if {[info exists filehighlight]} {
4273 # delete previous highlights
4274 catch {close $filehighlight}
4275 unset filehighlight
4276 catch {unset fhighlights}
4277 unbolden
4278 unhighlight_filelist
4279 }
4280 set highlight_paths {}
4281 after cancel do_file_hl $fh_serial
4282 incr fh_serial
4283 if {$highlight_files ne {}} {
4284 after 300 do_file_hl $fh_serial
4285 }
4286 }
4288 proc gdttype_change {name ix op} {
4289 global gdttype highlight_files findstring findpattern
4291 stopfinding
4292 if {$findstring ne {}} {
4293 if {$gdttype eq [mc "containing:"]} {
4294 if {$highlight_files ne {}} {
4295 set highlight_files {}
4296 hfiles_change
4297 }
4298 findcom_change
4299 } else {
4300 if {$findpattern ne {}} {
4301 set findpattern {}
4302 findcom_change
4303 }
4304 set highlight_files $findstring
4305 hfiles_change
4306 }
4307 drawvisible
4308 }
4309 # enable/disable findtype/findloc menus too
4310 }
4312 proc find_change {name ix op} {
4313 global gdttype findstring highlight_files
4315 stopfinding
4316 if {$gdttype eq [mc "containing:"]} {
4317 findcom_change
4318 } else {
4319 if {$highlight_files ne $findstring} {
4320 set highlight_files $findstring
4321 hfiles_change
4322 }
4323 }
4324 drawvisible
4325 }
4327 proc findcom_change args {
4328 global nhighlights boldnameids
4329 global findpattern findtype findstring gdttype
4331 stopfinding
4332 # delete previous highlights, if any
4333 foreach id $boldnameids {
4334 bolden_name $id mainfont
4335 }
4336 set boldnameids {}
4337 catch {unset nhighlights}
4338 unbolden
4339 unmarkmatches
4340 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4341 set findpattern {}
4342 } elseif {$findtype eq [mc "Regexp"]} {
4343 set findpattern $findstring
4344 } else {
4345 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4346 $findstring]
4347 set findpattern "*$e*"
4348 }
4349 }
4351 proc makepatterns {l} {
4352 set ret {}
4353 foreach e $l {
4354 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4355 if {[string index $ee end] eq "/"} {
4356 lappend ret "$ee*"
4357 } else {
4358 lappend ret $ee
4359 lappend ret "$ee/*"
4360 }
4361 }
4362 return $ret
4363 }
4365 proc do_file_hl {serial} {
4366 global highlight_files filehighlight highlight_paths gdttype fhl_list
4368 if {$gdttype eq [mc "touching paths:"]} {
4369 if {[catch {set paths [shellsplit $highlight_files]}]} return
4370 set highlight_paths [makepatterns $paths]
4371 highlight_filelist
4372 set gdtargs [concat -- $paths]
4373 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4374 set gdtargs [list "-S$highlight_files"]
4375 } else {
4376 # must be "containing:", i.e. we're searching commit info
4377 return
4378 }
4379 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4380 set filehighlight [open $cmd r+]
4381 fconfigure $filehighlight -blocking 0
4382 filerun $filehighlight readfhighlight
4383 set fhl_list {}
4384 drawvisible
4385 flushhighlights
4386 }
4388 proc flushhighlights {} {
4389 global filehighlight fhl_list
4391 if {[info exists filehighlight]} {
4392 lappend fhl_list {}
4393 puts $filehighlight ""
4394 flush $filehighlight
4395 }
4396 }
4398 proc askfilehighlight {row id} {
4399 global filehighlight fhighlights fhl_list
4401 lappend fhl_list $id
4402 set fhighlights($id) -1
4403 puts $filehighlight $id
4404 }
4406 proc readfhighlight {} {
4407 global filehighlight fhighlights curview iddrawn
4408 global fhl_list find_dirn
4410 if {![info exists filehighlight]} {
4411 return 0
4412 }
4413 set nr 0
4414 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4415 set line [string trim $line]
4416 set i [lsearch -exact $fhl_list $line]
4417 if {$i < 0} continue
4418 for {set j 0} {$j < $i} {incr j} {
4419 set id [lindex $fhl_list $j]
4420 set fhighlights($id) 0
4421 }
4422 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4423 if {$line eq {}} continue
4424 if {![commitinview $line $curview]} continue
4425 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4426 bolden $line mainfontbold
4427 }
4428 set fhighlights($line) 1
4429 }
4430 if {[eof $filehighlight]} {
4431 # strange...
4432 puts "oops, git diff-tree died"
4433 catch {close $filehighlight}
4434 unset filehighlight
4435 return 0
4436 }
4437 if {[info exists find_dirn]} {
4438 run findmore
4439 }
4440 return 1
4441 }
4443 proc doesmatch {f} {
4444 global findtype findpattern
4446 if {$findtype eq [mc "Regexp"]} {
4447 return [regexp $findpattern $f]
4448 } elseif {$findtype eq [mc "IgnCase"]} {
4449 return [string match -nocase $findpattern $f]
4450 } else {
4451 return [string match $findpattern $f]
4452 }
4453 }
4455 proc askfindhighlight {row id} {
4456 global nhighlights commitinfo iddrawn
4457 global findloc
4458 global markingmatches
4460 if {![info exists commitinfo($id)]} {
4461 getcommit $id
4462 }
4463 set info $commitinfo($id)
4464 set isbold 0
4465 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4466 foreach f $info ty $fldtypes {
4467 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4468 [doesmatch $f]} {
4469 if {$ty eq [mc "Author"]} {
4470 set isbold 2
4471 break
4472 }
4473 set isbold 1
4474 }
4475 }
4476 if {$isbold && [info exists iddrawn($id)]} {
4477 if {![ishighlighted $id]} {
4478 bolden $id mainfontbold
4479 if {$isbold > 1} {
4480 bolden_name $id mainfontbold
4481 }
4482 }
4483 if {$markingmatches} {
4484 markrowmatches $row $id
4485 }
4486 }
4487 set nhighlights($id) $isbold
4488 }
4490 proc markrowmatches {row id} {
4491 global canv canv2 linehtag linentag commitinfo findloc
4493 set headline [lindex $commitinfo($id) 0]
4494 set author [lindex $commitinfo($id) 1]
4495 $canv delete match$row
4496 $canv2 delete match$row
4497 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4498 set m [findmatches $headline]
4499 if {$m ne {}} {
4500 markmatches $canv $row $headline $linehtag($id) $m \
4501 [$canv itemcget $linehtag($id) -font] $row
4502 }
4503 }
4504 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4505 set m [findmatches $author]
4506 if {$m ne {}} {
4507 markmatches $canv2 $row $author $linentag($id) $m \
4508 [$canv2 itemcget $linentag($id) -font] $row
4509 }
4510 }
4511 }
4513 proc vrel_change {name ix op} {
4514 global highlight_related
4516 rhighlight_none
4517 if {$highlight_related ne [mc "None"]} {
4518 run drawvisible
4519 }
4520 }
4522 # prepare for testing whether commits are descendents or ancestors of a
4523 proc rhighlight_sel {a} {
4524 global descendent desc_todo ancestor anc_todo
4525 global highlight_related
4527 catch {unset descendent}
4528 set desc_todo [list $a]
4529 catch {unset ancestor}
4530 set anc_todo [list $a]
4531 if {$highlight_related ne [mc "None"]} {
4532 rhighlight_none
4533 run drawvisible
4534 }
4535 }
4537 proc rhighlight_none {} {
4538 global rhighlights
4540 catch {unset rhighlights}
4541 unbolden
4542 }
4544 proc is_descendent {a} {
4545 global curview children descendent desc_todo
4547 set v $curview
4548 set la [rowofcommit $a]
4549 set todo $desc_todo
4550 set leftover {}
4551 set done 0
4552 for {set i 0} {$i < [llength $todo]} {incr i} {
4553 set do [lindex $todo $i]
4554 if {[rowofcommit $do] < $la} {
4555 lappend leftover $do
4556 continue
4557 }
4558 foreach nk $children($v,$do) {
4559 if {![info exists descendent($nk)]} {
4560 set descendent($nk) 1
4561 lappend todo $nk
4562 if {$nk eq $a} {
4563 set done 1
4564 }
4565 }
4566 }
4567 if {$done} {
4568 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4569 return
4570 }
4571 }
4572 set descendent($a) 0
4573 set desc_todo $leftover
4574 }
4576 proc is_ancestor {a} {
4577 global curview parents ancestor anc_todo
4579 set v $curview
4580 set la [rowofcommit $a]
4581 set todo $anc_todo
4582 set leftover {}
4583 set done 0
4584 for {set i 0} {$i < [llength $todo]} {incr i} {
4585 set do [lindex $todo $i]
4586 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4587 lappend leftover $do
4588 continue
4589 }
4590 foreach np $parents($v,$do) {
4591 if {![info exists ancestor($np)]} {
4592 set ancestor($np) 1
4593 lappend todo $np
4594 if {$np eq $a} {
4595 set done 1
4596 }
4597 }
4598 }
4599 if {$done} {
4600 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4601 return
4602 }
4603 }
4604 set ancestor($a) 0
4605 set anc_todo $leftover
4606 }
4608 proc askrelhighlight {row id} {
4609 global descendent highlight_related iddrawn rhighlights
4610 global selectedline ancestor
4612 if {$selectedline eq {}} return
4613 set isbold 0
4614 if {$highlight_related eq [mc "Descendant"] ||
4615 $highlight_related eq [mc "Not descendant"]} {
4616 if {![info exists descendent($id)]} {
4617 is_descendent $id
4618 }
4619 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4620 set isbold 1
4621 }
4622 } elseif {$highlight_related eq [mc "Ancestor"] ||
4623 $highlight_related eq [mc "Not ancestor"]} {
4624 if {![info exists ancestor($id)]} {
4625 is_ancestor $id
4626 }
4627 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4628 set isbold 1
4629 }
4630 }
4631 if {[info exists iddrawn($id)]} {
4632 if {$isbold && ![ishighlighted $id]} {
4633 bolden $id mainfontbold
4634 }
4635 }
4636 set rhighlights($id) $isbold
4637 }
4639 # Graph layout functions
4641 proc shortids {ids} {
4642 set res {}
4643 foreach id $ids {
4644 if {[llength $id] > 1} {
4645 lappend res [shortids $id]
4646 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4647 lappend res [string range $id 0 7]
4648 } else {
4649 lappend res $id
4650 }
4651 }
4652 return $res
4653 }
4655 proc ntimes {n o} {
4656 set ret {}
4657 set o [list $o]
4658 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4659 if {($n & $mask) != 0} {
4660 set ret [concat $ret $o]
4661 }
4662 set o [concat $o $o]
4663 }
4664 return $ret
4665 }
4667 proc ordertoken {id} {
4668 global ordertok curview varcid varcstart varctok curview parents children
4669 global nullid nullid2
4671 if {[info exists ordertok($id)]} {
4672 return $ordertok($id)
4673 }
4674 set origid $id
4675 set todo {}
4676 while {1} {
4677 if {[info exists varcid($curview,$id)]} {
4678 set a $varcid($curview,$id)
4679 set p [lindex $varcstart($curview) $a]
4680 } else {
4681 set p [lindex $children($curview,$id) 0]
4682 }
4683 if {[info exists ordertok($p)]} {
4684 set tok $ordertok($p)
4685 break
4686 }
4687 set id [first_real_child $curview,$p]
4688 if {$id eq {}} {
4689 # it's a root
4690 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4691 break
4692 }
4693 if {[llength $parents($curview,$id)] == 1} {
4694 lappend todo [list $p {}]
4695 } else {
4696 set j [lsearch -exact $parents($curview,$id) $p]
4697 if {$j < 0} {
4698 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4699 }
4700 lappend todo [list $p [strrep $j]]
4701 }
4702 }
4703 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4704 set p [lindex $todo $i 0]
4705 append tok [lindex $todo $i 1]
4706 set ordertok($p) $tok
4707 }
4708 set ordertok($origid) $tok
4709 return $tok
4710 }
4712 # Work out where id should go in idlist so that order-token
4713 # values increase from left to right
4714 proc idcol {idlist id {i 0}} {
4715 set t [ordertoken $id]
4716 if {$i < 0} {
4717 set i 0
4718 }
4719 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4720 if {$i > [llength $idlist]} {
4721 set i [llength $idlist]
4722 }
4723 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4724 incr i
4725 } else {
4726 if {$t > [ordertoken [lindex $idlist $i]]} {
4727 while {[incr i] < [llength $idlist] &&
4728 $t >= [ordertoken [lindex $idlist $i]]} {}
4729 }
4730 }
4731 return $i
4732 }
4734 proc initlayout {} {
4735 global rowidlist rowisopt rowfinal displayorder parentlist
4736 global numcommits canvxmax canv
4737 global nextcolor
4738 global colormap rowtextx
4740 set numcommits 0
4741 set displayorder {}
4742 set parentlist {}
4743 set nextcolor 0
4744 set rowidlist {}
4745 set rowisopt {}
4746 set rowfinal {}
4747 set canvxmax [$canv cget -width]
4748 catch {unset colormap}
4749 catch {unset rowtextx}
4750 setcanvscroll
4751 }
4753 proc setcanvscroll {} {
4754 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4755 global lastscrollset lastscrollrows
4757 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4758 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4759 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4760 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4761 set lastscrollset [clock clicks -milliseconds]
4762 set lastscrollrows $numcommits
4763 }
4765 proc visiblerows {} {
4766 global canv numcommits linespc
4768 set ymax [lindex [$canv cget -scrollregion] 3]
4769 if {$ymax eq {} || $ymax == 0} return
4770 set f [$canv yview]
4771 set y0 [expr {int([lindex $f 0] * $ymax)}]
4772 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4773 if {$r0 < 0} {
4774 set r0 0
4775 }
4776 set y1 [expr {int([lindex $f 1] * $ymax)}]
4777 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4778 if {$r1 >= $numcommits} {
4779 set r1 [expr {$numcommits - 1}]
4780 }
4781 return [list $r0 $r1]
4782 }
4784 proc layoutmore {} {
4785 global commitidx viewcomplete curview
4786 global numcommits pending_select curview
4787 global lastscrollset lastscrollrows
4789 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4790 [clock clicks -milliseconds] - $lastscrollset > 500} {
4791 setcanvscroll
4792 }
4793 if {[info exists pending_select] &&
4794 [commitinview $pending_select $curview]} {
4795 update
4796 selectline [rowofcommit $pending_select] 1
4797 }
4798 drawvisible
4799 }
4801 # With path limiting, we mightn't get the actual HEAD commit,
4802 # so ask git rev-list what is the first ancestor of HEAD that
4803 # touches a file in the path limit.
4804 proc get_viewmainhead {view} {
4805 global viewmainheadid vfilelimit viewinstances mainheadid
4807 catch {
4808 set rfd [open [concat | git rev-list -1 $mainheadid \
4809 -- $vfilelimit($view)] r]
4810 set j [reg_instance $rfd]
4811 lappend viewinstances($view) $j
4812 fconfigure $rfd -blocking 0
4813 filerun $rfd [list getviewhead $rfd $j $view]
4814 set viewmainheadid($curview) {}
4815 }
4816 }
4818 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4819 proc getviewhead {fd inst view} {
4820 global viewmainheadid commfd curview viewinstances showlocalchanges
4822 set id {}
4823 if {[gets $fd line] < 0} {
4824 if {![eof $fd]} {
4825 return 1
4826 }
4827 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4828 set id $line
4829 }
4830 set viewmainheadid($view) $id
4831 close $fd
4832 unset commfd($inst)
4833 set i [lsearch -exact $viewinstances($view) $inst]
4834 if {$i >= 0} {
4835 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4836 }
4837 if {$showlocalchanges && $id ne {} && $view == $curview} {
4838 doshowlocalchanges
4839 }
4840 return 0
4841 }
4843 proc doshowlocalchanges {} {
4844 global curview viewmainheadid
4846 if {$viewmainheadid($curview) eq {}} return
4847 if {[commitinview $viewmainheadid($curview) $curview]} {
4848 dodiffindex
4849 } else {
4850 interestedin $viewmainheadid($curview) dodiffindex
4851 }
4852 }
4854 proc dohidelocalchanges {} {
4855 global nullid nullid2 lserial curview
4857 if {[commitinview $nullid $curview]} {
4858 removefakerow $nullid
4859 }
4860 if {[commitinview $nullid2 $curview]} {
4861 removefakerow $nullid2
4862 }
4863 incr lserial
4864 }
4866 # spawn off a process to do git diff-index --cached HEAD
4867 proc dodiffindex {} {
4868 global lserial showlocalchanges vfilelimit curview
4869 global isworktree
4871 if {!$showlocalchanges || !$isworktree} return
4872 incr lserial
4873 set cmd "|git diff-index --cached HEAD"
4874 if {$vfilelimit($curview) ne {}} {
4875 set cmd [concat $cmd -- $vfilelimit($curview)]
4876 }
4877 set fd [open $cmd r]
4878 fconfigure $fd -blocking 0
4879 set i [reg_instance $fd]
4880 filerun $fd [list readdiffindex $fd $lserial $i]
4881 }
4883 proc readdiffindex {fd serial inst} {
4884 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4885 global vfilelimit
4887 set isdiff 1
4888 if {[gets $fd line] < 0} {
4889 if {![eof $fd]} {
4890 return 1
4891 }
4892 set isdiff 0
4893 }
4894 # we only need to see one line and we don't really care what it says...
4895 stop_instance $inst
4897 if {$serial != $lserial} {
4898 return 0
4899 }
4901 # now see if there are any local changes not checked in to the index
4902 set cmd "|git diff-files"
4903 if {$vfilelimit($curview) ne {}} {
4904 set cmd [concat $cmd -- $vfilelimit($curview)]
4905 }
4906 set fd [open $cmd r]
4907 fconfigure $fd -blocking 0
4908 set i [reg_instance $fd]
4909 filerun $fd [list readdifffiles $fd $serial $i]
4911 if {$isdiff && ![commitinview $nullid2 $curview]} {
4912 # add the line for the changes in the index to the graph
4913 set hl [mc "Local changes checked in to index but not committed"]
4914 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4915 set commitdata($nullid2) "\n $hl\n"
4916 if {[commitinview $nullid $curview]} {
4917 removefakerow $nullid
4918 }
4919 insertfakerow $nullid2 $viewmainheadid($curview)
4920 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4921 if {[commitinview $nullid $curview]} {
4922 removefakerow $nullid
4923 }
4924 removefakerow $nullid2
4925 }
4926 return 0
4927 }
4929 proc readdifffiles {fd serial inst} {
4930 global viewmainheadid nullid nullid2 curview
4931 global commitinfo commitdata lserial
4933 set isdiff 1
4934 if {[gets $fd line] < 0} {
4935 if {![eof $fd]} {
4936 return 1
4937 }
4938 set isdiff 0
4939 }
4940 # we only need to see one line and we don't really care what it says...
4941 stop_instance $inst
4943 if {$serial != $lserial} {
4944 return 0
4945 }
4947 if {$isdiff && ![commitinview $nullid $curview]} {
4948 # add the line for the local diff to the graph
4949 set hl [mc "Local uncommitted changes, not checked in to index"]
4950 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4951 set commitdata($nullid) "\n $hl\n"
4952 if {[commitinview $nullid2 $curview]} {
4953 set p $nullid2
4954 } else {
4955 set p $viewmainheadid($curview)
4956 }
4957 insertfakerow $nullid $p
4958 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4959 removefakerow $nullid
4960 }
4961 return 0
4962 }
4964 proc nextuse {id row} {
4965 global curview children
4967 if {[info exists children($curview,$id)]} {
4968 foreach kid $children($curview,$id) {
4969 if {![commitinview $kid $curview]} {
4970 return -1
4971 }
4972 if {[rowofcommit $kid] > $row} {
4973 return [rowofcommit $kid]
4974 }
4975 }
4976 }
4977 if {[commitinview $id $curview]} {
4978 return [rowofcommit $id]
4979 }
4980 return -1
4981 }
4983 proc prevuse {id row} {
4984 global curview children
4986 set ret -1
4987 if {[info exists children($curview,$id)]} {
4988 foreach kid $children($curview,$id) {
4989 if {![commitinview $kid $curview]} break
4990 if {[rowofcommit $kid] < $row} {
4991 set ret [rowofcommit $kid]
4992 }
4993 }
4994 }
4995 return $ret
4996 }
4998 proc make_idlist {row} {
4999 global displayorder parentlist uparrowlen downarrowlen mingaplen
5000 global commitidx curview children
5002 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5003 if {$r < 0} {
5004 set r 0
5005 }
5006 set ra [expr {$row - $downarrowlen}]
5007 if {$ra < 0} {
5008 set ra 0
5009 }
5010 set rb [expr {$row + $uparrowlen}]
5011 if {$rb > $commitidx($curview)} {
5012 set rb $commitidx($curview)
5013 }
5014 make_disporder $r [expr {$rb + 1}]
5015 set ids {}
5016 for {} {$r < $ra} {incr r} {
5017 set nextid [lindex $displayorder [expr {$r + 1}]]
5018 foreach p [lindex $parentlist $r] {
5019 if {$p eq $nextid} continue
5020 set rn [nextuse $p $r]
5021 if {$rn >= $row &&
5022 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5023 lappend ids [list [ordertoken $p] $p]
5024 }
5025 }
5026 }
5027 for {} {$r < $row} {incr r} {
5028 set nextid [lindex $displayorder [expr {$r + 1}]]
5029 foreach p [lindex $parentlist $r] {
5030 if {$p eq $nextid} continue
5031 set rn [nextuse $p $r]
5032 if {$rn < 0 || $rn >= $row} {
5033 lappend ids [list [ordertoken $p] $p]
5034 }
5035 }
5036 }
5037 set id [lindex $displayorder $row]
5038 lappend ids [list [ordertoken $id] $id]
5039 while {$r < $rb} {
5040 foreach p [lindex $parentlist $r] {
5041 set firstkid [lindex $children($curview,$p) 0]
5042 if {[rowofcommit $firstkid] < $row} {
5043 lappend ids [list [ordertoken $p] $p]
5044 }
5045 }
5046 incr r
5047 set id [lindex $displayorder $r]
5048 if {$id ne {}} {
5049 set firstkid [lindex $children($curview,$id) 0]
5050 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5051 lappend ids [list [ordertoken $id] $id]
5052 }
5053 }
5054 }
5055 set idlist {}
5056 foreach idx [lsort -unique $ids] {
5057 lappend idlist [lindex $idx 1]
5058 }
5059 return $idlist
5060 }
5062 proc rowsequal {a b} {
5063 while {[set i [lsearch -exact $a {}]] >= 0} {
5064 set a [lreplace $a $i $i]
5065 }
5066 while {[set i [lsearch -exact $b {}]] >= 0} {
5067 set b [lreplace $b $i $i]
5068 }
5069 return [expr {$a eq $b}]
5070 }
5072 proc makeupline {id row rend col} {
5073 global rowidlist uparrowlen downarrowlen mingaplen
5075 for {set r $rend} {1} {set r $rstart} {
5076 set rstart [prevuse $id $r]
5077 if {$rstart < 0} return
5078 if {$rstart < $row} break
5079 }
5080 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5081 set rstart [expr {$rend - $uparrowlen - 1}]
5082 }
5083 for {set r $rstart} {[incr r] <= $row} {} {
5084 set idlist [lindex $rowidlist $r]
5085 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5086 set col [idcol $idlist $id $col]
5087 lset rowidlist $r [linsert $idlist $col $id]
5088 changedrow $r
5089 }
5090 }
5091 }
5093 proc layoutrows {row endrow} {
5094 global rowidlist rowisopt rowfinal displayorder
5095 global uparrowlen downarrowlen maxwidth mingaplen
5096 global children parentlist
5097 global commitidx viewcomplete curview
5099 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5100 set idlist {}
5101 if {$row > 0} {
5102 set rm1 [expr {$row - 1}]
5103 foreach id [lindex $rowidlist $rm1] {
5104 if {$id ne {}} {
5105 lappend idlist $id
5106 }
5107 }
5108 set final [lindex $rowfinal $rm1]
5109 }
5110 for {} {$row < $endrow} {incr row} {
5111 set rm1 [expr {$row - 1}]
5112 if {$rm1 < 0 || $idlist eq {}} {
5113 set idlist [make_idlist $row]
5114 set final 1
5115 } else {
5116 set id [lindex $displayorder $rm1]
5117 set col [lsearch -exact $idlist $id]
5118 set idlist [lreplace $idlist $col $col]
5119 foreach p [lindex $parentlist $rm1] {
5120 if {[lsearch -exact $idlist $p] < 0} {
5121 set col [idcol $idlist $p $col]
5122 set idlist [linsert $idlist $col $p]
5123 # if not the first child, we have to insert a line going up
5124 if {$id ne [lindex $children($curview,$p) 0]} {
5125 makeupline $p $rm1 $row $col
5126 }
5127 }
5128 }
5129 set id [lindex $displayorder $row]
5130 if {$row > $downarrowlen} {
5131 set termrow [expr {$row - $downarrowlen - 1}]
5132 foreach p [lindex $parentlist $termrow] {
5133 set i [lsearch -exact $idlist $p]
5134 if {$i < 0} continue
5135 set nr [nextuse $p $termrow]
5136 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5137 set idlist [lreplace $idlist $i $i]
5138 }
5139 }
5140 }
5141 set col [lsearch -exact $idlist $id]
5142 if {$col < 0} {
5143 set col [idcol $idlist $id]
5144 set idlist [linsert $idlist $col $id]
5145 if {$children($curview,$id) ne {}} {
5146 makeupline $id $rm1 $row $col
5147 }
5148 }
5149 set r [expr {$row + $uparrowlen - 1}]
5150 if {$r < $commitidx($curview)} {
5151 set x $col
5152 foreach p [lindex $parentlist $r] {
5153 if {[lsearch -exact $idlist $p] >= 0} continue
5154 set fk [lindex $children($curview,$p) 0]
5155 if {[rowofcommit $fk] < $row} {
5156 set x [idcol $idlist $p $x]
5157 set idlist [linsert $idlist $x $p]
5158 }
5159 }
5160 if {[incr r] < $commitidx($curview)} {
5161 set p [lindex $displayorder $r]
5162 if {[lsearch -exact $idlist $p] < 0} {
5163 set fk [lindex $children($curview,$p) 0]
5164 if {$fk ne {} && [rowofcommit $fk] < $row} {
5165 set x [idcol $idlist $p $x]
5166 set idlist [linsert $idlist $x $p]
5167 }
5168 }
5169 }
5170 }
5171 }
5172 if {$final && !$viewcomplete($curview) &&
5173 $row + $uparrowlen + $mingaplen + $downarrowlen
5174 >= $commitidx($curview)} {
5175 set final 0
5176 }
5177 set l [llength $rowidlist]
5178 if {$row == $l} {
5179 lappend rowidlist $idlist
5180 lappend rowisopt 0
5181 lappend rowfinal $final
5182 } elseif {$row < $l} {
5183 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5184 lset rowidlist $row $idlist
5185 changedrow $row
5186 }
5187 lset rowfinal $row $final
5188 } else {
5189 set pad [ntimes [expr {$row - $l}] {}]
5190 set rowidlist [concat $rowidlist $pad]
5191 lappend rowidlist $idlist
5192 set rowfinal [concat $rowfinal $pad]
5193 lappend rowfinal $final
5194 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5195 }
5196 }
5197 return $row
5198 }
5200 proc changedrow {row} {
5201 global displayorder iddrawn rowisopt need_redisplay
5203 set l [llength $rowisopt]
5204 if {$row < $l} {
5205 lset rowisopt $row 0
5206 if {$row + 1 < $l} {
5207 lset rowisopt [expr {$row + 1}] 0
5208 if {$row + 2 < $l} {
5209 lset rowisopt [expr {$row + 2}] 0
5210 }
5211 }
5212 }
5213 set id [lindex $displayorder $row]
5214 if {[info exists iddrawn($id)]} {
5215 set need_redisplay 1
5216 }
5217 }
5219 proc insert_pad {row col npad} {
5220 global rowidlist
5222 set pad [ntimes $npad {}]
5223 set idlist [lindex $rowidlist $row]
5224 set bef [lrange $idlist 0 [expr {$col - 1}]]
5225 set aft [lrange $idlist $col end]
5226 set i [lsearch -exact $aft {}]
5227 if {$i > 0} {
5228 set aft [lreplace $aft $i $i]
5229 }
5230 lset rowidlist $row [concat $bef $pad $aft]
5231 changedrow $row
5232 }
5234 proc optimize_rows {row col endrow} {
5235 global rowidlist rowisopt displayorder curview children
5237 if {$row < 1} {
5238 set row 1
5239 }
5240 for {} {$row < $endrow} {incr row; set col 0} {
5241 if {[lindex $rowisopt $row]} continue
5242 set haspad 0
5243 set y0 [expr {$row - 1}]
5244 set ym [expr {$row - 2}]
5245 set idlist [lindex $rowidlist $row]
5246 set previdlist [lindex $rowidlist $y0]
5247 if {$idlist eq {} || $previdlist eq {}} continue
5248 if {$ym >= 0} {
5249 set pprevidlist [lindex $rowidlist $ym]
5250 if {$pprevidlist eq {}} continue
5251 } else {
5252 set pprevidlist {}
5253 }
5254 set x0 -1
5255 set xm -1
5256 for {} {$col < [llength $idlist]} {incr col} {
5257 set id [lindex $idlist $col]
5258 if {[lindex $previdlist $col] eq $id} continue
5259 if {$id eq {}} {
5260 set haspad 1
5261 continue
5262 }
5263 set x0 [lsearch -exact $previdlist $id]
5264 if {$x0 < 0} continue
5265 set z [expr {$x0 - $col}]
5266 set isarrow 0
5267 set z0 {}
5268 if {$ym >= 0} {
5269 set xm [lsearch -exact $pprevidlist $id]
5270 if {$xm >= 0} {
5271 set z0 [expr {$xm - $x0}]
5272 }
5273 }
5274 if {$z0 eq {}} {
5275 # if row y0 is the first child of $id then it's not an arrow
5276 if {[lindex $children($curview,$id) 0] ne
5277 [lindex $displayorder $y0]} {
5278 set isarrow 1
5279 }
5280 }
5281 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5282 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5283 set isarrow 1
5284 }
5285 # Looking at lines from this row to the previous row,
5286 # make them go straight up if they end in an arrow on
5287 # the previous row; otherwise make them go straight up
5288 # or at 45 degrees.
5289 if {$z < -1 || ($z < 0 && $isarrow)} {
5290 # Line currently goes left too much;
5291 # insert pads in the previous row, then optimize it
5292 set npad [expr {-1 - $z + $isarrow}]
5293 insert_pad $y0 $x0 $npad
5294 if {$y0 > 0} {
5295 optimize_rows $y0 $x0 $row
5296 }
5297 set previdlist [lindex $rowidlist $y0]
5298 set x0 [lsearch -exact $previdlist $id]
5299 set z [expr {$x0 - $col}]
5300 if {$z0 ne {}} {
5301 set pprevidlist [lindex $rowidlist $ym]
5302 set xm [lsearch -exact $pprevidlist $id]
5303 set z0 [expr {$xm - $x0}]
5304 }
5305 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5306 # Line currently goes right too much;
5307 # insert pads in this line
5308 set npad [expr {$z - 1 + $isarrow}]
5309 insert_pad $row $col $npad
5310 set idlist [lindex $rowidlist $row]
5311 incr col $npad
5312 set z [expr {$x0 - $col}]
5313 set haspad 1
5314 }
5315 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5316 # this line links to its first child on row $row-2
5317 set id [lindex $displayorder $ym]
5318 set xc [lsearch -exact $pprevidlist $id]
5319 if {$xc >= 0} {
5320 set z0 [expr {$xc - $x0}]
5321 }
5322 }
5323 # avoid lines jigging left then immediately right
5324 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5325 insert_pad $y0 $x0 1
5326 incr x0
5327 optimize_rows $y0 $x0 $row
5328 set previdlist [lindex $rowidlist $y0]
5329 }
5330 }
5331 if {!$haspad} {
5332 # Find the first column that doesn't have a line going right
5333 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5334 set id [lindex $idlist $col]
5335 if {$id eq {}} break
5336 set x0 [lsearch -exact $previdlist $id]
5337 if {$x0 < 0} {
5338 # check if this is the link to the first child
5339 set kid [lindex $displayorder $y0]
5340 if {[lindex $children($curview,$id) 0] eq $kid} {
5341 # it is, work out offset to child
5342 set x0 [lsearch -exact $previdlist $kid]
5343 }
5344 }
5345 if {$x0 <= $col} break
5346 }
5347 # Insert a pad at that column as long as it has a line and
5348 # isn't the last column
5349 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5350 set idlist [linsert $idlist $col {}]
5351 lset rowidlist $row $idlist
5352 changedrow $row
5353 }
5354 }
5355 }
5356 }
5358 proc xc {row col} {
5359 global canvx0 linespc
5360 return [expr {$canvx0 + $col * $linespc}]
5361 }
5363 proc yc {row} {
5364 global canvy0 linespc
5365 return [expr {$canvy0 + $row * $linespc}]
5366 }
5368 proc linewidth {id} {
5369 global thickerline lthickness
5371 set wid $lthickness
5372 if {[info exists thickerline] && $id eq $thickerline} {
5373 set wid [expr {2 * $lthickness}]
5374 }
5375 return $wid
5376 }
5378 proc rowranges {id} {
5379 global curview children uparrowlen downarrowlen
5380 global rowidlist
5382 set kids $children($curview,$id)
5383 if {$kids eq {}} {
5384 return {}
5385 }
5386 set ret {}
5387 lappend kids $id
5388 foreach child $kids {
5389 if {![commitinview $child $curview]} break
5390 set row [rowofcommit $child]
5391 if {![info exists prev]} {
5392 lappend ret [expr {$row + 1}]
5393 } else {
5394 if {$row <= $prevrow} {
5395 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5396 }
5397 # see if the line extends the whole way from prevrow to row
5398 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5399 [lsearch -exact [lindex $rowidlist \
5400 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5401 # it doesn't, see where it ends
5402 set r [expr {$prevrow + $downarrowlen}]
5403 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5404 while {[incr r -1] > $prevrow &&
5405 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5406 } else {
5407 while {[incr r] <= $row &&
5408 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5409 incr r -1
5410 }
5411 lappend ret $r
5412 # see where it starts up again
5413 set r [expr {$row - $uparrowlen}]
5414 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5415 while {[incr r] < $row &&
5416 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5417 } else {
5418 while {[incr r -1] >= $prevrow &&
5419 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5420 incr r
5421 }
5422 lappend ret $r
5423 }
5424 }
5425 if {$child eq $id} {
5426 lappend ret $row
5427 }
5428 set prev $child
5429 set prevrow $row
5430 }
5431 return $ret
5432 }
5434 proc drawlineseg {id row endrow arrowlow} {
5435 global rowidlist displayorder iddrawn linesegs
5436 global canv colormap linespc curview maxlinelen parentlist
5438 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5439 set le [expr {$row + 1}]
5440 set arrowhigh 1
5441 while {1} {
5442 set c [lsearch -exact [lindex $rowidlist $le] $id]
5443 if {$c < 0} {
5444 incr le -1
5445 break
5446 }
5447 lappend cols $c
5448 set x [lindex $displayorder $le]
5449 if {$x eq $id} {
5450 set arrowhigh 0
5451 break
5452 }
5453 if {[info exists iddrawn($x)] || $le == $endrow} {
5454 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5455 if {$c >= 0} {
5456 lappend cols $c
5457 set arrowhigh 0
5458 }
5459 break
5460 }
5461 incr le
5462 }
5463 if {$le <= $row} {
5464 return $row
5465 }
5467 set lines {}
5468 set i 0
5469 set joinhigh 0
5470 if {[info exists linesegs($id)]} {
5471 set lines $linesegs($id)
5472 foreach li $lines {
5473 set r0 [lindex $li 0]
5474 if {$r0 > $row} {
5475 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5476 set joinhigh 1
5477 }
5478 break
5479 }
5480 incr i
5481 }
5482 }
5483 set joinlow 0
5484 if {$i > 0} {
5485 set li [lindex $lines [expr {$i-1}]]
5486 set r1 [lindex $li 1]
5487 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5488 set joinlow 1
5489 }
5490 }
5492 set x [lindex $cols [expr {$le - $row}]]
5493 set xp [lindex $cols [expr {$le - 1 - $row}]]
5494 set dir [expr {$xp - $x}]
5495 if {$joinhigh} {
5496 set ith [lindex $lines $i 2]
5497 set coords [$canv coords $ith]
5498 set ah [$canv itemcget $ith -arrow]
5499 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5500 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5501 if {$x2 ne {} && $x - $x2 == $dir} {
5502 set coords [lrange $coords 0 end-2]
5503 }
5504 } else {
5505 set coords [list [xc $le $x] [yc $le]]
5506 }
5507 if {$joinlow} {
5508 set itl [lindex $lines [expr {$i-1}] 2]
5509 set al [$canv itemcget $itl -arrow]
5510 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5511 } elseif {$arrowlow} {
5512 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5513 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5514 set arrowlow 0
5515 }
5516 }
5517 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5518 for {set y $le} {[incr y -1] > $row} {} {
5519 set x $xp
5520 set xp [lindex $cols [expr {$y - 1 - $row}]]
5521 set ndir [expr {$xp - $x}]
5522 if {$dir != $ndir || $xp < 0} {
5523 lappend coords [xc $y $x] [yc $y]
5524 }
5525 set dir $ndir
5526 }
5527 if {!$joinlow} {
5528 if {$xp < 0} {
5529 # join parent line to first child
5530 set ch [lindex $displayorder $row]
5531 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5532 if {$xc < 0} {
5533 puts "oops: drawlineseg: child $ch not on row $row"
5534 } elseif {$xc != $x} {
5535 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5536 set d [expr {int(0.5 * $linespc)}]
5537 set x1 [xc $row $x]
5538 if {$xc < $x} {
5539 set x2 [expr {$x1 - $d}]
5540 } else {
5541 set x2 [expr {$x1 + $d}]
5542 }
5543 set y2 [yc $row]
5544 set y1 [expr {$y2 + $d}]
5545 lappend coords $x1 $y1 $x2 $y2
5546 } elseif {$xc < $x - 1} {
5547 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5548 } elseif {$xc > $x + 1} {
5549 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5550 }
5551 set x $xc
5552 }
5553 lappend coords [xc $row $x] [yc $row]
5554 } else {
5555 set xn [xc $row $xp]
5556 set yn [yc $row]
5557 lappend coords $xn $yn
5558 }
5559 if {!$joinhigh} {
5560 assigncolor $id
5561 set t [$canv create line $coords -width [linewidth $id] \
5562 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5563 $canv lower $t
5564 bindline $t $id
5565 set lines [linsert $lines $i [list $row $le $t]]
5566 } else {
5567 $canv coords $ith $coords
5568 if {$arrow ne $ah} {
5569 $canv itemconf $ith -arrow $arrow
5570 }
5571 lset lines $i 0 $row
5572 }
5573 } else {
5574 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5575 set ndir [expr {$xo - $xp}]
5576 set clow [$canv coords $itl]
5577 if {$dir == $ndir} {
5578 set clow [lrange $clow 2 end]
5579 }
5580 set coords [concat $coords $clow]
5581 if {!$joinhigh} {
5582 lset lines [expr {$i-1}] 1 $le
5583 } else {
5584 # coalesce two pieces
5585 $canv delete $ith
5586 set b [lindex $lines [expr {$i-1}] 0]
5587 set e [lindex $lines $i 1]
5588 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5589 }
5590 $canv coords $itl $coords
5591 if {$arrow ne $al} {
5592 $canv itemconf $itl -arrow $arrow
5593 }
5594 }
5596 set linesegs($id) $lines
5597 return $le
5598 }
5600 proc drawparentlinks {id row} {
5601 global rowidlist canv colormap curview parentlist
5602 global idpos linespc
5604 set rowids [lindex $rowidlist $row]
5605 set col [lsearch -exact $rowids $id]
5606 if {$col < 0} return
5607 set olds [lindex $parentlist $row]
5608 set row2 [expr {$row + 1}]
5609 set x [xc $row $col]
5610 set y [yc $row]
5611 set y2 [yc $row2]
5612 set d [expr {int(0.5 * $linespc)}]
5613 set ymid [expr {$y + $d}]
5614 set ids [lindex $rowidlist $row2]
5615 # rmx = right-most X coord used
5616 set rmx 0
5617 foreach p $olds {
5618 set i [lsearch -exact $ids $p]
5619 if {$i < 0} {
5620 puts "oops, parent $p of $id not in list"
5621 continue
5622 }
5623 set x2 [xc $row2 $i]
5624 if {$x2 > $rmx} {
5625 set rmx $x2
5626 }
5627 set j [lsearch -exact $rowids $p]
5628 if {$j < 0} {
5629 # drawlineseg will do this one for us
5630 continue
5631 }
5632 assigncolor $p
5633 # should handle duplicated parents here...
5634 set coords [list $x $y]
5635 if {$i != $col} {
5636 # if attaching to a vertical segment, draw a smaller
5637 # slant for visual distinctness
5638 if {$i == $j} {
5639 if {$i < $col} {
5640 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5641 } else {
5642 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5643 }
5644 } elseif {$i < $col && $i < $j} {
5645 # segment slants towards us already
5646 lappend coords [xc $row $j] $y
5647 } else {
5648 if {$i < $col - 1} {
5649 lappend coords [expr {$x2 + $linespc}] $y
5650 } elseif {$i > $col + 1} {
5651 lappend coords [expr {$x2 - $linespc}] $y
5652 }
5653 lappend coords $x2 $y2
5654 }
5655 } else {
5656 lappend coords $x2 $y2
5657 }
5658 set t [$canv create line $coords -width [linewidth $p] \
5659 -fill $colormap($p) -tags lines.$p]
5660 $canv lower $t
5661 bindline $t $p
5662 }
5663 if {$rmx > [lindex $idpos($id) 1]} {
5664 lset idpos($id) 1 $rmx
5665 redrawtags $id
5666 }
5667 }
5669 proc drawlines {id} {
5670 global canv
5672 $canv itemconf lines.$id -width [linewidth $id]
5673 }
5675 proc drawcmittext {id row col} {
5676 global linespc canv canv2 canv3 fgcolor curview
5677 global cmitlisted commitinfo rowidlist parentlist
5678 global rowtextx idpos idtags idheads idotherrefs
5679 global linehtag linentag linedtag selectedline
5680 global canvxmax boldids boldnameids fgcolor markedid
5681 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5683 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5684 set listed $cmitlisted($curview,$id)
5685 if {$id eq $nullid} {
5686 set ofill red
5687 } elseif {$id eq $nullid2} {
5688 set ofill green
5689 } elseif {$id eq $mainheadid} {
5690 set ofill yellow
5691 } else {
5692 set ofill [lindex $circlecolors $listed]
5693 }
5694 set x [xc $row $col]
5695 set y [yc $row]
5696 set orad [expr {$linespc / 3}]
5697 if {$listed <= 2} {
5698 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5699 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5700 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5701 } elseif {$listed == 3} {
5702 # triangle pointing left for left-side commits
5703 set t [$canv create polygon \
5704 [expr {$x - $orad}] $y \
5705 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5706 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5707 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5708 } else {
5709 # triangle pointing right for right-side commits
5710 set t [$canv create polygon \
5711 [expr {$x + $orad - 1}] $y \
5712 [expr {$x - $orad}] [expr {$y - $orad}] \
5713 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5714 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5715 }
5716 set circleitem($row) $t
5717 $canv raise $t
5718 $canv bind $t <1> {selcanvline {} %x %y}
5719 set rmx [llength [lindex $rowidlist $row]]
5720 set olds [lindex $parentlist $row]
5721 if {$olds ne {}} {
5722 set nextids [lindex $rowidlist [expr {$row + 1}]]
5723 foreach p $olds {
5724 set i [lsearch -exact $nextids $p]
5725 if {$i > $rmx} {
5726 set rmx $i
5727 }
5728 }
5729 }
5730 set xt [xc $row $rmx]
5731 set rowtextx($row) $xt
5732 set idpos($id) [list $x $xt $y]
5733 if {[info exists idtags($id)] || [info exists idheads($id)]
5734 || [info exists idotherrefs($id)]} {
5735 set xt [drawtags $id $x $xt $y]
5736 }
5737 set headline [lindex $commitinfo($id) 0]
5738 set name [lindex $commitinfo($id) 1]
5739 set date [lindex $commitinfo($id) 2]
5740 set date [formatdate $date]
5741 set font mainfont
5742 set nfont mainfont
5743 set isbold [ishighlighted $id]
5744 if {$isbold > 0} {
5745 lappend boldids $id
5746 set font mainfontbold
5747 if {$isbold > 1} {
5748 lappend boldnameids $id
5749 set nfont mainfontbold
5750 }
5751 }
5752 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5753 -text $headline -font $font -tags text]
5754 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5755 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5756 -text $name -font $nfont -tags text]
5757 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5758 -text $date -font mainfont -tags text]
5759 if {$selectedline == $row} {
5760 make_secsel $id
5761 }
5762 if {[info exists markedid] && $markedid eq $id} {
5763 make_idmark $id
5764 }
5765 set xr [expr {$xt + [font measure $font $headline]}]
5766 if {$xr > $canvxmax} {
5767 set canvxmax $xr
5768 setcanvscroll
5769 }
5770 }
5772 proc drawcmitrow {row} {
5773 global displayorder rowidlist nrows_drawn
5774 global iddrawn markingmatches
5775 global commitinfo numcommits
5776 global filehighlight fhighlights findpattern nhighlights
5777 global hlview vhighlights
5778 global highlight_related rhighlights
5780 if {$row >= $numcommits} return
5782 set id [lindex $displayorder $row]
5783 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5784 askvhighlight $row $id
5785 }
5786 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5787 askfilehighlight $row $id
5788 }
5789 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5790 askfindhighlight $row $id
5791 }
5792 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5793 askrelhighlight $row $id
5794 }
5795 if {![info exists iddrawn($id)]} {
5796 set col [lsearch -exact [lindex $rowidlist $row] $id]
5797 if {$col < 0} {
5798 puts "oops, row $row id $id not in list"
5799 return
5800 }
5801 if {![info exists commitinfo($id)]} {
5802 getcommit $id
5803 }
5804 assigncolor $id
5805 drawcmittext $id $row $col
5806 set iddrawn($id) 1
5807 incr nrows_drawn
5808 }
5809 if {$markingmatches} {
5810 markrowmatches $row $id
5811 }
5812 }
5814 proc drawcommits {row {endrow {}}} {
5815 global numcommits iddrawn displayorder curview need_redisplay
5816 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5818 if {$row < 0} {
5819 set row 0
5820 }
5821 if {$endrow eq {}} {
5822 set endrow $row
5823 }
5824 if {$endrow >= $numcommits} {
5825 set endrow [expr {$numcommits - 1}]
5826 }
5828 set rl1 [expr {$row - $downarrowlen - 3}]
5829 if {$rl1 < 0} {
5830 set rl1 0
5831 }
5832 set ro1 [expr {$row - 3}]
5833 if {$ro1 < 0} {
5834 set ro1 0
5835 }
5836 set r2 [expr {$endrow + $uparrowlen + 3}]
5837 if {$r2 > $numcommits} {
5838 set r2 $numcommits
5839 }
5840 for {set r $rl1} {$r < $r2} {incr r} {
5841 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5842 if {$rl1 < $r} {
5843 layoutrows $rl1 $r
5844 }
5845 set rl1 [expr {$r + 1}]
5846 }
5847 }
5848 if {$rl1 < $r} {
5849 layoutrows $rl1 $r
5850 }
5851 optimize_rows $ro1 0 $r2
5852 if {$need_redisplay || $nrows_drawn > 2000} {
5853 clear_display
5854 }
5856 # make the lines join to already-drawn rows either side
5857 set r [expr {$row - 1}]
5858 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5859 set r $row
5860 }
5861 set er [expr {$endrow + 1}]
5862 if {$er >= $numcommits ||
5863 ![info exists iddrawn([lindex $displayorder $er])]} {
5864 set er $endrow
5865 }
5866 for {} {$r <= $er} {incr r} {
5867 set id [lindex $displayorder $r]
5868 set wasdrawn [info exists iddrawn($id)]
5869 drawcmitrow $r
5870 if {$r == $er} break
5871 set nextid [lindex $displayorder [expr {$r + 1}]]
5872 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5873 drawparentlinks $id $r
5875 set rowids [lindex $rowidlist $r]
5876 foreach lid $rowids {
5877 if {$lid eq {}} continue
5878 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5879 if {$lid eq $id} {
5880 # see if this is the first child of any of its parents
5881 foreach p [lindex $parentlist $r] {
5882 if {[lsearch -exact $rowids $p] < 0} {
5883 # make this line extend up to the child
5884 set lineend($p) [drawlineseg $p $r $er 0]
5885 }
5886 }
5887 } else {
5888 set lineend($lid) [drawlineseg $lid $r $er 1]
5889 }
5890 }
5891 }
5892 }
5894 proc undolayout {row} {
5895 global uparrowlen mingaplen downarrowlen
5896 global rowidlist rowisopt rowfinal need_redisplay
5898 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5899 if {$r < 0} {
5900 set r 0
5901 }
5902 if {[llength $rowidlist] > $r} {
5903 incr r -1
5904 set rowidlist [lrange $rowidlist 0 $r]
5905 set rowfinal [lrange $rowfinal 0 $r]
5906 set rowisopt [lrange $rowisopt 0 $r]
5907 set need_redisplay 1
5908 run drawvisible
5909 }
5910 }
5912 proc drawvisible {} {
5913 global canv linespc curview vrowmod selectedline targetrow targetid
5914 global need_redisplay cscroll numcommits
5916 set fs [$canv yview]
5917 set ymax [lindex [$canv cget -scrollregion] 3]
5918 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5919 set f0 [lindex $fs 0]
5920 set f1 [lindex $fs 1]
5921 set y0 [expr {int($f0 * $ymax)}]
5922 set y1 [expr {int($f1 * $ymax)}]
5924 if {[info exists targetid]} {
5925 if {[commitinview $targetid $curview]} {
5926 set r [rowofcommit $targetid]
5927 if {$r != $targetrow} {
5928 # Fix up the scrollregion and change the scrolling position
5929 # now that our target row has moved.
5930 set diff [expr {($r - $targetrow) * $linespc}]
5931 set targetrow $r
5932 setcanvscroll
5933 set ymax [lindex [$canv cget -scrollregion] 3]
5934 incr y0 $diff
5935 incr y1 $diff
5936 set f0 [expr {$y0 / $ymax}]
5937 set f1 [expr {$y1 / $ymax}]
5938 allcanvs yview moveto $f0
5939 $cscroll set $f0 $f1
5940 set need_redisplay 1
5941 }
5942 } else {
5943 unset targetid
5944 }
5945 }
5947 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5948 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5949 if {$endrow >= $vrowmod($curview)} {
5950 update_arcrows $curview
5951 }
5952 if {$selectedline ne {} &&
5953 $row <= $selectedline && $selectedline <= $endrow} {
5954 set targetrow $selectedline
5955 } elseif {[info exists targetid]} {
5956 set targetrow [expr {int(($row + $endrow) / 2)}]
5957 }
5958 if {[info exists targetrow]} {
5959 if {$targetrow >= $numcommits} {
5960 set targetrow [expr {$numcommits - 1}]
5961 }
5962 set targetid [commitonrow $targetrow]
5963 }
5964 drawcommits $row $endrow
5965 }
5967 proc clear_display {} {
5968 global iddrawn linesegs need_redisplay nrows_drawn
5969 global vhighlights fhighlights nhighlights rhighlights
5970 global linehtag linentag linedtag boldids boldnameids
5972 allcanvs delete all
5973 catch {unset iddrawn}
5974 catch {unset linesegs}
5975 catch {unset linehtag}
5976 catch {unset linentag}
5977 catch {unset linedtag}
5978 set boldids {}
5979 set boldnameids {}
5980 catch {unset vhighlights}
5981 catch {unset fhighlights}
5982 catch {unset nhighlights}
5983 catch {unset rhighlights}
5984 set need_redisplay 0
5985 set nrows_drawn 0
5986 }
5988 proc findcrossings {id} {
5989 global rowidlist parentlist numcommits displayorder
5991 set cross {}
5992 set ccross {}
5993 foreach {s e} [rowranges $id] {
5994 if {$e >= $numcommits} {
5995 set e [expr {$numcommits - 1}]
5996 }
5997 if {$e <= $s} continue
5998 for {set row $e} {[incr row -1] >= $s} {} {
5999 set x [lsearch -exact [lindex $rowidlist $row] $id]
6000 if {$x < 0} break
6001 set olds [lindex $parentlist $row]
6002 set kid [lindex $displayorder $row]
6003 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6004 if {$kidx < 0} continue
6005 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6006 foreach p $olds {
6007 set px [lsearch -exact $nextrow $p]
6008 if {$px < 0} continue
6009 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6010 if {[lsearch -exact $ccross $p] >= 0} continue
6011 if {$x == $px + ($kidx < $px? -1: 1)} {
6012 lappend ccross $p
6013 } elseif {[lsearch -exact $cross $p] < 0} {
6014 lappend cross $p
6015 }
6016 }
6017 }
6018 }
6019 }
6020 return [concat $ccross {{}} $cross]
6021 }
6023 proc assigncolor {id} {
6024 global colormap colors nextcolor
6025 global parents children children curview
6027 if {[info exists colormap($id)]} return
6028 set ncolors [llength $colors]
6029 if {[info exists children($curview,$id)]} {
6030 set kids $children($curview,$id)
6031 } else {
6032 set kids {}
6033 }
6034 if {[llength $kids] == 1} {
6035 set child [lindex $kids 0]
6036 if {[info exists colormap($child)]
6037 && [llength $parents($curview,$child)] == 1} {
6038 set colormap($id) $colormap($child)
6039 return
6040 }
6041 }
6042 set badcolors {}
6043 set origbad {}
6044 foreach x [findcrossings $id] {
6045 if {$x eq {}} {
6046 # delimiter between corner crossings and other crossings
6047 if {[llength $badcolors] >= $ncolors - 1} break
6048 set origbad $badcolors
6049 }
6050 if {[info exists colormap($x)]
6051 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6052 lappend badcolors $colormap($x)
6053 }
6054 }
6055 if {[llength $badcolors] >= $ncolors} {
6056 set badcolors $origbad
6057 }
6058 set origbad $badcolors
6059 if {[llength $badcolors] < $ncolors - 1} {
6060 foreach child $kids {
6061 if {[info exists colormap($child)]
6062 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6063 lappend badcolors $colormap($child)
6064 }
6065 foreach p $parents($curview,$child) {
6066 if {[info exists colormap($p)]
6067 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6068 lappend badcolors $colormap($p)
6069 }
6070 }
6071 }
6072 if {[llength $badcolors] >= $ncolors} {
6073 set badcolors $origbad
6074 }
6075 }
6076 for {set i 0} {$i <= $ncolors} {incr i} {
6077 set c [lindex $colors $nextcolor]
6078 if {[incr nextcolor] >= $ncolors} {
6079 set nextcolor 0
6080 }
6081 if {[lsearch -exact $badcolors $c]} break
6082 }
6083 set colormap($id) $c
6084 }
6086 proc bindline {t id} {
6087 global canv
6089 $canv bind $t <Enter> "lineenter %x %y $id"
6090 $canv bind $t <Motion> "linemotion %x %y $id"
6091 $canv bind $t <Leave> "lineleave $id"
6092 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6093 }
6095 proc drawtags {id x xt y1} {
6096 global idtags idheads idotherrefs mainhead
6097 global linespc lthickness
6098 global canv rowtextx curview fgcolor bgcolor ctxbut
6100 set marks {}
6101 set ntags 0
6102 set nheads 0
6103 if {[info exists idtags($id)]} {
6104 set marks $idtags($id)
6105 set ntags [llength $marks]
6106 }
6107 if {[info exists idheads($id)]} {
6108 set marks [concat $marks $idheads($id)]
6109 set nheads [llength $idheads($id)]
6110 }
6111 if {[info exists idotherrefs($id)]} {
6112 set marks [concat $marks $idotherrefs($id)]
6113 }
6114 if {$marks eq {}} {
6115 return $xt
6116 }
6118 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6119 set yt [expr {$y1 - 0.5 * $linespc}]
6120 set yb [expr {$yt + $linespc - 1}]
6121 set xvals {}
6122 set wvals {}
6123 set i -1
6124 foreach tag $marks {
6125 incr i
6126 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6127 set wid [font measure mainfontbold $tag]
6128 } else {
6129 set wid [font measure mainfont $tag]
6130 }
6131 lappend xvals $xt
6132 lappend wvals $wid
6133 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6134 }
6135 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6136 -width $lthickness -fill black -tags tag.$id]
6137 $canv lower $t
6138 foreach tag $marks x $xvals wid $wvals {
6139 set xl [expr {$x + $delta}]
6140 set xr [expr {$x + $delta + $wid + $lthickness}]
6141 set font mainfont
6142 if {[incr ntags -1] >= 0} {
6143 # draw a tag
6144 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6145 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6146 -width 1 -outline black -fill yellow -tags tag.$id]
6147 $canv bind $t <1> [list showtag $tag 1]
6148 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6149 } else {
6150 # draw a head or other ref
6151 if {[incr nheads -1] >= 0} {
6152 set col green
6153 if {$tag eq $mainhead} {
6154 set font mainfontbold
6155 }
6156 } else {
6157 set col "#ddddff"
6158 }
6159 set xl [expr {$xl - $delta/2}]
6160 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6161 -width 1 -outline black -fill $col -tags tag.$id
6162 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6163 set rwid [font measure mainfont $remoteprefix]
6164 set xi [expr {$x + 1}]
6165 set yti [expr {$yt + 1}]
6166 set xri [expr {$x + $rwid}]
6167 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6168 -width 0 -fill "#ffddaa" -tags tag.$id
6169 }
6170 }
6171 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6172 -font $font -tags [list tag.$id text]]
6173 if {$ntags >= 0} {
6174 $canv bind $t <1> [list showtag $tag 1]
6175 } elseif {$nheads >= 0} {
6176 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6177 }
6178 }
6179 return $xt
6180 }
6182 proc xcoord {i level ln} {
6183 global canvx0 xspc1 xspc2
6185 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6186 if {$i > 0 && $i == $level} {
6187 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6188 } elseif {$i > $level} {
6189 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6190 }
6191 return $x
6192 }
6194 proc show_status {msg} {
6195 global canv fgcolor
6197 clear_display
6198 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6199 -tags text -fill $fgcolor
6200 }
6202 # Don't change the text pane cursor if it is currently the hand cursor,
6203 # showing that we are over a sha1 ID link.
6204 proc settextcursor {c} {
6205 global ctext curtextcursor
6207 if {[$ctext cget -cursor] == $curtextcursor} {
6208 $ctext config -cursor $c
6209 }
6210 set curtextcursor $c
6211 }
6213 proc nowbusy {what {name {}}} {
6214 global isbusy busyname statusw
6216 if {[array names isbusy] eq {}} {
6217 . config -cursor watch
6218 settextcursor watch
6219 }
6220 set isbusy($what) 1
6221 set busyname($what) $name
6222 if {$name ne {}} {
6223 $statusw conf -text $name
6224 }
6225 }
6227 proc notbusy {what} {
6228 global isbusy maincursor textcursor busyname statusw
6230 catch {
6231 unset isbusy($what)
6232 if {$busyname($what) ne {} &&
6233 [$statusw cget -text] eq $busyname($what)} {
6234 $statusw conf -text {}
6235 }
6236 }
6237 if {[array names isbusy] eq {}} {
6238 . config -cursor $maincursor
6239 settextcursor $textcursor
6240 }
6241 }
6243 proc findmatches {f} {
6244 global findtype findstring
6245 if {$findtype == [mc "Regexp"]} {
6246 set matches [regexp -indices -all -inline $findstring $f]
6247 } else {
6248 set fs $findstring
6249 if {$findtype == [mc "IgnCase"]} {
6250 set f [string tolower $f]
6251 set fs [string tolower $fs]
6252 }
6253 set matches {}
6254 set i 0
6255 set l [string length $fs]
6256 while {[set j [string first $fs $f $i]] >= 0} {
6257 lappend matches [list $j [expr {$j+$l-1}]]
6258 set i [expr {$j + $l}]
6259 }
6260 }
6261 return $matches
6262 }
6264 proc dofind {{dirn 1} {wrap 1}} {
6265 global findstring findstartline findcurline selectedline numcommits
6266 global gdttype filehighlight fh_serial find_dirn findallowwrap
6268 if {[info exists find_dirn]} {
6269 if {$find_dirn == $dirn} return
6270 stopfinding
6271 }
6272 focus .
6273 if {$findstring eq {} || $numcommits == 0} return
6274 if {$selectedline eq {}} {
6275 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6276 } else {
6277 set findstartline $selectedline
6278 }
6279 set findcurline $findstartline
6280 nowbusy finding [mc "Searching"]
6281 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6282 after cancel do_file_hl $fh_serial
6283 do_file_hl $fh_serial
6284 }
6285 set find_dirn $dirn
6286 set findallowwrap $wrap
6287 run findmore
6288 }
6290 proc stopfinding {} {
6291 global find_dirn findcurline fprogcoord
6293 if {[info exists find_dirn]} {
6294 unset find_dirn
6295 unset findcurline
6296 notbusy finding
6297 set fprogcoord 0
6298 adjustprogress
6299 }
6300 stopblaming
6301 }
6303 proc findmore {} {
6304 global commitdata commitinfo numcommits findpattern findloc
6305 global findstartline findcurline findallowwrap
6306 global find_dirn gdttype fhighlights fprogcoord
6307 global curview varcorder vrownum varccommits vrowmod
6309 if {![info exists find_dirn]} {
6310 return 0
6311 }
6312 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6313 set l $findcurline
6314 set moretodo 0
6315 if {$find_dirn > 0} {
6316 incr l
6317 if {$l >= $numcommits} {
6318 set l 0
6319 }
6320 if {$l <= $findstartline} {
6321 set lim [expr {$findstartline + 1}]
6322 } else {
6323 set lim $numcommits
6324 set moretodo $findallowwrap
6325 }
6326 } else {
6327 if {$l == 0} {
6328 set l $numcommits
6329 }
6330 incr l -1
6331 if {$l >= $findstartline} {
6332 set lim [expr {$findstartline - 1}]
6333 } else {
6334 set lim -1
6335 set moretodo $findallowwrap
6336 }
6337 }
6338 set n [expr {($lim - $l) * $find_dirn}]
6339 if {$n > 500} {
6340 set n 500
6341 set moretodo 1
6342 }
6343 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6344 update_arcrows $curview
6345 }
6346 set found 0
6347 set domore 1
6348 set ai [bsearch $vrownum($curview) $l]
6349 set a [lindex $varcorder($curview) $ai]
6350 set arow [lindex $vrownum($curview) $ai]
6351 set ids [lindex $varccommits($curview,$a)]
6352 set arowend [expr {$arow + [llength $ids]}]
6353 if {$gdttype eq [mc "containing:"]} {
6354 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6355 if {$l < $arow || $l >= $arowend} {
6356 incr ai $find_dirn
6357 set a [lindex $varcorder($curview) $ai]
6358 set arow [lindex $vrownum($curview) $ai]
6359 set ids [lindex $varccommits($curview,$a)]
6360 set arowend [expr {$arow + [llength $ids]}]
6361 }
6362 set id [lindex $ids [expr {$l - $arow}]]
6363 # shouldn't happen unless git log doesn't give all the commits...
6364 if {![info exists commitdata($id)] ||
6365 ![doesmatch $commitdata($id)]} {
6366 continue
6367 }
6368 if {![info exists commitinfo($id)]} {
6369 getcommit $id
6370 }
6371 set info $commitinfo($id)
6372 foreach f $info ty $fldtypes {
6373 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6374 [doesmatch $f]} {
6375 set found 1
6376 break
6377 }
6378 }
6379 if {$found} break
6380 }
6381 } else {
6382 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6383 if {$l < $arow || $l >= $arowend} {
6384 incr ai $find_dirn
6385 set a [lindex $varcorder($curview) $ai]
6386 set arow [lindex $vrownum($curview) $ai]
6387 set ids [lindex $varccommits($curview,$a)]
6388 set arowend [expr {$arow + [llength $ids]}]
6389 }
6390 set id [lindex $ids [expr {$l - $arow}]]
6391 if {![info exists fhighlights($id)]} {
6392 # this sets fhighlights($id) to -1
6393 askfilehighlight $l $id
6394 }
6395 if {$fhighlights($id) > 0} {
6396 set found $domore
6397 break
6398 }
6399 if {$fhighlights($id) < 0} {
6400 if {$domore} {
6401 set domore 0
6402 set findcurline [expr {$l - $find_dirn}]
6403 }
6404 }
6405 }
6406 }
6407 if {$found || ($domore && !$moretodo)} {
6408 unset findcurline
6409 unset find_dirn
6410 notbusy finding
6411 set fprogcoord 0
6412 adjustprogress
6413 if {$found} {
6414 findselectline $l
6415 } else {
6416 bell
6417 }
6418 return 0
6419 }
6420 if {!$domore} {
6421 flushhighlights
6422 } else {
6423 set findcurline [expr {$l - $find_dirn}]
6424 }
6425 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6426 if {$n < 0} {
6427 incr n $numcommits
6428 }
6429 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6430 adjustprogress
6431 return $domore
6432 }
6434 proc findselectline {l} {
6435 global findloc commentend ctext findcurline markingmatches gdttype
6437 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6438 set findcurline $l
6439 selectline $l 1
6440 if {$markingmatches &&
6441 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6442 # highlight the matches in the comments
6443 set f [$ctext get 1.0 $commentend]
6444 set matches [findmatches $f]
6445 foreach match $matches {
6446 set start [lindex $match 0]
6447 set end [expr {[lindex $match 1] + 1}]
6448 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6449 }
6450 }
6451 drawvisible
6452 }
6454 # mark the bits of a headline or author that match a find string
6455 proc markmatches {canv l str tag matches font row} {
6456 global selectedline
6458 set bbox [$canv bbox $tag]
6459 set x0 [lindex $bbox 0]
6460 set y0 [lindex $bbox 1]
6461 set y1 [lindex $bbox 3]
6462 foreach match $matches {
6463 set start [lindex $match 0]
6464 set end [lindex $match 1]
6465 if {$start > $end} continue
6466 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6467 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6468 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6469 [expr {$x0+$xlen+2}] $y1 \
6470 -outline {} -tags [list match$l matches] -fill yellow]
6471 $canv lower $t
6472 if {$row == $selectedline} {
6473 $canv raise $t secsel
6474 }
6475 }
6476 }
6478 proc unmarkmatches {} {
6479 global markingmatches
6481 allcanvs delete matches
6482 set markingmatches 0
6483 stopfinding
6484 }
6486 proc selcanvline {w x y} {
6487 global canv canvy0 ctext linespc
6488 global rowtextx
6489 set ymax [lindex [$canv cget -scrollregion] 3]
6490 if {$ymax == {}} return
6491 set yfrac [lindex [$canv yview] 0]
6492 set y [expr {$y + $yfrac * $ymax}]
6493 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6494 if {$l < 0} {
6495 set l 0
6496 }
6497 if {$w eq $canv} {
6498 set xmax [lindex [$canv cget -scrollregion] 2]
6499 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6500 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6501 }
6502 unmarkmatches
6503 selectline $l 1
6504 }
6506 proc commit_descriptor {p} {
6507 global commitinfo
6508 if {![info exists commitinfo($p)]} {
6509 getcommit $p
6510 }
6511 set l "..."
6512 if {[llength $commitinfo($p)] > 1} {
6513 set l [lindex $commitinfo($p) 0]
6514 }
6515 return "$p ($l)\n"
6516 }
6518 # append some text to the ctext widget, and make any SHA1 ID
6519 # that we know about be a clickable link.
6520 proc appendwithlinks {text tags} {
6521 global ctext linknum curview
6523 set start [$ctext index "end - 1c"]
6524 $ctext insert end $text $tags
6525 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6526 foreach l $links {
6527 set s [lindex $l 0]
6528 set e [lindex $l 1]
6529 set linkid [string range $text $s $e]
6530 incr e
6531 $ctext tag delete link$linknum
6532 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6533 setlink $linkid link$linknum
6534 incr linknum
6535 }
6536 }
6538 proc setlink {id lk} {
6539 global curview ctext pendinglinks
6541 set known 0
6542 if {[string length $id] < 40} {
6543 set matches [longid $id]
6544 if {[llength $matches] > 0} {
6545 if {[llength $matches] > 1} return
6546 set known 1
6547 set id [lindex $matches 0]
6548 }
6549 } else {
6550 set known [commitinview $id $curview]
6551 }
6552 if {$known} {
6553 $ctext tag conf $lk -foreground blue -underline 1
6554 $ctext tag bind $lk <1> [list selbyid $id]
6555 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6556 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6557 } else {
6558 lappend pendinglinks($id) $lk
6559 interestedin $id {makelink %P}
6560 }
6561 }
6563 proc appendshortlink {id {pre {}} {post {}}} {
6564 global ctext linknum
6566 $ctext insert end $pre
6567 $ctext tag delete link$linknum
6568 $ctext insert end [string range $id 0 7] link$linknum
6569 $ctext insert end $post
6570 setlink $id link$linknum
6571 incr linknum
6572 }
6574 proc makelink {id} {
6575 global pendinglinks
6577 if {![info exists pendinglinks($id)]} return
6578 foreach lk $pendinglinks($id) {
6579 setlink $id $lk
6580 }
6581 unset pendinglinks($id)
6582 }
6584 proc linkcursor {w inc} {
6585 global linkentercount curtextcursor
6587 if {[incr linkentercount $inc] > 0} {
6588 $w configure -cursor hand2
6589 } else {
6590 $w configure -cursor $curtextcursor
6591 if {$linkentercount < 0} {
6592 set linkentercount 0
6593 }
6594 }
6595 }
6597 proc viewnextline {dir} {
6598 global canv linespc
6600 $canv delete hover
6601 set ymax [lindex [$canv cget -scrollregion] 3]
6602 set wnow [$canv yview]
6603 set wtop [expr {[lindex $wnow 0] * $ymax}]
6604 set newtop [expr {$wtop + $dir * $linespc}]
6605 if {$newtop < 0} {
6606 set newtop 0
6607 } elseif {$newtop > $ymax} {
6608 set newtop $ymax
6609 }
6610 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6611 }
6613 # add a list of tag or branch names at position pos
6614 # returns the number of names inserted
6615 proc appendrefs {pos ids var} {
6616 global ctext linknum curview $var maxrefs
6618 if {[catch {$ctext index $pos}]} {
6619 return 0
6620 }
6621 $ctext conf -state normal
6622 $ctext delete $pos "$pos lineend"
6623 set tags {}
6624 foreach id $ids {
6625 foreach tag [set $var\($id\)] {
6626 lappend tags [list $tag $id]
6627 }
6628 }
6629 if {[llength $tags] > $maxrefs} {
6630 $ctext insert $pos "[mc "many"] ([llength $tags])"
6631 } else {
6632 set tags [lsort -index 0 -decreasing $tags]
6633 set sep {}
6634 foreach ti $tags {
6635 set id [lindex $ti 1]
6636 set lk link$linknum
6637 incr linknum
6638 $ctext tag delete $lk
6639 $ctext insert $pos $sep
6640 $ctext insert $pos [lindex $ti 0] $lk
6641 setlink $id $lk
6642 set sep ", "
6643 }
6644 }
6645 $ctext conf -state disabled
6646 return [llength $tags]
6647 }
6649 # called when we have finished computing the nearby tags
6650 proc dispneartags {delay} {
6651 global selectedline currentid showneartags tagphase
6653 if {$selectedline eq {} || !$showneartags} return
6654 after cancel dispnexttag
6655 if {$delay} {
6656 after 200 dispnexttag
6657 set tagphase -1
6658 } else {
6659 after idle dispnexttag
6660 set tagphase 0
6661 }
6662 }
6664 proc dispnexttag {} {
6665 global selectedline currentid showneartags tagphase ctext
6667 if {$selectedline eq {} || !$showneartags} return
6668 switch -- $tagphase {
6669 0 {
6670 set dtags [desctags $currentid]
6671 if {$dtags ne {}} {
6672 appendrefs precedes $dtags idtags
6673 }
6674 }
6675 1 {
6676 set atags [anctags $currentid]
6677 if {$atags ne {}} {
6678 appendrefs follows $atags idtags
6679 }
6680 }
6681 2 {
6682 set dheads [descheads $currentid]
6683 if {$dheads ne {}} {
6684 if {[appendrefs branch $dheads idheads] > 1
6685 && [$ctext get "branch -3c"] eq "h"} {
6686 # turn "Branch" into "Branches"
6687 $ctext conf -state normal
6688 $ctext insert "branch -2c" "es"
6689 $ctext conf -state disabled
6690 }
6691 }
6692 }
6693 }
6694 if {[incr tagphase] <= 2} {
6695 after idle dispnexttag
6696 }
6697 }
6699 proc make_secsel {id} {
6700 global linehtag linentag linedtag canv canv2 canv3
6702 if {![info exists linehtag($id)]} return
6703 $canv delete secsel
6704 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6705 -tags secsel -fill [$canv cget -selectbackground]]
6706 $canv lower $t
6707 $canv2 delete secsel
6708 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6709 -tags secsel -fill [$canv2 cget -selectbackground]]
6710 $canv2 lower $t
6711 $canv3 delete secsel
6712 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6713 -tags secsel -fill [$canv3 cget -selectbackground]]
6714 $canv3 lower $t
6715 }
6717 proc make_idmark {id} {
6718 global linehtag canv fgcolor
6720 if {![info exists linehtag($id)]} return
6721 $canv delete markid
6722 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6723 -tags markid -outline $fgcolor]
6724 $canv raise $t
6725 }
6727 proc selectline {l isnew {desired_loc {}}} {
6728 global canv ctext commitinfo selectedline
6729 global canvy0 linespc parents children curview
6730 global currentid sha1entry
6731 global commentend idtags linknum
6732 global mergemax numcommits pending_select
6733 global cmitmode showneartags allcommits
6734 global targetrow targetid lastscrollrows
6735 global autoselect jump_to_here
6737 catch {unset pending_select}
6738 $canv delete hover
6739 normalline
6740 unsel_reflist
6741 stopfinding
6742 if {$l < 0 || $l >= $numcommits} return
6743 set id [commitonrow $l]
6744 set targetid $id
6745 set targetrow $l
6746 set selectedline $l
6747 set currentid $id
6748 if {$lastscrollrows < $numcommits} {
6749 setcanvscroll
6750 }
6752 set y [expr {$canvy0 + $l * $linespc}]
6753 set ymax [lindex [$canv cget -scrollregion] 3]
6754 set ytop [expr {$y - $linespc - 1}]
6755 set ybot [expr {$y + $linespc + 1}]
6756 set wnow [$canv yview]
6757 set wtop [expr {[lindex $wnow 0] * $ymax}]
6758 set wbot [expr {[lindex $wnow 1] * $ymax}]
6759 set wh [expr {$wbot - $wtop}]
6760 set newtop $wtop
6761 if {$ytop < $wtop} {
6762 if {$ybot < $wtop} {
6763 set newtop [expr {$y - $wh / 2.0}]
6764 } else {
6765 set newtop $ytop
6766 if {$newtop > $wtop - $linespc} {
6767 set newtop [expr {$wtop - $linespc}]
6768 }
6769 }
6770 } elseif {$ybot > $wbot} {
6771 if {$ytop > $wbot} {
6772 set newtop [expr {$y - $wh / 2.0}]
6773 } else {
6774 set newtop [expr {$ybot - $wh}]
6775 if {$newtop < $wtop + $linespc} {
6776 set newtop [expr {$wtop + $linespc}]
6777 }
6778 }
6779 }
6780 if {$newtop != $wtop} {
6781 if {$newtop < 0} {
6782 set newtop 0
6783 }
6784 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6785 drawvisible
6786 }
6788 make_secsel $id
6790 if {$isnew} {
6791 addtohistory [list selbyid $id]
6792 }
6794 $sha1entry delete 0 end
6795 $sha1entry insert 0 $id
6796 if {$autoselect} {
6797 $sha1entry selection from 0
6798 $sha1entry selection to end
6799 }
6800 rhighlight_sel $id
6802 $ctext conf -state normal
6803 clear_ctext
6804 set linknum 0
6805 if {![info exists commitinfo($id)]} {
6806 getcommit $id
6807 }
6808 set info $commitinfo($id)
6809 set date [formatdate [lindex $info 2]]
6810 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6811 set date [formatdate [lindex $info 4]]
6812 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6813 if {[info exists idtags($id)]} {
6814 $ctext insert end [mc "Tags:"]
6815 foreach tag $idtags($id) {
6816 $ctext insert end " $tag"
6817 }
6818 $ctext insert end "\n"
6819 }
6821 set headers {}
6822 set olds $parents($curview,$id)
6823 if {[llength $olds] > 1} {
6824 set np 0
6825 foreach p $olds {
6826 if {$np >= $mergemax} {
6827 set tag mmax
6828 } else {
6829 set tag m$np
6830 }
6831 $ctext insert end "[mc "Parent"]: " $tag
6832 appendwithlinks [commit_descriptor $p] {}
6833 incr np
6834 }
6835 } else {
6836 foreach p $olds {
6837 append headers "[mc "Parent"]: [commit_descriptor $p]"
6838 }
6839 }
6841 foreach c $children($curview,$id) {
6842 append headers "[mc "Child"]: [commit_descriptor $c]"
6843 }
6845 # make anything that looks like a SHA1 ID be a clickable link
6846 appendwithlinks $headers {}
6847 if {$showneartags} {
6848 if {![info exists allcommits]} {
6849 getallcommits
6850 }
6851 $ctext insert end "[mc "Branch"]: "
6852 $ctext mark set branch "end -1c"
6853 $ctext mark gravity branch left
6854 $ctext insert end "\n[mc "Follows"]: "
6855 $ctext mark set follows "end -1c"
6856 $ctext mark gravity follows left
6857 $ctext insert end "\n[mc "Precedes"]: "
6858 $ctext mark set precedes "end -1c"
6859 $ctext mark gravity precedes left
6860 $ctext insert end "\n"
6861 dispneartags 1
6862 }
6863 $ctext insert end "\n"
6864 set comment [lindex $info 5]
6865 if {[string first "\r" $comment] >= 0} {
6866 set comment [string map {"\r" "\n "} $comment]
6867 }
6868 appendwithlinks $comment {comment}
6870 $ctext tag remove found 1.0 end
6871 $ctext conf -state disabled
6872 set commentend [$ctext index "end - 1c"]
6874 set jump_to_here $desired_loc
6875 init_flist [mc "Comments"]
6876 if {$cmitmode eq "tree"} {
6877 gettree $id
6878 } elseif {[llength $olds] <= 1} {
6879 startdiff $id
6880 } else {
6881 mergediff $id
6882 }
6883 }
6885 proc selfirstline {} {
6886 unmarkmatches
6887 selectline 0 1
6888 }
6890 proc sellastline {} {
6891 global numcommits
6892 unmarkmatches
6893 set l [expr {$numcommits - 1}]
6894 selectline $l 1
6895 }
6897 proc selnextline {dir} {
6898 global selectedline
6899 focus .
6900 if {$selectedline eq {}} return
6901 set l [expr {$selectedline + $dir}]
6902 unmarkmatches
6903 selectline $l 1
6904 }
6906 proc selnextpage {dir} {
6907 global canv linespc selectedline numcommits
6909 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6910 if {$lpp < 1} {
6911 set lpp 1
6912 }
6913 allcanvs yview scroll [expr {$dir * $lpp}] units
6914 drawvisible
6915 if {$selectedline eq {}} return
6916 set l [expr {$selectedline + $dir * $lpp}]
6917 if {$l < 0} {
6918 set l 0
6919 } elseif {$l >= $numcommits} {
6920 set l [expr $numcommits - 1]
6921 }
6922 unmarkmatches
6923 selectline $l 1
6924 }
6926 proc unselectline {} {
6927 global selectedline currentid
6929 set selectedline {}
6930 catch {unset currentid}
6931 allcanvs delete secsel
6932 rhighlight_none
6933 }
6935 proc reselectline {} {
6936 global selectedline
6938 if {$selectedline ne {}} {
6939 selectline $selectedline 0
6940 }
6941 }
6943 proc addtohistory {cmd} {
6944 global history historyindex curview
6946 set elt [list $curview $cmd]
6947 if {$historyindex > 0
6948 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6949 return
6950 }
6952 if {$historyindex < [llength $history]} {
6953 set history [lreplace $history $historyindex end $elt]
6954 } else {
6955 lappend history $elt
6956 }
6957 incr historyindex
6958 if {$historyindex > 1} {
6959 .tf.bar.leftbut conf -state normal
6960 } else {
6961 .tf.bar.leftbut conf -state disabled
6962 }
6963 .tf.bar.rightbut conf -state disabled
6964 }
6966 proc godo {elt} {
6967 global curview
6969 set view [lindex $elt 0]
6970 set cmd [lindex $elt 1]
6971 if {$curview != $view} {
6972 showview $view
6973 }
6974 eval $cmd
6975 }
6977 proc goback {} {
6978 global history historyindex
6979 focus .
6981 if {$historyindex > 1} {
6982 incr historyindex -1
6983 godo [lindex $history [expr {$historyindex - 1}]]
6984 .tf.bar.rightbut conf -state normal
6985 }
6986 if {$historyindex <= 1} {
6987 .tf.bar.leftbut conf -state disabled
6988 }
6989 }
6991 proc goforw {} {
6992 global history historyindex
6993 focus .
6995 if {$historyindex < [llength $history]} {
6996 set cmd [lindex $history $historyindex]
6997 incr historyindex
6998 godo $cmd
6999 .tf.bar.leftbut conf -state normal
7000 }
7001 if {$historyindex >= [llength $history]} {
7002 .tf.bar.rightbut conf -state disabled
7003 }
7004 }
7006 proc gettree {id} {
7007 global treefilelist treeidlist diffids diffmergeid treepending
7008 global nullid nullid2
7010 set diffids $id
7011 catch {unset diffmergeid}
7012 if {![info exists treefilelist($id)]} {
7013 if {![info exists treepending]} {
7014 if {$id eq $nullid} {
7015 set cmd [list | git ls-files]
7016 } elseif {$id eq $nullid2} {
7017 set cmd [list | git ls-files --stage -t]
7018 } else {
7019 set cmd [list | git ls-tree -r $id]
7020 }
7021 if {[catch {set gtf [open $cmd r]}]} {
7022 return
7023 }
7024 set treepending $id
7025 set treefilelist($id) {}
7026 set treeidlist($id) {}
7027 fconfigure $gtf -blocking 0 -encoding binary
7028 filerun $gtf [list gettreeline $gtf $id]
7029 }
7030 } else {
7031 setfilelist $id
7032 }
7033 }
7035 proc gettreeline {gtf id} {
7036 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7038 set nl 0
7039 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7040 if {$diffids eq $nullid} {
7041 set fname $line
7042 } else {
7043 set i [string first "\t" $line]
7044 if {$i < 0} continue
7045 set fname [string range $line [expr {$i+1}] end]
7046 set line [string range $line 0 [expr {$i-1}]]
7047 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7048 set sha1 [lindex $line 2]
7049 lappend treeidlist($id) $sha1
7050 }
7051 if {[string index $fname 0] eq "\""} {
7052 set fname [lindex $fname 0]
7053 }
7054 set fname [encoding convertfrom $fname]
7055 lappend treefilelist($id) $fname
7056 }
7057 if {![eof $gtf]} {
7058 return [expr {$nl >= 1000? 2: 1}]
7059 }
7060 close $gtf
7061 unset treepending
7062 if {$cmitmode ne "tree"} {
7063 if {![info exists diffmergeid]} {
7064 gettreediffs $diffids
7065 }
7066 } elseif {$id ne $diffids} {
7067 gettree $diffids
7068 } else {
7069 setfilelist $id
7070 }
7071 return 0
7072 }
7074 proc showfile {f} {
7075 global treefilelist treeidlist diffids nullid nullid2
7076 global ctext_file_names ctext_file_lines
7077 global ctext commentend
7079 set i [lsearch -exact $treefilelist($diffids) $f]
7080 if {$i < 0} {
7081 puts "oops, $f not in list for id $diffids"
7082 return
7083 }
7084 if {$diffids eq $nullid} {
7085 if {[catch {set bf [open $f r]} err]} {
7086 puts "oops, can't read $f: $err"
7087 return
7088 }
7089 } else {
7090 set blob [lindex $treeidlist($diffids) $i]
7091 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7092 puts "oops, error reading blob $blob: $err"
7093 return
7094 }
7095 }
7096 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7097 filerun $bf [list getblobline $bf $diffids]
7098 $ctext config -state normal
7099 clear_ctext $commentend
7100 lappend ctext_file_names $f
7101 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7102 $ctext insert end "\n"
7103 $ctext insert end "$f\n" filesep
7104 $ctext config -state disabled
7105 $ctext yview $commentend
7106 settabs 0
7107 }
7109 proc getblobline {bf id} {
7110 global diffids cmitmode ctext
7112 if {$id ne $diffids || $cmitmode ne "tree"} {
7113 catch {close $bf}
7114 return 0
7115 }
7116 $ctext config -state normal
7117 set nl 0
7118 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7119 $ctext insert end "$line\n"
7120 }
7121 if {[eof $bf]} {
7122 global jump_to_here ctext_file_names commentend
7124 # delete last newline
7125 $ctext delete "end - 2c" "end - 1c"
7126 close $bf
7127 if {$jump_to_here ne {} &&
7128 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7129 set lnum [expr {[lindex $jump_to_here 1] +
7130 [lindex [split $commentend .] 0]}]
7131 mark_ctext_line $lnum
7132 }
7133 return 0
7134 }
7135 $ctext config -state disabled
7136 return [expr {$nl >= 1000? 2: 1}]
7137 }
7139 proc mark_ctext_line {lnum} {
7140 global ctext markbgcolor
7142 $ctext tag delete omark
7143 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7144 $ctext tag conf omark -background $markbgcolor
7145 $ctext see $lnum.0
7146 }
7148 proc mergediff {id} {
7149 global diffmergeid
7150 global diffids treediffs
7151 global parents curview
7153 set diffmergeid $id
7154 set diffids $id
7155 set treediffs($id) {}
7156 set np [llength $parents($curview,$id)]
7157 settabs $np
7158 getblobdiffs $id
7159 }
7161 proc startdiff {ids} {
7162 global treediffs diffids treepending diffmergeid nullid nullid2
7164 settabs 1
7165 set diffids $ids
7166 catch {unset diffmergeid}
7167 if {![info exists treediffs($ids)] ||
7168 [lsearch -exact $ids $nullid] >= 0 ||
7169 [lsearch -exact $ids $nullid2] >= 0} {
7170 if {![info exists treepending]} {
7171 gettreediffs $ids
7172 }
7173 } else {
7174 addtocflist $ids
7175 }
7176 }
7178 proc path_filter {filter name} {
7179 foreach p $filter {
7180 set l [string length $p]
7181 if {[string index $p end] eq "/"} {
7182 if {[string compare -length $l $p $name] == 0} {
7183 return 1
7184 }
7185 } else {
7186 if {[string compare -length $l $p $name] == 0 &&
7187 ([string length $name] == $l ||
7188 [string index $name $l] eq "/")} {
7189 return 1
7190 }
7191 }
7192 }
7193 return 0
7194 }
7196 proc addtocflist {ids} {
7197 global treediffs
7199 add_flist $treediffs($ids)
7200 getblobdiffs $ids
7201 }
7203 proc diffcmd {ids flags} {
7204 global nullid nullid2
7206 set i [lsearch -exact $ids $nullid]
7207 set j [lsearch -exact $ids $nullid2]
7208 if {$i >= 0} {
7209 if {[llength $ids] > 1 && $j < 0} {
7210 # comparing working directory with some specific revision
7211 set cmd [concat | git diff-index $flags]
7212 if {$i == 0} {
7213 lappend cmd -R [lindex $ids 1]
7214 } else {
7215 lappend cmd [lindex $ids 0]
7216 }
7217 } else {
7218 # comparing working directory with index
7219 set cmd [concat | git diff-files $flags]
7220 if {$j == 1} {
7221 lappend cmd -R
7222 }
7223 }
7224 } elseif {$j >= 0} {
7225 set cmd [concat | git diff-index --cached $flags]
7226 if {[llength $ids] > 1} {
7227 # comparing index with specific revision
7228 if {$j == 0} {
7229 lappend cmd -R [lindex $ids 1]
7230 } else {
7231 lappend cmd [lindex $ids 0]
7232 }
7233 } else {
7234 # comparing index with HEAD
7235 lappend cmd HEAD
7236 }
7237 } else {
7238 set cmd [concat | git diff-tree -r $flags $ids]
7239 }
7240 return $cmd
7241 }
7243 proc gettreediffs {ids} {
7244 global treediff treepending
7246 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7248 set treepending $ids
7249 set treediff {}
7250 fconfigure $gdtf -blocking 0 -encoding binary
7251 filerun $gdtf [list gettreediffline $gdtf $ids]
7252 }
7254 proc gettreediffline {gdtf ids} {
7255 global treediff treediffs treepending diffids diffmergeid
7256 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7258 set nr 0
7259 set sublist {}
7260 set max 1000
7261 if {$perfile_attrs} {
7262 # cache_gitattr is slow, and even slower on win32 where we
7263 # have to invoke it for only about 30 paths at a time
7264 set max 500
7265 if {[tk windowingsystem] == "win32"} {
7266 set max 120
7267 }
7268 }
7269 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7270 set i [string first "\t" $line]
7271 if {$i >= 0} {
7272 set file [string range $line [expr {$i+1}] end]
7273 if {[string index $file 0] eq "\""} {
7274 set file [lindex $file 0]
7275 }
7276 set file [encoding convertfrom $file]
7277 if {$file ne [lindex $treediff end]} {
7278 lappend treediff $file
7279 lappend sublist $file
7280 }
7281 }
7282 }
7283 if {$perfile_attrs} {
7284 cache_gitattr encoding $sublist
7285 }
7286 if {![eof $gdtf]} {
7287 return [expr {$nr >= $max? 2: 1}]
7288 }
7289 close $gdtf
7290 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7291 set flist {}
7292 foreach f $treediff {
7293 if {[path_filter $vfilelimit($curview) $f]} {
7294 lappend flist $f
7295 }
7296 }
7297 set treediffs($ids) $flist
7298 } else {
7299 set treediffs($ids) $treediff
7300 }
7301 unset treepending
7302 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7303 gettree $diffids
7304 } elseif {$ids != $diffids} {
7305 if {![info exists diffmergeid]} {
7306 gettreediffs $diffids
7307 }
7308 } else {
7309 addtocflist $ids
7310 }
7311 return 0
7312 }
7314 # empty string or positive integer
7315 proc diffcontextvalidate {v} {
7316 return [regexp {^(|[1-9][0-9]*)$} $v]
7317 }
7319 proc diffcontextchange {n1 n2 op} {
7320 global diffcontextstring diffcontext
7322 if {[string is integer -strict $diffcontextstring]} {
7323 if {$diffcontextstring >= 0} {
7324 set diffcontext $diffcontextstring
7325 reselectline
7326 }
7327 }
7328 }
7330 proc changeignorespace {} {
7331 reselectline
7332 }
7334 proc getblobdiffs {ids} {
7335 global blobdifffd diffids env
7336 global diffinhdr treediffs
7337 global diffcontext
7338 global ignorespace
7339 global limitdiffs vfilelimit curview
7340 global diffencoding targetline diffnparents
7341 global git_version
7343 set textconv {}
7344 if {[package vcompare $git_version "1.6.1"] >= 0} {
7345 set textconv "--textconv"
7346 }
7347 set submodule {}
7348 if {[package vcompare $git_version "1.6.6"] >= 0} {
7349 set submodule "--submodule"
7350 }
7351 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7352 if {$ignorespace} {
7353 append cmd " -w"
7354 }
7355 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7356 set cmd [concat $cmd -- $vfilelimit($curview)]
7357 }
7358 if {[catch {set bdf [open $cmd r]} err]} {
7359 error_popup [mc "Error getting diffs: %s" $err]
7360 return
7361 }
7362 set targetline {}
7363 set diffnparents 0
7364 set diffinhdr 0
7365 set diffencoding [get_path_encoding {}]
7366 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7367 set blobdifffd($ids) $bdf
7368 filerun $bdf [list getblobdiffline $bdf $diffids]
7369 }
7371 proc setinlist {var i val} {
7372 global $var
7374 while {[llength [set $var]] < $i} {
7375 lappend $var {}
7376 }
7377 if {[llength [set $var]] == $i} {
7378 lappend $var $val
7379 } else {
7380 lset $var $i $val
7381 }
7382 }
7384 proc makediffhdr {fname ids} {
7385 global ctext curdiffstart treediffs diffencoding
7386 global ctext_file_names jump_to_here targetline diffline
7388 set fname [encoding convertfrom $fname]
7389 set diffencoding [get_path_encoding $fname]
7390 set i [lsearch -exact $treediffs($ids) $fname]
7391 if {$i >= 0} {
7392 setinlist difffilestart $i $curdiffstart
7393 }
7394 lset ctext_file_names end $fname
7395 set l [expr {(78 - [string length $fname]) / 2}]
7396 set pad [string range "----------------------------------------" 1 $l]
7397 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7398 set targetline {}
7399 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7400 set targetline [lindex $jump_to_here 1]
7401 }
7402 set diffline 0
7403 }
7405 proc getblobdiffline {bdf ids} {
7406 global diffids blobdifffd ctext curdiffstart
7407 global diffnexthead diffnextnote difffilestart
7408 global ctext_file_names ctext_file_lines
7409 global diffinhdr treediffs mergemax diffnparents
7410 global diffencoding jump_to_here targetline diffline
7412 set nr 0
7413 $ctext conf -state normal
7414 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7415 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7416 catch {close $bdf}
7417 return 0
7418 }
7419 if {![string compare -length 5 "diff " $line]} {
7420 if {![regexp {^diff (--cc|--git) } $line m type]} {
7421 set line [encoding convertfrom $line]
7422 $ctext insert end "$line\n" hunksep
7423 continue
7424 }
7425 # start of a new file
7426 set diffinhdr 1
7427 $ctext insert end "\n"
7428 set curdiffstart [$ctext index "end - 1c"]
7429 lappend ctext_file_names ""
7430 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7431 $ctext insert end "\n" filesep
7433 if {$type eq "--cc"} {
7434 # start of a new file in a merge diff
7435 set fname [string range $line 10 end]
7436 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7437 lappend treediffs($ids) $fname
7438 add_flist [list $fname]
7439 }
7441 } else {
7442 set line [string range $line 11 end]
7443 # If the name hasn't changed the length will be odd,
7444 # the middle char will be a space, and the two bits either
7445 # side will be a/name and b/name, or "a/name" and "b/name".
7446 # If the name has changed we'll get "rename from" and
7447 # "rename to" or "copy from" and "copy to" lines following
7448 # this, and we'll use them to get the filenames.
7449 # This complexity is necessary because spaces in the
7450 # filename(s) don't get escaped.
7451 set l [string length $line]
7452 set i [expr {$l / 2}]
7453 if {!(($l & 1) && [string index $line $i] eq " " &&
7454 [string range $line 2 [expr {$i - 1}]] eq \
7455 [string range $line [expr {$i + 3}] end])} {
7456 continue
7457 }
7458 # unescape if quoted and chop off the a/ from the front
7459 if {[string index $line 0] eq "\""} {
7460 set fname [string range [lindex $line 0] 2 end]
7461 } else {
7462 set fname [string range $line 2 [expr {$i - 1}]]
7463 }
7464 }
7465 makediffhdr $fname $ids
7467 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7468 set fname [encoding convertfrom [string range $line 16 end]]
7469 $ctext insert end "\n"
7470 set curdiffstart [$ctext index "end - 1c"]
7471 lappend ctext_file_names $fname
7472 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7473 $ctext insert end "$line\n" filesep
7474 set i [lsearch -exact $treediffs($ids) $fname]
7475 if {$i >= 0} {
7476 setinlist difffilestart $i $curdiffstart
7477 }
7479 } elseif {![string compare -length 2 "@@" $line]} {
7480 regexp {^@@+} $line ats
7481 set line [encoding convertfrom $diffencoding $line]
7482 $ctext insert end "$line\n" hunksep
7483 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7484 set diffline $nl
7485 }
7486 set diffnparents [expr {[string length $ats] - 1}]
7487 set diffinhdr 0
7489 } elseif {![string compare -length 10 "Submodule " $line]} {
7490 # start of a new submodule
7491 if {[string compare [$ctext get "end - 4c" end] "\n \n\n"]} {
7492 $ctext insert end "\n"; # Add newline after commit message
7493 }
7494 set curdiffstart [$ctext index "end - 1c"]
7495 lappend ctext_file_names ""
7496 set fname [string range $line 10 [expr [string last " " $line] - 1]]
7497 lappend ctext_file_lines $fname
7498 makediffhdr $fname $ids
7499 $ctext insert end "\n$line\n" filesep
7500 } elseif {![string compare -length 3 " >" $line]} {
7501 $ctext insert end "$line\n" dresult
7502 } elseif {![string compare -length 3 " <" $line]} {
7503 $ctext insert end "$line\n" d0
7504 } elseif {$diffinhdr} {
7505 if {![string compare -length 12 "rename from " $line]} {
7506 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7507 if {[string index $fname 0] eq "\""} {
7508 set fname [lindex $fname 0]
7509 }
7510 set fname [encoding convertfrom $fname]
7511 set i [lsearch -exact $treediffs($ids) $fname]
7512 if {$i >= 0} {
7513 setinlist difffilestart $i $curdiffstart
7514 }
7515 } elseif {![string compare -length 10 $line "rename to "] ||
7516 ![string compare -length 8 $line "copy to "]} {
7517 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7518 if {[string index $fname 0] eq "\""} {
7519 set fname [lindex $fname 0]
7520 }
7521 makediffhdr $fname $ids
7522 } elseif {[string compare -length 3 $line "---"] == 0} {
7523 # do nothing
7524 continue
7525 } elseif {[string compare -length 3 $line "+++"] == 0} {
7526 set diffinhdr 0
7527 continue
7528 }
7529 $ctext insert end "$line\n" filesep
7531 } else {
7532 set line [string map {\x1A ^Z} \
7533 [encoding convertfrom $diffencoding $line]]
7534 # parse the prefix - one ' ', '-' or '+' for each parent
7535 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7536 set tag [expr {$diffnparents > 1? "m": "d"}]
7537 if {[string trim $prefix " -+"] eq {}} {
7538 # prefix only has " ", "-" and "+" in it: normal diff line
7539 set num [string first "-" $prefix]
7540 if {$num >= 0} {
7541 # removed line, first parent with line is $num
7542 if {$num >= $mergemax} {
7543 set num "max"
7544 }
7545 $ctext insert end "$line\n" $tag$num
7546 } else {
7547 set tags {}
7548 if {[string first "+" $prefix] >= 0} {
7549 # added line
7550 lappend tags ${tag}result
7551 if {$diffnparents > 1} {
7552 set num [string first " " $prefix]
7553 if {$num >= 0} {
7554 if {$num >= $mergemax} {
7555 set num "max"
7556 }
7557 lappend tags m$num
7558 }
7559 }
7560 }
7561 if {$targetline ne {}} {
7562 if {$diffline == $targetline} {
7563 set seehere [$ctext index "end - 1 chars"]
7564 set targetline {}
7565 } else {
7566 incr diffline
7567 }
7568 }
7569 $ctext insert end "$line\n" $tags
7570 }
7571 } else {
7572 # "\ No newline at end of file",
7573 # or something else we don't recognize
7574 $ctext insert end "$line\n" hunksep
7575 }
7576 }
7577 }
7578 if {[info exists seehere]} {
7579 mark_ctext_line [lindex [split $seehere .] 0]
7580 }
7581 $ctext conf -state disabled
7582 if {[eof $bdf]} {
7583 catch {close $bdf}
7584 return 0
7585 }
7586 return [expr {$nr >= 1000? 2: 1}]
7587 }
7589 proc changediffdisp {} {
7590 global ctext diffelide
7592 $ctext tag conf d0 -elide [lindex $diffelide 0]
7593 $ctext tag conf dresult -elide [lindex $diffelide 1]
7594 }
7596 proc highlightfile {loc cline} {
7597 global ctext cflist cflist_top
7599 $ctext yview $loc
7600 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7601 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7602 $cflist see $cline.0
7603 set cflist_top $cline
7604 }
7606 proc prevfile {} {
7607 global difffilestart ctext cmitmode
7609 if {$cmitmode eq "tree"} return
7610 set prev 0.0
7611 set prevline 1
7612 set here [$ctext index @0,0]
7613 foreach loc $difffilestart {
7614 if {[$ctext compare $loc >= $here]} {
7615 highlightfile $prev $prevline
7616 return
7617 }
7618 set prev $loc
7619 incr prevline
7620 }
7621 highlightfile $prev $prevline
7622 }
7624 proc nextfile {} {
7625 global difffilestart ctext cmitmode
7627 if {$cmitmode eq "tree"} return
7628 set here [$ctext index @0,0]
7629 set line 1
7630 foreach loc $difffilestart {
7631 incr line
7632 if {[$ctext compare $loc > $here]} {
7633 highlightfile $loc $line
7634 return
7635 }
7636 }
7637 }
7639 proc clear_ctext {{first 1.0}} {
7640 global ctext smarktop smarkbot
7641 global ctext_file_names ctext_file_lines
7642 global pendinglinks
7644 set l [lindex [split $first .] 0]
7645 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7646 set smarktop $l
7647 }
7648 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7649 set smarkbot $l
7650 }
7651 $ctext delete $first end
7652 if {$first eq "1.0"} {
7653 catch {unset pendinglinks}
7654 }
7655 set ctext_file_names {}
7656 set ctext_file_lines {}
7657 }
7659 proc settabs {{firstab {}}} {
7660 global firsttabstop tabstop ctext have_tk85
7662 if {$firstab ne {} && $have_tk85} {
7663 set firsttabstop $firstab
7664 }
7665 set w [font measure textfont "0"]
7666 if {$firsttabstop != 0} {
7667 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7668 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7669 } elseif {$have_tk85 || $tabstop != 8} {
7670 $ctext conf -tabs [expr {$tabstop * $w}]
7671 } else {
7672 $ctext conf -tabs {}
7673 }
7674 }
7676 proc incrsearch {name ix op} {
7677 global ctext searchstring searchdirn
7679 $ctext tag remove found 1.0 end
7680 if {[catch {$ctext index anchor}]} {
7681 # no anchor set, use start of selection, or of visible area
7682 set sel [$ctext tag ranges sel]
7683 if {$sel ne {}} {
7684 $ctext mark set anchor [lindex $sel 0]
7685 } elseif {$searchdirn eq "-forwards"} {
7686 $ctext mark set anchor @0,0
7687 } else {
7688 $ctext mark set anchor @0,[winfo height $ctext]
7689 }
7690 }
7691 if {$searchstring ne {}} {
7692 set here [$ctext search $searchdirn -- $searchstring anchor]
7693 if {$here ne {}} {
7694 $ctext see $here
7695 }
7696 searchmarkvisible 1
7697 }
7698 }
7700 proc dosearch {} {
7701 global sstring ctext searchstring searchdirn
7703 focus $sstring
7704 $sstring icursor end
7705 set searchdirn -forwards
7706 if {$searchstring ne {}} {
7707 set sel [$ctext tag ranges sel]
7708 if {$sel ne {}} {
7709 set start "[lindex $sel 0] + 1c"
7710 } elseif {[catch {set start [$ctext index anchor]}]} {
7711 set start "@0,0"
7712 }
7713 set match [$ctext search -count mlen -- $searchstring $start]
7714 $ctext tag remove sel 1.0 end
7715 if {$match eq {}} {
7716 bell
7717 return
7718 }
7719 $ctext see $match
7720 set mend "$match + $mlen c"
7721 $ctext tag add sel $match $mend
7722 $ctext mark unset anchor
7723 }
7724 }
7726 proc dosearchback {} {
7727 global sstring ctext searchstring searchdirn
7729 focus $sstring
7730 $sstring icursor end
7731 set searchdirn -backwards
7732 if {$searchstring ne {}} {
7733 set sel [$ctext tag ranges sel]
7734 if {$sel ne {}} {
7735 set start [lindex $sel 0]
7736 } elseif {[catch {set start [$ctext index anchor]}]} {
7737 set start @0,[winfo height $ctext]
7738 }
7739 set match [$ctext search -backwards -count ml -- $searchstring $start]
7740 $ctext tag remove sel 1.0 end
7741 if {$match eq {}} {
7742 bell
7743 return
7744 }
7745 $ctext see $match
7746 set mend "$match + $ml c"
7747 $ctext tag add sel $match $mend
7748 $ctext mark unset anchor
7749 }
7750 }
7752 proc searchmark {first last} {
7753 global ctext searchstring
7755 set mend $first.0
7756 while {1} {
7757 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7758 if {$match eq {}} break
7759 set mend "$match + $mlen c"
7760 $ctext tag add found $match $mend
7761 }
7762 }
7764 proc searchmarkvisible {doall} {
7765 global ctext smarktop smarkbot
7767 set topline [lindex [split [$ctext index @0,0] .] 0]
7768 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7769 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7770 # no overlap with previous
7771 searchmark $topline $botline
7772 set smarktop $topline
7773 set smarkbot $botline
7774 } else {
7775 if {$topline < $smarktop} {
7776 searchmark $topline [expr {$smarktop-1}]
7777 set smarktop $topline
7778 }
7779 if {$botline > $smarkbot} {
7780 searchmark [expr {$smarkbot+1}] $botline
7781 set smarkbot $botline
7782 }
7783 }
7784 }
7786 proc scrolltext {f0 f1} {
7787 global searchstring
7789 .bleft.bottom.sb set $f0 $f1
7790 if {$searchstring ne {}} {
7791 searchmarkvisible 0
7792 }
7793 }
7795 proc setcoords {} {
7796 global linespc charspc canvx0 canvy0
7797 global xspc1 xspc2 lthickness
7799 set linespc [font metrics mainfont -linespace]
7800 set charspc [font measure mainfont "m"]
7801 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7802 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7803 set lthickness [expr {int($linespc / 9) + 1}]
7804 set xspc1(0) $linespc
7805 set xspc2 $linespc
7806 }
7808 proc redisplay {} {
7809 global canv
7810 global selectedline
7812 set ymax [lindex [$canv cget -scrollregion] 3]
7813 if {$ymax eq {} || $ymax == 0} return
7814 set span [$canv yview]
7815 clear_display
7816 setcanvscroll
7817 allcanvs yview moveto [lindex $span 0]
7818 drawvisible
7819 if {$selectedline ne {}} {
7820 selectline $selectedline 0
7821 allcanvs yview moveto [lindex $span 0]
7822 }
7823 }
7825 proc parsefont {f n} {
7826 global fontattr
7828 set fontattr($f,family) [lindex $n 0]
7829 set s [lindex $n 1]
7830 if {$s eq {} || $s == 0} {
7831 set s 10
7832 } elseif {$s < 0} {
7833 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7834 }
7835 set fontattr($f,size) $s
7836 set fontattr($f,weight) normal
7837 set fontattr($f,slant) roman
7838 foreach style [lrange $n 2 end] {
7839 switch -- $style {
7840 "normal" -
7841 "bold" {set fontattr($f,weight) $style}
7842 "roman" -
7843 "italic" {set fontattr($f,slant) $style}
7844 }
7845 }
7846 }
7848 proc fontflags {f {isbold 0}} {
7849 global fontattr
7851 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7852 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7853 -slant $fontattr($f,slant)]
7854 }
7856 proc fontname {f} {
7857 global fontattr
7859 set n [list $fontattr($f,family) $fontattr($f,size)]
7860 if {$fontattr($f,weight) eq "bold"} {
7861 lappend n "bold"
7862 }
7863 if {$fontattr($f,slant) eq "italic"} {
7864 lappend n "italic"
7865 }
7866 return $n
7867 }
7869 proc incrfont {inc} {
7870 global mainfont textfont ctext canv cflist showrefstop
7871 global stopped entries fontattr
7873 unmarkmatches
7874 set s $fontattr(mainfont,size)
7875 incr s $inc
7876 if {$s < 1} {
7877 set s 1
7878 }
7879 set fontattr(mainfont,size) $s
7880 font config mainfont -size $s
7881 font config mainfontbold -size $s
7882 set mainfont [fontname mainfont]
7883 set s $fontattr(textfont,size)
7884 incr s $inc
7885 if {$s < 1} {
7886 set s 1
7887 }
7888 set fontattr(textfont,size) $s
7889 font config textfont -size $s
7890 font config textfontbold -size $s
7891 set textfont [fontname textfont]
7892 setcoords
7893 settabs
7894 redisplay
7895 }
7897 proc clearsha1 {} {
7898 global sha1entry sha1string
7899 if {[string length $sha1string] == 40} {
7900 $sha1entry delete 0 end
7901 }
7902 }
7904 proc sha1change {n1 n2 op} {
7905 global sha1string currentid sha1but
7906 if {$sha1string == {}
7907 || ([info exists currentid] && $sha1string == $currentid)} {
7908 set state disabled
7909 } else {
7910 set state normal
7911 }
7912 if {[$sha1but cget -state] == $state} return
7913 if {$state == "normal"} {
7914 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7915 } else {
7916 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7917 }
7918 }
7920 proc gotocommit {} {
7921 global sha1string tagids headids curview varcid
7923 if {$sha1string == {}
7924 || ([info exists currentid] && $sha1string == $currentid)} return
7925 if {[info exists tagids($sha1string)]} {
7926 set id $tagids($sha1string)
7927 } elseif {[info exists headids($sha1string)]} {
7928 set id $headids($sha1string)
7929 } else {
7930 set id [string tolower $sha1string]
7931 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7932 set matches [longid $id]
7933 if {$matches ne {}} {
7934 if {[llength $matches] > 1} {
7935 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7936 return
7937 }
7938 set id [lindex $matches 0]
7939 }
7940 } else {
7941 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
7942 error_popup [mc "Revision %s is not known" $sha1string]
7943 return
7944 }
7945 }
7946 }
7947 if {[commitinview $id $curview]} {
7948 selectline [rowofcommit $id] 1
7949 return
7950 }
7951 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7952 set msg [mc "SHA1 id %s is not known" $sha1string]
7953 } else {
7954 set msg [mc "Revision %s is not in the current view" $sha1string]
7955 }
7956 error_popup $msg
7957 }
7959 proc lineenter {x y id} {
7960 global hoverx hovery hoverid hovertimer
7961 global commitinfo canv
7963 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7964 set hoverx $x
7965 set hovery $y
7966 set hoverid $id
7967 if {[info exists hovertimer]} {
7968 after cancel $hovertimer
7969 }
7970 set hovertimer [after 500 linehover]
7971 $canv delete hover
7972 }
7974 proc linemotion {x y id} {
7975 global hoverx hovery hoverid hovertimer
7977 if {[info exists hoverid] && $id == $hoverid} {
7978 set hoverx $x
7979 set hovery $y
7980 if {[info exists hovertimer]} {
7981 after cancel $hovertimer
7982 }
7983 set hovertimer [after 500 linehover]
7984 }
7985 }
7987 proc lineleave {id} {
7988 global hoverid hovertimer canv
7990 if {[info exists hoverid] && $id == $hoverid} {
7991 $canv delete hover
7992 if {[info exists hovertimer]} {
7993 after cancel $hovertimer
7994 unset hovertimer
7995 }
7996 unset hoverid
7997 }
7998 }
8000 proc linehover {} {
8001 global hoverx hovery hoverid hovertimer
8002 global canv linespc lthickness
8003 global commitinfo
8005 set text [lindex $commitinfo($hoverid) 0]
8006 set ymax [lindex [$canv cget -scrollregion] 3]
8007 if {$ymax == {}} return
8008 set yfrac [lindex [$canv yview] 0]
8009 set x [expr {$hoverx + 2 * $linespc}]
8010 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8011 set x0 [expr {$x - 2 * $lthickness}]
8012 set y0 [expr {$y - 2 * $lthickness}]
8013 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8014 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8015 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8016 -fill \#ffff80 -outline black -width 1 -tags hover]
8017 $canv raise $t
8018 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8019 -font mainfont]
8020 $canv raise $t
8021 }
8023 proc clickisonarrow {id y} {
8024 global lthickness
8026 set ranges [rowranges $id]
8027 set thresh [expr {2 * $lthickness + 6}]
8028 set n [expr {[llength $ranges] - 1}]
8029 for {set i 1} {$i < $n} {incr i} {
8030 set row [lindex $ranges $i]
8031 if {abs([yc $row] - $y) < $thresh} {
8032 return $i
8033 }
8034 }
8035 return {}
8036 }
8038 proc arrowjump {id n y} {
8039 global canv
8041 # 1 <-> 2, 3 <-> 4, etc...
8042 set n [expr {(($n - 1) ^ 1) + 1}]
8043 set row [lindex [rowranges $id] $n]
8044 set yt [yc $row]
8045 set ymax [lindex [$canv cget -scrollregion] 3]
8046 if {$ymax eq {} || $ymax <= 0} return
8047 set view [$canv yview]
8048 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8049 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8050 if {$yfrac < 0} {
8051 set yfrac 0
8052 }
8053 allcanvs yview moveto $yfrac
8054 }
8056 proc lineclick {x y id isnew} {
8057 global ctext commitinfo children canv thickerline curview
8059 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8060 unmarkmatches
8061 unselectline
8062 normalline
8063 $canv delete hover
8064 # draw this line thicker than normal
8065 set thickerline $id
8066 drawlines $id
8067 if {$isnew} {
8068 set ymax [lindex [$canv cget -scrollregion] 3]
8069 if {$ymax eq {}} return
8070 set yfrac [lindex [$canv yview] 0]
8071 set y [expr {$y + $yfrac * $ymax}]
8072 }
8073 set dirn [clickisonarrow $id $y]
8074 if {$dirn ne {}} {
8075 arrowjump $id $dirn $y
8076 return
8077 }
8079 if {$isnew} {
8080 addtohistory [list lineclick $x $y $id 0]
8081 }
8082 # fill the details pane with info about this line
8083 $ctext conf -state normal
8084 clear_ctext
8085 settabs 0
8086 $ctext insert end "[mc "Parent"]:\t"
8087 $ctext insert end $id link0
8088 setlink $id link0
8089 set info $commitinfo($id)
8090 $ctext insert end "\n\t[lindex $info 0]\n"
8091 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8092 set date [formatdate [lindex $info 2]]
8093 $ctext insert end "\t[mc "Date"]:\t$date\n"
8094 set kids $children($curview,$id)
8095 if {$kids ne {}} {
8096 $ctext insert end "\n[mc "Children"]:"
8097 set i 0
8098 foreach child $kids {
8099 incr i
8100 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8101 set info $commitinfo($child)
8102 $ctext insert end "\n\t"
8103 $ctext insert end $child link$i
8104 setlink $child link$i
8105 $ctext insert end "\n\t[lindex $info 0]"
8106 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8107 set date [formatdate [lindex $info 2]]
8108 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8109 }
8110 }
8111 $ctext conf -state disabled
8112 init_flist {}
8113 }
8115 proc normalline {} {
8116 global thickerline
8117 if {[info exists thickerline]} {
8118 set id $thickerline
8119 unset thickerline
8120 drawlines $id
8121 }
8122 }
8124 proc selbyid {id} {
8125 global curview
8126 if {[commitinview $id $curview]} {
8127 selectline [rowofcommit $id] 1
8128 }
8129 }
8131 proc mstime {} {
8132 global startmstime
8133 if {![info exists startmstime]} {
8134 set startmstime [clock clicks -milliseconds]
8135 }
8136 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8137 }
8139 proc rowmenu {x y id} {
8140 global rowctxmenu selectedline rowmenuid curview
8141 global nullid nullid2 fakerowmenu mainhead markedid
8143 stopfinding
8144 set rowmenuid $id
8145 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8146 set state disabled
8147 } else {
8148 set state normal
8149 }
8150 if {$id ne $nullid && $id ne $nullid2} {
8151 set menu $rowctxmenu
8152 if {$mainhead ne {}} {
8153 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8154 } else {
8155 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8156 }
8157 if {[info exists markedid] && $markedid ne $id} {
8158 $menu entryconfigure 9 -state normal
8159 $menu entryconfigure 10 -state normal
8160 $menu entryconfigure 11 -state normal
8161 } else {
8162 $menu entryconfigure 9 -state disabled
8163 $menu entryconfigure 10 -state disabled
8164 $menu entryconfigure 11 -state disabled
8165 }
8166 } else {
8167 set menu $fakerowmenu
8168 }
8169 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8170 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8171 $menu entryconfigure [mca "Make patch"] -state $state
8172 tk_popup $menu $x $y
8173 }
8175 proc markhere {} {
8176 global rowmenuid markedid canv
8178 set markedid $rowmenuid
8179 make_idmark $markedid
8180 }
8182 proc gotomark {} {
8183 global markedid
8185 if {[info exists markedid]} {
8186 selbyid $markedid
8187 }
8188 }
8190 proc replace_by_kids {l r} {
8191 global curview children
8193 set id [commitonrow $r]
8194 set l [lreplace $l 0 0]
8195 foreach kid $children($curview,$id) {
8196 lappend l [rowofcommit $kid]
8197 }
8198 return [lsort -integer -decreasing -unique $l]
8199 }
8201 proc find_common_desc {} {
8202 global markedid rowmenuid curview children
8204 if {![info exists markedid]} return
8205 if {![commitinview $markedid $curview] ||
8206 ![commitinview $rowmenuid $curview]} return
8207 #set t1 [clock clicks -milliseconds]
8208 set l1 [list [rowofcommit $markedid]]
8209 set l2 [list [rowofcommit $rowmenuid]]
8210 while 1 {
8211 set r1 [lindex $l1 0]
8212 set r2 [lindex $l2 0]
8213 if {$r1 eq {} || $r2 eq {}} break
8214 if {$r1 == $r2} {
8215 selectline $r1 1
8216 break
8217 }
8218 if {$r1 > $r2} {
8219 set l1 [replace_by_kids $l1 $r1]
8220 } else {
8221 set l2 [replace_by_kids $l2 $r2]
8222 }
8223 }
8224 #set t2 [clock clicks -milliseconds]
8225 #puts "took [expr {$t2-$t1}]ms"
8226 }
8228 proc compare_commits {} {
8229 global markedid rowmenuid curview children
8231 if {![info exists markedid]} return
8232 if {![commitinview $markedid $curview]} return
8233 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8234 do_cmp_commits $markedid $rowmenuid
8235 }
8237 proc getpatchid {id} {
8238 global patchids
8240 if {![info exists patchids($id)]} {
8241 set cmd [diffcmd [list $id] {-p --root}]
8242 # trim off the initial "|"
8243 set cmd [lrange $cmd 1 end]
8244 if {[catch {
8245 set x [eval exec $cmd | git patch-id]
8246 set patchids($id) [lindex $x 0]
8247 }]} {
8248 set patchids($id) "error"
8249 }
8250 }
8251 return $patchids($id)
8252 }
8254 proc do_cmp_commits {a b} {
8255 global ctext curview parents children patchids commitinfo
8257 $ctext conf -state normal
8258 clear_ctext
8259 init_flist {}
8260 for {set i 0} {$i < 100} {incr i} {
8261 set skipa 0
8262 set skipb 0
8263 if {[llength $parents($curview,$a)] > 1} {
8264 appendshortlink $a [mc "Skipping merge commit "] "\n"
8265 set skipa 1
8266 } else {
8267 set patcha [getpatchid $a]
8268 }
8269 if {[llength $parents($curview,$b)] > 1} {
8270 appendshortlink $b [mc "Skipping merge commit "] "\n"
8271 set skipb 1
8272 } else {
8273 set patchb [getpatchid $b]
8274 }
8275 if {!$skipa && !$skipb} {
8276 set heada [lindex $commitinfo($a) 0]
8277 set headb [lindex $commitinfo($b) 0]
8278 if {$patcha eq "error"} {
8279 appendshortlink $a [mc "Error getting patch ID for "] \
8280 [mc " - stopping\n"]
8281 break
8282 }
8283 if {$patchb eq "error"} {
8284 appendshortlink $b [mc "Error getting patch ID for "] \
8285 [mc " - stopping\n"]
8286 break
8287 }
8288 if {$patcha eq $patchb} {
8289 if {$heada eq $headb} {
8290 appendshortlink $a [mc "Commit "]
8291 appendshortlink $b " == " " $heada\n"
8292 } else {
8293 appendshortlink $a [mc "Commit "] " $heada\n"
8294 appendshortlink $b [mc " is the same patch as\n "] \
8295 " $headb\n"
8296 }
8297 set skipa 1
8298 set skipb 1
8299 } else {
8300 $ctext insert end "\n"
8301 appendshortlink $a [mc "Commit "] " $heada\n"
8302 appendshortlink $b [mc " differs from\n "] \
8303 " $headb\n"
8304 $ctext insert end [mc "Diff of commits:\n\n"]
8305 $ctext conf -state disabled
8306 update
8307 diffcommits $a $b
8308 return
8309 }
8310 }
8311 if {$skipa} {
8312 if {[llength $children($curview,$a)] != 1} {
8313 $ctext insert end "\n"
8314 appendshortlink $a [mc "Commit "] \
8315 [mc " has %s children - stopping\n" \
8316 [llength $children($curview,$a)]]
8317 break
8318 }
8319 set a [lindex $children($curview,$a) 0]
8320 }
8321 if {$skipb} {
8322 if {[llength $children($curview,$b)] != 1} {
8323 appendshortlink $b [mc "Commit "] \
8324 [mc " has %s children - stopping\n" \
8325 [llength $children($curview,$b)]]
8326 break
8327 }
8328 set b [lindex $children($curview,$b) 0]
8329 }
8330 }
8331 $ctext conf -state disabled
8332 }
8334 proc diffcommits {a b} {
8335 global diffcontext diffids blobdifffd diffinhdr
8337 set tmpdir [gitknewtmpdir]
8338 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8339 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8340 if {[catch {
8341 exec git diff-tree -p --pretty $a >$fna
8342 exec git diff-tree -p --pretty $b >$fnb
8343 } err]} {
8344 error_popup [mc "Error writing commit to file: %s" $err]
8345 return
8346 }
8347 if {[catch {
8348 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8349 } err]} {
8350 error_popup [mc "Error diffing commits: %s" $err]
8351 return
8352 }
8353 set diffids [list commits $a $b]
8354 set blobdifffd($diffids) $fd
8355 set diffinhdr 0
8356 filerun $fd [list getblobdiffline $fd $diffids]
8357 }
8359 proc diffvssel {dirn} {
8360 global rowmenuid selectedline
8362 if {$selectedline eq {}} return
8363 if {$dirn} {
8364 set oldid [commitonrow $selectedline]
8365 set newid $rowmenuid
8366 } else {
8367 set oldid $rowmenuid
8368 set newid [commitonrow $selectedline]
8369 }
8370 addtohistory [list doseldiff $oldid $newid]
8371 doseldiff $oldid $newid
8372 }
8374 proc doseldiff {oldid newid} {
8375 global ctext
8376 global commitinfo
8378 $ctext conf -state normal
8379 clear_ctext
8380 init_flist [mc "Top"]
8381 $ctext insert end "[mc "From"] "
8382 $ctext insert end $oldid link0
8383 setlink $oldid link0
8384 $ctext insert end "\n "
8385 $ctext insert end [lindex $commitinfo($oldid) 0]
8386 $ctext insert end "\n\n[mc "To"] "
8387 $ctext insert end $newid link1
8388 setlink $newid link1
8389 $ctext insert end "\n "
8390 $ctext insert end [lindex $commitinfo($newid) 0]
8391 $ctext insert end "\n"
8392 $ctext conf -state disabled
8393 $ctext tag remove found 1.0 end
8394 startdiff [list $oldid $newid]
8395 }
8397 proc mkpatch {} {
8398 global rowmenuid currentid commitinfo patchtop patchnum
8400 if {![info exists currentid]} return
8401 set oldid $currentid
8402 set oldhead [lindex $commitinfo($oldid) 0]
8403 set newid $rowmenuid
8404 set newhead [lindex $commitinfo($newid) 0]
8405 set top .patch
8406 set patchtop $top
8407 catch {destroy $top}
8408 toplevel $top
8409 make_transient $top .
8410 label $top.title -text [mc "Generate patch"]
8411 grid $top.title - -pady 10
8412 label $top.from -text [mc "From:"]
8413 entry $top.fromsha1 -width 40 -relief flat
8414 $top.fromsha1 insert 0 $oldid
8415 $top.fromsha1 conf -state readonly
8416 grid $top.from $top.fromsha1 -sticky w
8417 entry $top.fromhead -width 60 -relief flat
8418 $top.fromhead insert 0 $oldhead
8419 $top.fromhead conf -state readonly
8420 grid x $top.fromhead -sticky w
8421 label $top.to -text [mc "To:"]
8422 entry $top.tosha1 -width 40 -relief flat
8423 $top.tosha1 insert 0 $newid
8424 $top.tosha1 conf -state readonly
8425 grid $top.to $top.tosha1 -sticky w
8426 entry $top.tohead -width 60 -relief flat
8427 $top.tohead insert 0 $newhead
8428 $top.tohead conf -state readonly
8429 grid x $top.tohead -sticky w
8430 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8431 grid $top.rev x -pady 10
8432 label $top.flab -text [mc "Output file:"]
8433 entry $top.fname -width 60
8434 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8435 incr patchnum
8436 grid $top.flab $top.fname -sticky w
8437 frame $top.buts
8438 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8439 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8440 bind $top <Key-Return> mkpatchgo
8441 bind $top <Key-Escape> mkpatchcan
8442 grid $top.buts.gen $top.buts.can
8443 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8444 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8445 grid $top.buts - -pady 10 -sticky ew
8446 focus $top.fname
8447 }
8449 proc mkpatchrev {} {
8450 global patchtop
8452 set oldid [$patchtop.fromsha1 get]
8453 set oldhead [$patchtop.fromhead get]
8454 set newid [$patchtop.tosha1 get]
8455 set newhead [$patchtop.tohead get]
8456 foreach e [list fromsha1 fromhead tosha1 tohead] \
8457 v [list $newid $newhead $oldid $oldhead] {
8458 $patchtop.$e conf -state normal
8459 $patchtop.$e delete 0 end
8460 $patchtop.$e insert 0 $v
8461 $patchtop.$e conf -state readonly
8462 }
8463 }
8465 proc mkpatchgo {} {
8466 global patchtop nullid nullid2
8468 set oldid [$patchtop.fromsha1 get]
8469 set newid [$patchtop.tosha1 get]
8470 set fname [$patchtop.fname get]
8471 set cmd [diffcmd [list $oldid $newid] -p]
8472 # trim off the initial "|"
8473 set cmd [lrange $cmd 1 end]
8474 lappend cmd >$fname &
8475 if {[catch {eval exec $cmd} err]} {
8476 error_popup "[mc "Error creating patch:"] $err" $patchtop
8477 }
8478 catch {destroy $patchtop}
8479 unset patchtop
8480 }
8482 proc mkpatchcan {} {
8483 global patchtop
8485 catch {destroy $patchtop}
8486 unset patchtop
8487 }
8489 proc mktag {} {
8490 global rowmenuid mktagtop commitinfo
8492 set top .maketag
8493 set mktagtop $top
8494 catch {destroy $top}
8495 toplevel $top
8496 make_transient $top .
8497 label $top.title -text [mc "Create tag"]
8498 grid $top.title - -pady 10
8499 label $top.id -text [mc "ID:"]
8500 entry $top.sha1 -width 40 -relief flat
8501 $top.sha1 insert 0 $rowmenuid
8502 $top.sha1 conf -state readonly
8503 grid $top.id $top.sha1 -sticky w
8504 entry $top.head -width 60 -relief flat
8505 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8506 $top.head conf -state readonly
8507 grid x $top.head -sticky w
8508 label $top.tlab -text [mc "Tag name:"]
8509 entry $top.tag -width 60
8510 grid $top.tlab $top.tag -sticky w
8511 frame $top.buts
8512 button $top.buts.gen -text [mc "Create"] -command mktaggo
8513 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8514 bind $top <Key-Return> mktaggo
8515 bind $top <Key-Escape> mktagcan
8516 grid $top.buts.gen $top.buts.can
8517 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8518 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8519 grid $top.buts - -pady 10 -sticky ew
8520 focus $top.tag
8521 }
8523 proc domktag {} {
8524 global mktagtop env tagids idtags
8526 set id [$mktagtop.sha1 get]
8527 set tag [$mktagtop.tag get]
8528 if {$tag == {}} {
8529 error_popup [mc "No tag name specified"] $mktagtop
8530 return 0
8531 }
8532 if {[info exists tagids($tag)]} {
8533 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8534 return 0
8535 }
8536 if {[catch {
8537 exec git tag $tag $id
8538 } err]} {
8539 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8540 return 0
8541 }
8543 set tagids($tag) $id
8544 lappend idtags($id) $tag
8545 redrawtags $id
8546 addedtag $id
8547 dispneartags 0
8548 run refill_reflist
8549 return 1
8550 }
8552 proc redrawtags {id} {
8553 global canv linehtag idpos currentid curview cmitlisted markedid
8554 global canvxmax iddrawn circleitem mainheadid circlecolors
8556 if {![commitinview $id $curview]} return
8557 if {![info exists iddrawn($id)]} return
8558 set row [rowofcommit $id]
8559 if {$id eq $mainheadid} {
8560 set ofill yellow
8561 } else {
8562 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8563 }
8564 $canv itemconf $circleitem($row) -fill $ofill
8565 $canv delete tag.$id
8566 set xt [eval drawtags $id $idpos($id)]
8567 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8568 set text [$canv itemcget $linehtag($id) -text]
8569 set font [$canv itemcget $linehtag($id) -font]
8570 set xr [expr {$xt + [font measure $font $text]}]
8571 if {$xr > $canvxmax} {
8572 set canvxmax $xr
8573 setcanvscroll
8574 }
8575 if {[info exists currentid] && $currentid == $id} {
8576 make_secsel $id
8577 }
8578 if {[info exists markedid] && $markedid eq $id} {
8579 make_idmark $id
8580 }
8581 }
8583 proc mktagcan {} {
8584 global mktagtop
8586 catch {destroy $mktagtop}
8587 unset mktagtop
8588 }
8590 proc mktaggo {} {
8591 if {![domktag]} return
8592 mktagcan
8593 }
8595 proc writecommit {} {
8596 global rowmenuid wrcomtop commitinfo wrcomcmd
8598 set top .writecommit
8599 set wrcomtop $top
8600 catch {destroy $top}
8601 toplevel $top
8602 make_transient $top .
8603 label $top.title -text [mc "Write commit to file"]
8604 grid $top.title - -pady 10
8605 label $top.id -text [mc "ID:"]
8606 entry $top.sha1 -width 40 -relief flat
8607 $top.sha1 insert 0 $rowmenuid
8608 $top.sha1 conf -state readonly
8609 grid $top.id $top.sha1 -sticky w
8610 entry $top.head -width 60 -relief flat
8611 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8612 $top.head conf -state readonly
8613 grid x $top.head -sticky w
8614 label $top.clab -text [mc "Command:"]
8615 entry $top.cmd -width 60 -textvariable wrcomcmd
8616 grid $top.clab $top.cmd -sticky w -pady 10
8617 label $top.flab -text [mc "Output file:"]
8618 entry $top.fname -width 60
8619 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8620 grid $top.flab $top.fname -sticky w
8621 frame $top.buts
8622 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8623 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8624 bind $top <Key-Return> wrcomgo
8625 bind $top <Key-Escape> wrcomcan
8626 grid $top.buts.gen $top.buts.can
8627 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8628 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8629 grid $top.buts - -pady 10 -sticky ew
8630 focus $top.fname
8631 }
8633 proc wrcomgo {} {
8634 global wrcomtop
8636 set id [$wrcomtop.sha1 get]
8637 set cmd "echo $id | [$wrcomtop.cmd get]"
8638 set fname [$wrcomtop.fname get]
8639 if {[catch {exec sh -c $cmd >$fname &} err]} {
8640 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8641 }
8642 catch {destroy $wrcomtop}
8643 unset wrcomtop
8644 }
8646 proc wrcomcan {} {
8647 global wrcomtop
8649 catch {destroy $wrcomtop}
8650 unset wrcomtop
8651 }
8653 proc mkbranch {} {
8654 global rowmenuid mkbrtop
8656 set top .makebranch
8657 catch {destroy $top}
8658 toplevel $top
8659 make_transient $top .
8660 label $top.title -text [mc "Create new branch"]
8661 grid $top.title - -pady 10
8662 label $top.id -text [mc "ID:"]
8663 entry $top.sha1 -width 40 -relief flat
8664 $top.sha1 insert 0 $rowmenuid
8665 $top.sha1 conf -state readonly
8666 grid $top.id $top.sha1 -sticky w
8667 label $top.nlab -text [mc "Name:"]
8668 entry $top.name -width 40
8669 grid $top.nlab $top.name -sticky w
8670 frame $top.buts
8671 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8672 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8673 bind $top <Key-Return> [list mkbrgo $top]
8674 bind $top <Key-Escape> "catch {destroy $top}"
8675 grid $top.buts.go $top.buts.can
8676 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8677 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8678 grid $top.buts - -pady 10 -sticky ew
8679 focus $top.name
8680 }
8682 proc mkbrgo {top} {
8683 global headids idheads
8685 set name [$top.name get]
8686 set id [$top.sha1 get]
8687 set cmdargs {}
8688 set old_id {}
8689 if {$name eq {}} {
8690 error_popup [mc "Please specify a name for the new branch"] $top
8691 return
8692 }
8693 if {[info exists headids($name)]} {
8694 if {![confirm_popup [mc \
8695 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8696 return
8697 }
8698 set old_id $headids($name)
8699 lappend cmdargs -f
8700 }
8701 catch {destroy $top}
8702 lappend cmdargs $name $id
8703 nowbusy newbranch
8704 update
8705 if {[catch {
8706 eval exec git branch $cmdargs
8707 } err]} {
8708 notbusy newbranch
8709 error_popup $err
8710 } else {
8711 notbusy newbranch
8712 if {$old_id ne {}} {
8713 movehead $id $name
8714 movedhead $id $name
8715 redrawtags $old_id
8716 redrawtags $id
8717 } else {
8718 set headids($name) $id
8719 lappend idheads($id) $name
8720 addedhead $id $name
8721 redrawtags $id
8722 }
8723 dispneartags 0
8724 run refill_reflist
8725 }
8726 }
8728 proc exec_citool {tool_args {baseid {}}} {
8729 global commitinfo env
8731 set save_env [array get env GIT_AUTHOR_*]
8733 if {$baseid ne {}} {
8734 if {![info exists commitinfo($baseid)]} {
8735 getcommit $baseid
8736 }
8737 set author [lindex $commitinfo($baseid) 1]
8738 set date [lindex $commitinfo($baseid) 2]
8739 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8740 $author author name email]
8741 && $date ne {}} {
8742 set env(GIT_AUTHOR_NAME) $name
8743 set env(GIT_AUTHOR_EMAIL) $email
8744 set env(GIT_AUTHOR_DATE) $date
8745 }
8746 }
8748 eval exec git citool $tool_args &
8750 array unset env GIT_AUTHOR_*
8751 array set env $save_env
8752 }
8754 proc cherrypick {} {
8755 global rowmenuid curview
8756 global mainhead mainheadid
8758 set oldhead [exec git rev-parse HEAD]
8759 set dheads [descheads $rowmenuid]
8760 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8761 set ok [confirm_popup [mc "Commit %s is already\
8762 included in branch %s -- really re-apply it?" \
8763 [string range $rowmenuid 0 7] $mainhead]]
8764 if {!$ok} return
8765 }
8766 nowbusy cherrypick [mc "Cherry-picking"]
8767 update
8768 # Unfortunately git-cherry-pick writes stuff to stderr even when
8769 # no error occurs, and exec takes that as an indication of error...
8770 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8771 notbusy cherrypick
8772 if {[regexp -line \
8773 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8774 $err msg fname]} {
8775 error_popup [mc "Cherry-pick failed because of local changes\
8776 to file '%s'.\nPlease commit, reset or stash\
8777 your changes and try again." $fname]
8778 } elseif {[regexp -line \
8779 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8780 $err]} {
8781 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8782 conflict.\nDo you wish to run git citool to\
8783 resolve it?"]]} {
8784 # Force citool to read MERGE_MSG
8785 file delete [file join [gitdir] "GITGUI_MSG"]
8786 exec_citool {} $rowmenuid
8787 }
8788 } else {
8789 error_popup $err
8790 }
8791 run updatecommits
8792 return
8793 }
8794 set newhead [exec git rev-parse HEAD]
8795 if {$newhead eq $oldhead} {
8796 notbusy cherrypick
8797 error_popup [mc "No changes committed"]
8798 return
8799 }
8800 addnewchild $newhead $oldhead
8801 if {[commitinview $oldhead $curview]} {
8802 # XXX this isn't right if we have a path limit...
8803 insertrow $newhead $oldhead $curview
8804 if {$mainhead ne {}} {
8805 movehead $newhead $mainhead
8806 movedhead $newhead $mainhead
8807 }
8808 set mainheadid $newhead
8809 redrawtags $oldhead
8810 redrawtags $newhead
8811 selbyid $newhead
8812 }
8813 notbusy cherrypick
8814 }
8816 proc resethead {} {
8817 global mainhead rowmenuid confirm_ok resettype
8819 set confirm_ok 0
8820 set w ".confirmreset"
8821 toplevel $w
8822 make_transient $w .
8823 wm title $w [mc "Confirm reset"]
8824 message $w.m -text \
8825 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8826 -justify center -aspect 1000
8827 pack $w.m -side top -fill x -padx 20 -pady 20
8828 frame $w.f -relief sunken -border 2
8829 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8830 grid $w.f.rt -sticky w
8831 set resettype mixed
8832 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8833 -text [mc "Soft: Leave working tree and index untouched"]
8834 grid $w.f.soft -sticky w
8835 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8836 -text [mc "Mixed: Leave working tree untouched, reset index"]
8837 grid $w.f.mixed -sticky w
8838 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8839 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8840 grid $w.f.hard -sticky w
8841 pack $w.f -side top -fill x
8842 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8843 pack $w.ok -side left -fill x -padx 20 -pady 20
8844 button $w.cancel -text [mc Cancel] -command "destroy $w"
8845 bind $w <Key-Escape> [list destroy $w]
8846 pack $w.cancel -side right -fill x -padx 20 -pady 20
8847 bind $w <Visibility> "grab $w; focus $w"
8848 tkwait window $w
8849 if {!$confirm_ok} return
8850 if {[catch {set fd [open \
8851 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8852 error_popup $err
8853 } else {
8854 dohidelocalchanges
8855 filerun $fd [list readresetstat $fd]
8856 nowbusy reset [mc "Resetting"]
8857 selbyid $rowmenuid
8858 }
8859 }
8861 proc readresetstat {fd} {
8862 global mainhead mainheadid showlocalchanges rprogcoord
8864 if {[gets $fd line] >= 0} {
8865 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8866 set rprogcoord [expr {1.0 * $m / $n}]
8867 adjustprogress
8868 }
8869 return 1
8870 }
8871 set rprogcoord 0
8872 adjustprogress
8873 notbusy reset
8874 if {[catch {close $fd} err]} {
8875 error_popup $err
8876 }
8877 set oldhead $mainheadid
8878 set newhead [exec git rev-parse HEAD]
8879 if {$newhead ne $oldhead} {
8880 movehead $newhead $mainhead
8881 movedhead $newhead $mainhead
8882 set mainheadid $newhead
8883 redrawtags $oldhead
8884 redrawtags $newhead
8885 }
8886 if {$showlocalchanges} {
8887 doshowlocalchanges
8888 }
8889 return 0
8890 }
8892 # context menu for a head
8893 proc headmenu {x y id head} {
8894 global headmenuid headmenuhead headctxmenu mainhead
8896 stopfinding
8897 set headmenuid $id
8898 set headmenuhead $head
8899 set state normal
8900 if {$head eq $mainhead} {
8901 set state disabled
8902 }
8903 $headctxmenu entryconfigure 0 -state $state
8904 $headctxmenu entryconfigure 1 -state $state
8905 tk_popup $headctxmenu $x $y
8906 }
8908 proc cobranch {} {
8909 global headmenuid headmenuhead headids
8910 global showlocalchanges
8912 # check the tree is clean first??
8913 nowbusy checkout [mc "Checking out"]
8914 update
8915 dohidelocalchanges
8916 if {[catch {
8917 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8918 } err]} {
8919 notbusy checkout
8920 error_popup $err
8921 if {$showlocalchanges} {
8922 dodiffindex
8923 }
8924 } else {
8925 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8926 }
8927 }
8929 proc readcheckoutstat {fd newhead newheadid} {
8930 global mainhead mainheadid headids showlocalchanges progresscoords
8931 global viewmainheadid curview
8933 if {[gets $fd line] >= 0} {
8934 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8935 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8936 adjustprogress
8937 }
8938 return 1
8939 }
8940 set progresscoords {0 0}
8941 adjustprogress
8942 notbusy checkout
8943 if {[catch {close $fd} err]} {
8944 error_popup $err
8945 }
8946 set oldmainid $mainheadid
8947 set mainhead $newhead
8948 set mainheadid $newheadid
8949 set viewmainheadid($curview) $newheadid
8950 redrawtags $oldmainid
8951 redrawtags $newheadid
8952 selbyid $newheadid
8953 if {$showlocalchanges} {
8954 dodiffindex
8955 }
8956 }
8958 proc rmbranch {} {
8959 global headmenuid headmenuhead mainhead
8960 global idheads
8962 set head $headmenuhead
8963 set id $headmenuid
8964 # this check shouldn't be needed any more...
8965 if {$head eq $mainhead} {
8966 error_popup [mc "Cannot delete the currently checked-out branch"]
8967 return
8968 }
8969 set dheads [descheads $id]
8970 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8971 # the stuff on this branch isn't on any other branch
8972 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8973 branch.\nReally delete branch %s?" $head $head]]} return
8974 }
8975 nowbusy rmbranch
8976 update
8977 if {[catch {exec git branch -D $head} err]} {
8978 notbusy rmbranch
8979 error_popup $err
8980 return
8981 }
8982 removehead $id $head
8983 removedhead $id $head
8984 redrawtags $id
8985 notbusy rmbranch
8986 dispneartags 0
8987 run refill_reflist
8988 }
8990 # Display a list of tags and heads
8991 proc showrefs {} {
8992 global showrefstop bgcolor fgcolor selectbgcolor
8993 global bglist fglist reflistfilter reflist maincursor
8995 set top .showrefs
8996 set showrefstop $top
8997 if {[winfo exists $top]} {
8998 raise $top
8999 refill_reflist
9000 return
9001 }
9002 toplevel $top
9003 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9004 make_transient $top .
9005 text $top.list -background $bgcolor -foreground $fgcolor \
9006 -selectbackground $selectbgcolor -font mainfont \
9007 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9008 -width 30 -height 20 -cursor $maincursor \
9009 -spacing1 1 -spacing3 1 -state disabled
9010 $top.list tag configure highlight -background $selectbgcolor
9011 lappend bglist $top.list
9012 lappend fglist $top.list
9013 scrollbar $top.ysb -command "$top.list yview" -orient vertical
9014 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9015 grid $top.list $top.ysb -sticky nsew
9016 grid $top.xsb x -sticky ew
9017 frame $top.f
9018 label $top.f.l -text "[mc "Filter"]: "
9019 entry $top.f.e -width 20 -textvariable reflistfilter
9020 set reflistfilter "*"
9021 trace add variable reflistfilter write reflistfilter_change
9022 pack $top.f.e -side right -fill x -expand 1
9023 pack $top.f.l -side left
9024 grid $top.f - -sticky ew -pady 2
9025 button $top.close -command [list destroy $top] -text [mc "Close"]
9026 bind $top <Key-Escape> [list destroy $top]
9027 grid $top.close -
9028 grid columnconfigure $top 0 -weight 1
9029 grid rowconfigure $top 0 -weight 1
9030 bind $top.list <1> {break}
9031 bind $top.list <B1-Motion> {break}
9032 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9033 set reflist {}
9034 refill_reflist
9035 }
9037 proc sel_reflist {w x y} {
9038 global showrefstop reflist headids tagids otherrefids
9040 if {![winfo exists $showrefstop]} return
9041 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9042 set ref [lindex $reflist [expr {$l-1}]]
9043 set n [lindex $ref 0]
9044 switch -- [lindex $ref 1] {
9045 "H" {selbyid $headids($n)}
9046 "T" {selbyid $tagids($n)}
9047 "o" {selbyid $otherrefids($n)}
9048 }
9049 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9050 }
9052 proc unsel_reflist {} {
9053 global showrefstop
9055 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9056 $showrefstop.list tag remove highlight 0.0 end
9057 }
9059 proc reflistfilter_change {n1 n2 op} {
9060 global reflistfilter
9062 after cancel refill_reflist
9063 after 200 refill_reflist
9064 }
9066 proc refill_reflist {} {
9067 global reflist reflistfilter showrefstop headids tagids otherrefids
9068 global curview
9070 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9071 set refs {}
9072 foreach n [array names headids] {
9073 if {[string match $reflistfilter $n]} {
9074 if {[commitinview $headids($n) $curview]} {
9075 lappend refs [list $n H]
9076 } else {
9077 interestedin $headids($n) {run refill_reflist}
9078 }
9079 }
9080 }
9081 foreach n [array names tagids] {
9082 if {[string match $reflistfilter $n]} {
9083 if {[commitinview $tagids($n) $curview]} {
9084 lappend refs [list $n T]
9085 } else {
9086 interestedin $tagids($n) {run refill_reflist}
9087 }
9088 }
9089 }
9090 foreach n [array names otherrefids] {
9091 if {[string match $reflistfilter $n]} {
9092 if {[commitinview $otherrefids($n) $curview]} {
9093 lappend refs [list $n o]
9094 } else {
9095 interestedin $otherrefids($n) {run refill_reflist}
9096 }
9097 }
9098 }
9099 set refs [lsort -index 0 $refs]
9100 if {$refs eq $reflist} return
9102 # Update the contents of $showrefstop.list according to the
9103 # differences between $reflist (old) and $refs (new)
9104 $showrefstop.list conf -state normal
9105 $showrefstop.list insert end "\n"
9106 set i 0
9107 set j 0
9108 while {$i < [llength $reflist] || $j < [llength $refs]} {
9109 if {$i < [llength $reflist]} {
9110 if {$j < [llength $refs]} {
9111 set cmp [string compare [lindex $reflist $i 0] \
9112 [lindex $refs $j 0]]
9113 if {$cmp == 0} {
9114 set cmp [string compare [lindex $reflist $i 1] \
9115 [lindex $refs $j 1]]
9116 }
9117 } else {
9118 set cmp -1
9119 }
9120 } else {
9121 set cmp 1
9122 }
9123 switch -- $cmp {
9124 -1 {
9125 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9126 incr i
9127 }
9128 0 {
9129 incr i
9130 incr j
9131 }
9132 1 {
9133 set l [expr {$j + 1}]
9134 $showrefstop.list image create $l.0 -align baseline \
9135 -image reficon-[lindex $refs $j 1] -padx 2
9136 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9137 incr j
9138 }
9139 }
9140 }
9141 set reflist $refs
9142 # delete last newline
9143 $showrefstop.list delete end-2c end-1c
9144 $showrefstop.list conf -state disabled
9145 }
9147 # Stuff for finding nearby tags
9148 proc getallcommits {} {
9149 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9150 global idheads idtags idotherrefs allparents tagobjid
9152 if {![info exists allcommits]} {
9153 set nextarc 0
9154 set allcommits 0
9155 set seeds {}
9156 set allcwait 0
9157 set cachedarcs 0
9158 set allccache [file join [gitdir] "gitk.cache"]
9159 if {![catch {
9160 set f [open $allccache r]
9161 set allcwait 1
9162 getcache $f
9163 }]} return
9164 }
9166 if {$allcwait} {
9167 return
9168 }
9169 set cmd [list | git rev-list --parents]
9170 set allcupdate [expr {$seeds ne {}}]
9171 if {!$allcupdate} {
9172 set ids "--all"
9173 } else {
9174 set refs [concat [array names idheads] [array names idtags] \
9175 [array names idotherrefs]]
9176 set ids {}
9177 set tagobjs {}
9178 foreach name [array names tagobjid] {
9179 lappend tagobjs $tagobjid($name)
9180 }
9181 foreach id [lsort -unique $refs] {
9182 if {![info exists allparents($id)] &&
9183 [lsearch -exact $tagobjs $id] < 0} {
9184 lappend ids $id
9185 }
9186 }
9187 if {$ids ne {}} {
9188 foreach id $seeds {
9189 lappend ids "^$id"
9190 }
9191 }
9192 }
9193 if {$ids ne {}} {
9194 set fd [open [concat $cmd $ids] r]
9195 fconfigure $fd -blocking 0
9196 incr allcommits
9197 nowbusy allcommits
9198 filerun $fd [list getallclines $fd]
9199 } else {
9200 dispneartags 0
9201 }
9202 }
9204 # Since most commits have 1 parent and 1 child, we group strings of
9205 # such commits into "arcs" joining branch/merge points (BMPs), which
9206 # are commits that either don't have 1 parent or don't have 1 child.
9207 #
9208 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9209 # arcout(id) - outgoing arcs for BMP
9210 # arcids(a) - list of IDs on arc including end but not start
9211 # arcstart(a) - BMP ID at start of arc
9212 # arcend(a) - BMP ID at end of arc
9213 # growing(a) - arc a is still growing
9214 # arctags(a) - IDs out of arcids (excluding end) that have tags
9215 # archeads(a) - IDs out of arcids (excluding end) that have heads
9216 # The start of an arc is at the descendent end, so "incoming" means
9217 # coming from descendents, and "outgoing" means going towards ancestors.
9219 proc getallclines {fd} {
9220 global allparents allchildren idtags idheads nextarc
9221 global arcnos arcids arctags arcout arcend arcstart archeads growing
9222 global seeds allcommits cachedarcs allcupdate
9224 set nid 0
9225 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9226 set id [lindex $line 0]
9227 if {[info exists allparents($id)]} {
9228 # seen it already
9229 continue
9230 }
9231 set cachedarcs 0
9232 set olds [lrange $line 1 end]
9233 set allparents($id) $olds
9234 if {![info exists allchildren($id)]} {
9235 set allchildren($id) {}
9236 set arcnos($id) {}
9237 lappend seeds $id
9238 } else {
9239 set a $arcnos($id)
9240 if {[llength $olds] == 1 && [llength $a] == 1} {
9241 lappend arcids($a) $id
9242 if {[info exists idtags($id)]} {
9243 lappend arctags($a) $id
9244 }
9245 if {[info exists idheads($id)]} {
9246 lappend archeads($a) $id
9247 }
9248 if {[info exists allparents($olds)]} {
9249 # seen parent already
9250 if {![info exists arcout($olds)]} {
9251 splitarc $olds
9252 }
9253 lappend arcids($a) $olds
9254 set arcend($a) $olds
9255 unset growing($a)
9256 }
9257 lappend allchildren($olds) $id
9258 lappend arcnos($olds) $a
9259 continue
9260 }
9261 }
9262 foreach a $arcnos($id) {
9263 lappend arcids($a) $id
9264 set arcend($a) $id
9265 unset growing($a)
9266 }
9268 set ao {}
9269 foreach p $olds {
9270 lappend allchildren($p) $id
9271 set a [incr nextarc]
9272 set arcstart($a) $id
9273 set archeads($a) {}
9274 set arctags($a) {}
9275 set archeads($a) {}
9276 set arcids($a) {}
9277 lappend ao $a
9278 set growing($a) 1
9279 if {[info exists allparents($p)]} {
9280 # seen it already, may need to make a new branch
9281 if {![info exists arcout($p)]} {
9282 splitarc $p
9283 }
9284 lappend arcids($a) $p
9285 set arcend($a) $p
9286 unset growing($a)
9287 }
9288 lappend arcnos($p) $a
9289 }
9290 set arcout($id) $ao
9291 }
9292 if {$nid > 0} {
9293 global cached_dheads cached_dtags cached_atags
9294 catch {unset cached_dheads}
9295 catch {unset cached_dtags}
9296 catch {unset cached_atags}
9297 }
9298 if {![eof $fd]} {
9299 return [expr {$nid >= 1000? 2: 1}]
9300 }
9301 set cacheok 1
9302 if {[catch {
9303 fconfigure $fd -blocking 1
9304 close $fd
9305 } err]} {
9306 # got an error reading the list of commits
9307 # if we were updating, try rereading the whole thing again
9308 if {$allcupdate} {
9309 incr allcommits -1
9310 dropcache $err
9311 return
9312 }
9313 error_popup "[mc "Error reading commit topology information;\
9314 branch and preceding/following tag information\
9315 will be incomplete."]\n($err)"
9316 set cacheok 0
9317 }
9318 if {[incr allcommits -1] == 0} {
9319 notbusy allcommits
9320 if {$cacheok} {
9321 run savecache
9322 }
9323 }
9324 dispneartags 0
9325 return 0
9326 }
9328 proc recalcarc {a} {
9329 global arctags archeads arcids idtags idheads
9331 set at {}
9332 set ah {}
9333 foreach id [lrange $arcids($a) 0 end-1] {
9334 if {[info exists idtags($id)]} {
9335 lappend at $id
9336 }
9337 if {[info exists idheads($id)]} {
9338 lappend ah $id
9339 }
9340 }
9341 set arctags($a) $at
9342 set archeads($a) $ah
9343 }
9345 proc splitarc {p} {
9346 global arcnos arcids nextarc arctags archeads idtags idheads
9347 global arcstart arcend arcout allparents growing
9349 set a $arcnos($p)
9350 if {[llength $a] != 1} {
9351 puts "oops splitarc called but [llength $a] arcs already"
9352 return
9353 }
9354 set a [lindex $a 0]
9355 set i [lsearch -exact $arcids($a) $p]
9356 if {$i < 0} {
9357 puts "oops splitarc $p not in arc $a"
9358 return
9359 }
9360 set na [incr nextarc]
9361 if {[info exists arcend($a)]} {
9362 set arcend($na) $arcend($a)
9363 } else {
9364 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9365 set j [lsearch -exact $arcnos($l) $a]
9366 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9367 }
9368 set tail [lrange $arcids($a) [expr {$i+1}] end]
9369 set arcids($a) [lrange $arcids($a) 0 $i]
9370 set arcend($a) $p
9371 set arcstart($na) $p
9372 set arcout($p) $na
9373 set arcids($na) $tail
9374 if {[info exists growing($a)]} {
9375 set growing($na) 1
9376 unset growing($a)
9377 }
9379 foreach id $tail {
9380 if {[llength $arcnos($id)] == 1} {
9381 set arcnos($id) $na
9382 } else {
9383 set j [lsearch -exact $arcnos($id) $a]
9384 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9385 }
9386 }
9388 # reconstruct tags and heads lists
9389 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9390 recalcarc $a
9391 recalcarc $na
9392 } else {
9393 set arctags($na) {}
9394 set archeads($na) {}
9395 }
9396 }
9398 # Update things for a new commit added that is a child of one
9399 # existing commit. Used when cherry-picking.
9400 proc addnewchild {id p} {
9401 global allparents allchildren idtags nextarc
9402 global arcnos arcids arctags arcout arcend arcstart archeads growing
9403 global seeds allcommits
9405 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9406 set allparents($id) [list $p]
9407 set allchildren($id) {}
9408 set arcnos($id) {}
9409 lappend seeds $id
9410 lappend allchildren($p) $id
9411 set a [incr nextarc]
9412 set arcstart($a) $id
9413 set archeads($a) {}
9414 set arctags($a) {}
9415 set arcids($a) [list $p]
9416 set arcend($a) $p
9417 if {![info exists arcout($p)]} {
9418 splitarc $p
9419 }
9420 lappend arcnos($p) $a
9421 set arcout($id) [list $a]
9422 }
9424 # This implements a cache for the topology information.
9425 # The cache saves, for each arc, the start and end of the arc,
9426 # the ids on the arc, and the outgoing arcs from the end.
9427 proc readcache {f} {
9428 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9429 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9430 global allcwait
9432 set a $nextarc
9433 set lim $cachedarcs
9434 if {$lim - $a > 500} {
9435 set lim [expr {$a + 500}]
9436 }
9437 if {[catch {
9438 if {$a == $lim} {
9439 # finish reading the cache and setting up arctags, etc.
9440 set line [gets $f]
9441 if {$line ne "1"} {error "bad final version"}
9442 close $f
9443 foreach id [array names idtags] {
9444 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9445 [llength $allparents($id)] == 1} {
9446 set a [lindex $arcnos($id) 0]
9447 if {$arctags($a) eq {}} {
9448 recalcarc $a
9449 }
9450 }
9451 }
9452 foreach id [array names idheads] {
9453 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9454 [llength $allparents($id)] == 1} {
9455 set a [lindex $arcnos($id) 0]
9456 if {$archeads($a) eq {}} {
9457 recalcarc $a
9458 }
9459 }
9460 }
9461 foreach id [lsort -unique $possible_seeds] {
9462 if {$arcnos($id) eq {}} {
9463 lappend seeds $id
9464 }
9465 }
9466 set allcwait 0
9467 } else {
9468 while {[incr a] <= $lim} {
9469 set line [gets $f]
9470 if {[llength $line] != 3} {error "bad line"}
9471 set s [lindex $line 0]
9472 set arcstart($a) $s
9473 lappend arcout($s) $a
9474 if {![info exists arcnos($s)]} {
9475 lappend possible_seeds $s
9476 set arcnos($s) {}
9477 }
9478 set e [lindex $line 1]
9479 if {$e eq {}} {
9480 set growing($a) 1
9481 } else {
9482 set arcend($a) $e
9483 if {![info exists arcout($e)]} {
9484 set arcout($e) {}
9485 }
9486 }
9487 set arcids($a) [lindex $line 2]
9488 foreach id $arcids($a) {
9489 lappend allparents($s) $id
9490 set s $id
9491 lappend arcnos($id) $a
9492 }
9493 if {![info exists allparents($s)]} {
9494 set allparents($s) {}
9495 }
9496 set arctags($a) {}
9497 set archeads($a) {}
9498 }
9499 set nextarc [expr {$a - 1}]
9500 }
9501 } err]} {
9502 dropcache $err
9503 return 0
9504 }
9505 if {!$allcwait} {
9506 getallcommits
9507 }
9508 return $allcwait
9509 }
9511 proc getcache {f} {
9512 global nextarc cachedarcs possible_seeds
9514 if {[catch {
9515 set line [gets $f]
9516 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9517 # make sure it's an integer
9518 set cachedarcs [expr {int([lindex $line 1])}]
9519 if {$cachedarcs < 0} {error "bad number of arcs"}
9520 set nextarc 0
9521 set possible_seeds {}
9522 run readcache $f
9523 } err]} {
9524 dropcache $err
9525 }
9526 return 0
9527 }
9529 proc dropcache {err} {
9530 global allcwait nextarc cachedarcs seeds
9532 #puts "dropping cache ($err)"
9533 foreach v {arcnos arcout arcids arcstart arcend growing \
9534 arctags archeads allparents allchildren} {
9535 global $v
9536 catch {unset $v}
9537 }
9538 set allcwait 0
9539 set nextarc 0
9540 set cachedarcs 0
9541 set seeds {}
9542 getallcommits
9543 }
9545 proc writecache {f} {
9546 global cachearc cachedarcs allccache
9547 global arcstart arcend arcnos arcids arcout
9549 set a $cachearc
9550 set lim $cachedarcs
9551 if {$lim - $a > 1000} {
9552 set lim [expr {$a + 1000}]
9553 }
9554 if {[catch {
9555 while {[incr a] <= $lim} {
9556 if {[info exists arcend($a)]} {
9557 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9558 } else {
9559 puts $f [list $arcstart($a) {} $arcids($a)]
9560 }
9561 }
9562 } err]} {
9563 catch {close $f}
9564 catch {file delete $allccache}
9565 #puts "writing cache failed ($err)"
9566 return 0
9567 }
9568 set cachearc [expr {$a - 1}]
9569 if {$a > $cachedarcs} {
9570 puts $f "1"
9571 close $f
9572 return 0
9573 }
9574 return 1
9575 }
9577 proc savecache {} {
9578 global nextarc cachedarcs cachearc allccache
9580 if {$nextarc == $cachedarcs} return
9581 set cachearc 0
9582 set cachedarcs $nextarc
9583 catch {
9584 set f [open $allccache w]
9585 puts $f [list 1 $cachedarcs]
9586 run writecache $f
9587 }
9588 }
9590 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9591 # or 0 if neither is true.
9592 proc anc_or_desc {a b} {
9593 global arcout arcstart arcend arcnos cached_isanc
9595 if {$arcnos($a) eq $arcnos($b)} {
9596 # Both are on the same arc(s); either both are the same BMP,
9597 # or if one is not a BMP, the other is also not a BMP or is
9598 # the BMP at end of the arc (and it only has 1 incoming arc).
9599 # Or both can be BMPs with no incoming arcs.
9600 if {$a eq $b || $arcnos($a) eq {}} {
9601 return 0
9602 }
9603 # assert {[llength $arcnos($a)] == 1}
9604 set arc [lindex $arcnos($a) 0]
9605 set i [lsearch -exact $arcids($arc) $a]
9606 set j [lsearch -exact $arcids($arc) $b]
9607 if {$i < 0 || $i > $j} {
9608 return 1
9609 } else {
9610 return -1
9611 }
9612 }
9614 if {![info exists arcout($a)]} {
9615 set arc [lindex $arcnos($a) 0]
9616 if {[info exists arcend($arc)]} {
9617 set aend $arcend($arc)
9618 } else {
9619 set aend {}
9620 }
9621 set a $arcstart($arc)
9622 } else {
9623 set aend $a
9624 }
9625 if {![info exists arcout($b)]} {
9626 set arc [lindex $arcnos($b) 0]
9627 if {[info exists arcend($arc)]} {
9628 set bend $arcend($arc)
9629 } else {
9630 set bend {}
9631 }
9632 set b $arcstart($arc)
9633 } else {
9634 set bend $b
9635 }
9636 if {$a eq $bend} {
9637 return 1
9638 }
9639 if {$b eq $aend} {
9640 return -1
9641 }
9642 if {[info exists cached_isanc($a,$bend)]} {
9643 if {$cached_isanc($a,$bend)} {
9644 return 1
9645 }
9646 }
9647 if {[info exists cached_isanc($b,$aend)]} {
9648 if {$cached_isanc($b,$aend)} {
9649 return -1
9650 }
9651 if {[info exists cached_isanc($a,$bend)]} {
9652 return 0
9653 }
9654 }
9656 set todo [list $a $b]
9657 set anc($a) a
9658 set anc($b) b
9659 for {set i 0} {$i < [llength $todo]} {incr i} {
9660 set x [lindex $todo $i]
9661 if {$anc($x) eq {}} {
9662 continue
9663 }
9664 foreach arc $arcnos($x) {
9665 set xd $arcstart($arc)
9666 if {$xd eq $bend} {
9667 set cached_isanc($a,$bend) 1
9668 set cached_isanc($b,$aend) 0
9669 return 1
9670 } elseif {$xd eq $aend} {
9671 set cached_isanc($b,$aend) 1
9672 set cached_isanc($a,$bend) 0
9673 return -1
9674 }
9675 if {![info exists anc($xd)]} {
9676 set anc($xd) $anc($x)
9677 lappend todo $xd
9678 } elseif {$anc($xd) ne $anc($x)} {
9679 set anc($xd) {}
9680 }
9681 }
9682 }
9683 set cached_isanc($a,$bend) 0
9684 set cached_isanc($b,$aend) 0
9685 return 0
9686 }
9688 # This identifies whether $desc has an ancestor that is
9689 # a growing tip of the graph and which is not an ancestor of $anc
9690 # and returns 0 if so and 1 if not.
9691 # If we subsequently discover a tag on such a growing tip, and that
9692 # turns out to be a descendent of $anc (which it could, since we
9693 # don't necessarily see children before parents), then $desc
9694 # isn't a good choice to display as a descendent tag of
9695 # $anc (since it is the descendent of another tag which is
9696 # a descendent of $anc). Similarly, $anc isn't a good choice to
9697 # display as a ancestor tag of $desc.
9698 #
9699 proc is_certain {desc anc} {
9700 global arcnos arcout arcstart arcend growing problems
9702 set certain {}
9703 if {[llength $arcnos($anc)] == 1} {
9704 # tags on the same arc are certain
9705 if {$arcnos($desc) eq $arcnos($anc)} {
9706 return 1
9707 }
9708 if {![info exists arcout($anc)]} {
9709 # if $anc is partway along an arc, use the start of the arc instead
9710 set a [lindex $arcnos($anc) 0]
9711 set anc $arcstart($a)
9712 }
9713 }
9714 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9715 set x $desc
9716 } else {
9717 set a [lindex $arcnos($desc) 0]
9718 set x $arcend($a)
9719 }
9720 if {$x == $anc} {
9721 return 1
9722 }
9723 set anclist [list $x]
9724 set dl($x) 1
9725 set nnh 1
9726 set ngrowanc 0
9727 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9728 set x [lindex $anclist $i]
9729 if {$dl($x)} {
9730 incr nnh -1
9731 }
9732 set done($x) 1
9733 foreach a $arcout($x) {
9734 if {[info exists growing($a)]} {
9735 if {![info exists growanc($x)] && $dl($x)} {
9736 set growanc($x) 1
9737 incr ngrowanc
9738 }
9739 } else {
9740 set y $arcend($a)
9741 if {[info exists dl($y)]} {
9742 if {$dl($y)} {
9743 if {!$dl($x)} {
9744 set dl($y) 0
9745 if {![info exists done($y)]} {
9746 incr nnh -1
9747 }
9748 if {[info exists growanc($x)]} {
9749 incr ngrowanc -1
9750 }
9751 set xl [list $y]
9752 for {set k 0} {$k < [llength $xl]} {incr k} {
9753 set z [lindex $xl $k]
9754 foreach c $arcout($z) {
9755 if {[info exists arcend($c)]} {
9756 set v $arcend($c)
9757 if {[info exists dl($v)] && $dl($v)} {
9758 set dl($v) 0
9759 if {![info exists done($v)]} {
9760 incr nnh -1
9761 }
9762 if {[info exists growanc($v)]} {
9763 incr ngrowanc -1
9764 }
9765 lappend xl $v
9766 }
9767 }
9768 }
9769 }
9770 }
9771 }
9772 } elseif {$y eq $anc || !$dl($x)} {
9773 set dl($y) 0
9774 lappend anclist $y
9775 } else {
9776 set dl($y) 1
9777 lappend anclist $y
9778 incr nnh
9779 }
9780 }
9781 }
9782 }
9783 foreach x [array names growanc] {
9784 if {$dl($x)} {
9785 return 0
9786 }
9787 return 0
9788 }
9789 return 1
9790 }
9792 proc validate_arctags {a} {
9793 global arctags idtags
9795 set i -1
9796 set na $arctags($a)
9797 foreach id $arctags($a) {
9798 incr i
9799 if {![info exists idtags($id)]} {
9800 set na [lreplace $na $i $i]
9801 incr i -1
9802 }
9803 }
9804 set arctags($a) $na
9805 }
9807 proc validate_archeads {a} {
9808 global archeads idheads
9810 set i -1
9811 set na $archeads($a)
9812 foreach id $archeads($a) {
9813 incr i
9814 if {![info exists idheads($id)]} {
9815 set na [lreplace $na $i $i]
9816 incr i -1
9817 }
9818 }
9819 set archeads($a) $na
9820 }
9822 # Return the list of IDs that have tags that are descendents of id,
9823 # ignoring IDs that are descendents of IDs already reported.
9824 proc desctags {id} {
9825 global arcnos arcstart arcids arctags idtags allparents
9826 global growing cached_dtags
9828 if {![info exists allparents($id)]} {
9829 return {}
9830 }
9831 set t1 [clock clicks -milliseconds]
9832 set argid $id
9833 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9834 # part-way along an arc; check that arc first
9835 set a [lindex $arcnos($id) 0]
9836 if {$arctags($a) ne {}} {
9837 validate_arctags $a
9838 set i [lsearch -exact $arcids($a) $id]
9839 set tid {}
9840 foreach t $arctags($a) {
9841 set j [lsearch -exact $arcids($a) $t]
9842 if {$j >= $i} break
9843 set tid $t
9844 }
9845 if {$tid ne {}} {
9846 return $tid
9847 }
9848 }
9849 set id $arcstart($a)
9850 if {[info exists idtags($id)]} {
9851 return $id
9852 }
9853 }
9854 if {[info exists cached_dtags($id)]} {
9855 return $cached_dtags($id)
9856 }
9858 set origid $id
9859 set todo [list $id]
9860 set queued($id) 1
9861 set nc 1
9862 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9863 set id [lindex $todo $i]
9864 set done($id) 1
9865 set ta [info exists hastaggedancestor($id)]
9866 if {!$ta} {
9867 incr nc -1
9868 }
9869 # ignore tags on starting node
9870 if {!$ta && $i > 0} {
9871 if {[info exists idtags($id)]} {
9872 set tagloc($id) $id
9873 set ta 1
9874 } elseif {[info exists cached_dtags($id)]} {
9875 set tagloc($id) $cached_dtags($id)
9876 set ta 1
9877 }
9878 }
9879 foreach a $arcnos($id) {
9880 set d $arcstart($a)
9881 if {!$ta && $arctags($a) ne {}} {
9882 validate_arctags $a
9883 if {$arctags($a) ne {}} {
9884 lappend tagloc($id) [lindex $arctags($a) end]
9885 }
9886 }
9887 if {$ta || $arctags($a) ne {}} {
9888 set tomark [list $d]
9889 for {set j 0} {$j < [llength $tomark]} {incr j} {
9890 set dd [lindex $tomark $j]
9891 if {![info exists hastaggedancestor($dd)]} {
9892 if {[info exists done($dd)]} {
9893 foreach b $arcnos($dd) {
9894 lappend tomark $arcstart($b)
9895 }
9896 if {[info exists tagloc($dd)]} {
9897 unset tagloc($dd)
9898 }
9899 } elseif {[info exists queued($dd)]} {
9900 incr nc -1
9901 }
9902 set hastaggedancestor($dd) 1
9903 }
9904 }
9905 }
9906 if {![info exists queued($d)]} {
9907 lappend todo $d
9908 set queued($d) 1
9909 if {![info exists hastaggedancestor($d)]} {
9910 incr nc
9911 }
9912 }
9913 }
9914 }
9915 set tags {}
9916 foreach id [array names tagloc] {
9917 if {![info exists hastaggedancestor($id)]} {
9918 foreach t $tagloc($id) {
9919 if {[lsearch -exact $tags $t] < 0} {
9920 lappend tags $t
9921 }
9922 }
9923 }
9924 }
9925 set t2 [clock clicks -milliseconds]
9926 set loopix $i
9928 # remove tags that are descendents of other tags
9929 for {set i 0} {$i < [llength $tags]} {incr i} {
9930 set a [lindex $tags $i]
9931 for {set j 0} {$j < $i} {incr j} {
9932 set b [lindex $tags $j]
9933 set r [anc_or_desc $a $b]
9934 if {$r == 1} {
9935 set tags [lreplace $tags $j $j]
9936 incr j -1
9937 incr i -1
9938 } elseif {$r == -1} {
9939 set tags [lreplace $tags $i $i]
9940 incr i -1
9941 break
9942 }
9943 }
9944 }
9946 if {[array names growing] ne {}} {
9947 # graph isn't finished, need to check if any tag could get
9948 # eclipsed by another tag coming later. Simply ignore any
9949 # tags that could later get eclipsed.
9950 set ctags {}
9951 foreach t $tags {
9952 if {[is_certain $t $origid]} {
9953 lappend ctags $t
9954 }
9955 }
9956 if {$tags eq $ctags} {
9957 set cached_dtags($origid) $tags
9958 } else {
9959 set tags $ctags
9960 }
9961 } else {
9962 set cached_dtags($origid) $tags
9963 }
9964 set t3 [clock clicks -milliseconds]
9965 if {0 && $t3 - $t1 >= 100} {
9966 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9967 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9968 }
9969 return $tags
9970 }
9972 proc anctags {id} {
9973 global arcnos arcids arcout arcend arctags idtags allparents
9974 global growing cached_atags
9976 if {![info exists allparents($id)]} {
9977 return {}
9978 }
9979 set t1 [clock clicks -milliseconds]
9980 set argid $id
9981 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9982 # part-way along an arc; check that arc first
9983 set a [lindex $arcnos($id) 0]
9984 if {$arctags($a) ne {}} {
9985 validate_arctags $a
9986 set i [lsearch -exact $arcids($a) $id]
9987 foreach t $arctags($a) {
9988 set j [lsearch -exact $arcids($a) $t]
9989 if {$j > $i} {
9990 return $t
9991 }
9992 }
9993 }
9994 if {![info exists arcend($a)]} {
9995 return {}
9996 }
9997 set id $arcend($a)
9998 if {[info exists idtags($id)]} {
9999 return $id
10000 }
10001 }
10002 if {[info exists cached_atags($id)]} {
10003 return $cached_atags($id)
10004 }
10006 set origid $id
10007 set todo [list $id]
10008 set queued($id) 1
10009 set taglist {}
10010 set nc 1
10011 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10012 set id [lindex $todo $i]
10013 set done($id) 1
10014 set td [info exists hastaggeddescendent($id)]
10015 if {!$td} {
10016 incr nc -1
10017 }
10018 # ignore tags on starting node
10019 if {!$td && $i > 0} {
10020 if {[info exists idtags($id)]} {
10021 set tagloc($id) $id
10022 set td 1
10023 } elseif {[info exists cached_atags($id)]} {
10024 set tagloc($id) $cached_atags($id)
10025 set td 1
10026 }
10027 }
10028 foreach a $arcout($id) {
10029 if {!$td && $arctags($a) ne {}} {
10030 validate_arctags $a
10031 if {$arctags($a) ne {}} {
10032 lappend tagloc($id) [lindex $arctags($a) 0]
10033 }
10034 }
10035 if {![info exists arcend($a)]} continue
10036 set d $arcend($a)
10037 if {$td || $arctags($a) ne {}} {
10038 set tomark [list $d]
10039 for {set j 0} {$j < [llength $tomark]} {incr j} {
10040 set dd [lindex $tomark $j]
10041 if {![info exists hastaggeddescendent($dd)]} {
10042 if {[info exists done($dd)]} {
10043 foreach b $arcout($dd) {
10044 if {[info exists arcend($b)]} {
10045 lappend tomark $arcend($b)
10046 }
10047 }
10048 if {[info exists tagloc($dd)]} {
10049 unset tagloc($dd)
10050 }
10051 } elseif {[info exists queued($dd)]} {
10052 incr nc -1
10053 }
10054 set hastaggeddescendent($dd) 1
10055 }
10056 }
10057 }
10058 if {![info exists queued($d)]} {
10059 lappend todo $d
10060 set queued($d) 1
10061 if {![info exists hastaggeddescendent($d)]} {
10062 incr nc
10063 }
10064 }
10065 }
10066 }
10067 set t2 [clock clicks -milliseconds]
10068 set loopix $i
10069 set tags {}
10070 foreach id [array names tagloc] {
10071 if {![info exists hastaggeddescendent($id)]} {
10072 foreach t $tagloc($id) {
10073 if {[lsearch -exact $tags $t] < 0} {
10074 lappend tags $t
10075 }
10076 }
10077 }
10078 }
10080 # remove tags that are ancestors of other tags
10081 for {set i 0} {$i < [llength $tags]} {incr i} {
10082 set a [lindex $tags $i]
10083 for {set j 0} {$j < $i} {incr j} {
10084 set b [lindex $tags $j]
10085 set r [anc_or_desc $a $b]
10086 if {$r == -1} {
10087 set tags [lreplace $tags $j $j]
10088 incr j -1
10089 incr i -1
10090 } elseif {$r == 1} {
10091 set tags [lreplace $tags $i $i]
10092 incr i -1
10093 break
10094 }
10095 }
10096 }
10098 if {[array names growing] ne {}} {
10099 # graph isn't finished, need to check if any tag could get
10100 # eclipsed by another tag coming later. Simply ignore any
10101 # tags that could later get eclipsed.
10102 set ctags {}
10103 foreach t $tags {
10104 if {[is_certain $origid $t]} {
10105 lappend ctags $t
10106 }
10107 }
10108 if {$tags eq $ctags} {
10109 set cached_atags($origid) $tags
10110 } else {
10111 set tags $ctags
10112 }
10113 } else {
10114 set cached_atags($origid) $tags
10115 }
10116 set t3 [clock clicks -milliseconds]
10117 if {0 && $t3 - $t1 >= 100} {
10118 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10119 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10120 }
10121 return $tags
10122 }
10124 # Return the list of IDs that have heads that are descendents of id,
10125 # including id itself if it has a head.
10126 proc descheads {id} {
10127 global arcnos arcstart arcids archeads idheads cached_dheads
10128 global allparents
10130 if {![info exists allparents($id)]} {
10131 return {}
10132 }
10133 set aret {}
10134 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10135 # part-way along an arc; check it first
10136 set a [lindex $arcnos($id) 0]
10137 if {$archeads($a) ne {}} {
10138 validate_archeads $a
10139 set i [lsearch -exact $arcids($a) $id]
10140 foreach t $archeads($a) {
10141 set j [lsearch -exact $arcids($a) $t]
10142 if {$j > $i} break
10143 lappend aret $t
10144 }
10145 }
10146 set id $arcstart($a)
10147 }
10148 set origid $id
10149 set todo [list $id]
10150 set seen($id) 1
10151 set ret {}
10152 for {set i 0} {$i < [llength $todo]} {incr i} {
10153 set id [lindex $todo $i]
10154 if {[info exists cached_dheads($id)]} {
10155 set ret [concat $ret $cached_dheads($id)]
10156 } else {
10157 if {[info exists idheads($id)]} {
10158 lappend ret $id
10159 }
10160 foreach a $arcnos($id) {
10161 if {$archeads($a) ne {}} {
10162 validate_archeads $a
10163 if {$archeads($a) ne {}} {
10164 set ret [concat $ret $archeads($a)]
10165 }
10166 }
10167 set d $arcstart($a)
10168 if {![info exists seen($d)]} {
10169 lappend todo $d
10170 set seen($d) 1
10171 }
10172 }
10173 }
10174 }
10175 set ret [lsort -unique $ret]
10176 set cached_dheads($origid) $ret
10177 return [concat $ret $aret]
10178 }
10180 proc addedtag {id} {
10181 global arcnos arcout cached_dtags cached_atags
10183 if {![info exists arcnos($id)]} return
10184 if {![info exists arcout($id)]} {
10185 recalcarc [lindex $arcnos($id) 0]
10186 }
10187 catch {unset cached_dtags}
10188 catch {unset cached_atags}
10189 }
10191 proc addedhead {hid head} {
10192 global arcnos arcout cached_dheads
10194 if {![info exists arcnos($hid)]} return
10195 if {![info exists arcout($hid)]} {
10196 recalcarc [lindex $arcnos($hid) 0]
10197 }
10198 catch {unset cached_dheads}
10199 }
10201 proc removedhead {hid head} {
10202 global cached_dheads
10204 catch {unset cached_dheads}
10205 }
10207 proc movedhead {hid head} {
10208 global arcnos arcout cached_dheads
10210 if {![info exists arcnos($hid)]} return
10211 if {![info exists arcout($hid)]} {
10212 recalcarc [lindex $arcnos($hid) 0]
10213 }
10214 catch {unset cached_dheads}
10215 }
10217 proc changedrefs {} {
10218 global cached_dheads cached_dtags cached_atags
10219 global arctags archeads arcnos arcout idheads idtags
10221 foreach id [concat [array names idheads] [array names idtags]] {
10222 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10223 set a [lindex $arcnos($id) 0]
10224 if {![info exists donearc($a)]} {
10225 recalcarc $a
10226 set donearc($a) 1
10227 }
10228 }
10229 }
10230 catch {unset cached_dtags}
10231 catch {unset cached_atags}
10232 catch {unset cached_dheads}
10233 }
10235 proc rereadrefs {} {
10236 global idtags idheads idotherrefs mainheadid
10238 set refids [concat [array names idtags] \
10239 [array names idheads] [array names idotherrefs]]
10240 foreach id $refids {
10241 if {![info exists ref($id)]} {
10242 set ref($id) [listrefs $id]
10243 }
10244 }
10245 set oldmainhead $mainheadid
10246 readrefs
10247 changedrefs
10248 set refids [lsort -unique [concat $refids [array names idtags] \
10249 [array names idheads] [array names idotherrefs]]]
10250 foreach id $refids {
10251 set v [listrefs $id]
10252 if {![info exists ref($id)] || $ref($id) != $v} {
10253 redrawtags $id
10254 }
10255 }
10256 if {$oldmainhead ne $mainheadid} {
10257 redrawtags $oldmainhead
10258 redrawtags $mainheadid
10259 }
10260 run refill_reflist
10261 }
10263 proc listrefs {id} {
10264 global idtags idheads idotherrefs
10266 set x {}
10267 if {[info exists idtags($id)]} {
10268 set x $idtags($id)
10269 }
10270 set y {}
10271 if {[info exists idheads($id)]} {
10272 set y $idheads($id)
10273 }
10274 set z {}
10275 if {[info exists idotherrefs($id)]} {
10276 set z $idotherrefs($id)
10277 }
10278 return [list $x $y $z]
10279 }
10281 proc showtag {tag isnew} {
10282 global ctext tagcontents tagids linknum tagobjid
10284 if {$isnew} {
10285 addtohistory [list showtag $tag 0]
10286 }
10287 $ctext conf -state normal
10288 clear_ctext
10289 settabs 0
10290 set linknum 0
10291 if {![info exists tagcontents($tag)]} {
10292 catch {
10293 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10294 }
10295 }
10296 if {[info exists tagcontents($tag)]} {
10297 set text $tagcontents($tag)
10298 } else {
10299 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10300 }
10301 appendwithlinks $text {}
10302 $ctext conf -state disabled
10303 init_flist {}
10304 }
10306 proc doquit {} {
10307 global stopped
10308 global gitktmpdir
10310 set stopped 100
10311 savestuff .
10312 destroy .
10314 if {[info exists gitktmpdir]} {
10315 catch {file delete -force $gitktmpdir}
10316 }
10317 }
10319 proc mkfontdisp {font top which} {
10320 global fontattr fontpref $font
10322 set fontpref($font) [set $font]
10323 button $top.${font}but -text $which -font optionfont \
10324 -command [list choosefont $font $which]
10325 label $top.$font -relief flat -font $font \
10326 -text $fontattr($font,family) -justify left
10327 grid x $top.${font}but $top.$font -sticky w
10328 }
10330 proc choosefont {font which} {
10331 global fontparam fontlist fonttop fontattr
10332 global prefstop
10334 set fontparam(which) $which
10335 set fontparam(font) $font
10336 set fontparam(family) [font actual $font -family]
10337 set fontparam(size) $fontattr($font,size)
10338 set fontparam(weight) $fontattr($font,weight)
10339 set fontparam(slant) $fontattr($font,slant)
10340 set top .gitkfont
10341 set fonttop $top
10342 if {![winfo exists $top]} {
10343 font create sample
10344 eval font config sample [font actual $font]
10345 toplevel $top
10346 make_transient $top $prefstop
10347 wm title $top [mc "Gitk font chooser"]
10348 label $top.l -textvariable fontparam(which)
10349 pack $top.l -side top
10350 set fontlist [lsort [font families]]
10351 frame $top.f
10352 listbox $top.f.fam -listvariable fontlist \
10353 -yscrollcommand [list $top.f.sb set]
10354 bind $top.f.fam <<ListboxSelect>> selfontfam
10355 scrollbar $top.f.sb -command [list $top.f.fam yview]
10356 pack $top.f.sb -side right -fill y
10357 pack $top.f.fam -side left -fill both -expand 1
10358 pack $top.f -side top -fill both -expand 1
10359 frame $top.g
10360 spinbox $top.g.size -from 4 -to 40 -width 4 \
10361 -textvariable fontparam(size) \
10362 -validatecommand {string is integer -strict %s}
10363 checkbutton $top.g.bold -padx 5 \
10364 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10365 -variable fontparam(weight) -onvalue bold -offvalue normal
10366 checkbutton $top.g.ital -padx 5 \
10367 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10368 -variable fontparam(slant) -onvalue italic -offvalue roman
10369 pack $top.g.size $top.g.bold $top.g.ital -side left
10370 pack $top.g -side top
10371 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10372 -background white
10373 $top.c create text 100 25 -anchor center -text $which -font sample \
10374 -fill black -tags text
10375 bind $top.c <Configure> [list centertext $top.c]
10376 pack $top.c -side top -fill x
10377 frame $top.buts
10378 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10379 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10380 bind $top <Key-Return> fontok
10381 bind $top <Key-Escape> fontcan
10382 grid $top.buts.ok $top.buts.can
10383 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10384 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10385 pack $top.buts -side bottom -fill x
10386 trace add variable fontparam write chg_fontparam
10387 } else {
10388 raise $top
10389 $top.c itemconf text -text $which
10390 }
10391 set i [lsearch -exact $fontlist $fontparam(family)]
10392 if {$i >= 0} {
10393 $top.f.fam selection set $i
10394 $top.f.fam see $i
10395 }
10396 }
10398 proc centertext {w} {
10399 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10400 }
10402 proc fontok {} {
10403 global fontparam fontpref prefstop
10405 set f $fontparam(font)
10406 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10407 if {$fontparam(weight) eq "bold"} {
10408 lappend fontpref($f) "bold"
10409 }
10410 if {$fontparam(slant) eq "italic"} {
10411 lappend fontpref($f) "italic"
10412 }
10413 set w $prefstop.$f
10414 $w conf -text $fontparam(family) -font $fontpref($f)
10416 fontcan
10417 }
10419 proc fontcan {} {
10420 global fonttop fontparam
10422 if {[info exists fonttop]} {
10423 catch {destroy $fonttop}
10424 catch {font delete sample}
10425 unset fonttop
10426 unset fontparam
10427 }
10428 }
10430 proc selfontfam {} {
10431 global fonttop fontparam
10433 set i [$fonttop.f.fam curselection]
10434 if {$i ne {}} {
10435 set fontparam(family) [$fonttop.f.fam get $i]
10436 }
10437 }
10439 proc chg_fontparam {v sub op} {
10440 global fontparam
10442 font config sample -$sub $fontparam($sub)
10443 }
10445 proc doprefs {} {
10446 global maxwidth maxgraphpct
10447 global oldprefs prefstop showneartags showlocalchanges
10448 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10449 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10450 global hideremotes
10452 set top .gitkprefs
10453 set prefstop $top
10454 if {[winfo exists $top]} {
10455 raise $top
10456 return
10457 }
10458 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10459 limitdiffs tabstop perfile_attrs hideremotes} {
10460 set oldprefs($v) [set $v]
10461 }
10462 toplevel $top
10463 wm title $top [mc "Gitk preferences"]
10464 make_transient $top .
10465 label $top.ldisp -text [mc "Commit list display options"]
10466 grid $top.ldisp - -sticky w -pady 10
10467 label $top.spacer -text " "
10468 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10469 -font optionfont
10470 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10471 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10472 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10473 -font optionfont
10474 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10475 grid x $top.maxpctl $top.maxpct -sticky w
10476 checkbutton $top.showlocal -text [mc "Show local changes"] \
10477 -font optionfont -variable showlocalchanges
10478 grid x $top.showlocal -sticky w
10479 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10480 -font optionfont -variable autoselect
10481 grid x $top.autoselect -sticky w
10483 label $top.ddisp -text [mc "Diff display options"]
10484 grid $top.ddisp - -sticky w -pady 10
10485 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10486 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10487 grid x $top.tabstopl $top.tabstop -sticky w
10488 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10489 -font optionfont -variable showneartags
10490 grid x $top.ntag -sticky w
10491 checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10492 -font optionfont -variable hideremotes
10493 grid x $top.hideremotes -sticky w
10494 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10495 -font optionfont -variable limitdiffs
10496 grid x $top.ldiff -sticky w
10497 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10498 -font optionfont -variable perfile_attrs
10499 grid x $top.lattr -sticky w
10501 entry $top.extdifft -textvariable extdifftool
10502 frame $top.extdifff
10503 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10504 -padx 10
10505 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10506 -command choose_extdiff
10507 pack $top.extdifff.l $top.extdifff.b -side left
10508 grid x $top.extdifff $top.extdifft -sticky w
10510 label $top.cdisp -text [mc "Colors: press to choose"]
10511 grid $top.cdisp - -sticky w -pady 10
10512 label $top.ui -padx 40 -relief sunk -background $uicolor
10513 button $top.uibut -text [mc "Interface"] -font optionfont \
10514 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10515 grid x $top.uibut $top.ui -sticky w
10516 label $top.bg -padx 40 -relief sunk -background $bgcolor
10517 button $top.bgbut -text [mc "Background"] -font optionfont \
10518 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10519 grid x $top.bgbut $top.bg -sticky w
10520 label $top.fg -padx 40 -relief sunk -background $fgcolor
10521 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10522 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10523 grid x $top.fgbut $top.fg -sticky w
10524 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10525 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10526 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10527 [list $ctext tag conf d0 -foreground]]
10528 grid x $top.diffoldbut $top.diffold -sticky w
10529 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10530 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10531 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10532 [list $ctext tag conf dresult -foreground]]
10533 grid x $top.diffnewbut $top.diffnew -sticky w
10534 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10535 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10536 -command [list choosecolor diffcolors 2 $top.hunksep \
10537 [mc "diff hunk header"] \
10538 [list $ctext tag conf hunksep -foreground]]
10539 grid x $top.hunksepbut $top.hunksep -sticky w
10540 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10541 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10542 -command [list choosecolor markbgcolor {} $top.markbgsep \
10543 [mc "marked line background"] \
10544 [list $ctext tag conf omark -background]]
10545 grid x $top.markbgbut $top.markbgsep -sticky w
10546 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10547 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10548 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10549 grid x $top.selbgbut $top.selbgsep -sticky w
10551 label $top.cfont -text [mc "Fonts: press to choose"]
10552 grid $top.cfont - -sticky w -pady 10
10553 mkfontdisp mainfont $top [mc "Main font"]
10554 mkfontdisp textfont $top [mc "Diff display font"]
10555 mkfontdisp uifont $top [mc "User interface font"]
10557 frame $top.buts
10558 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10559 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10560 bind $top <Key-Return> prefsok
10561 bind $top <Key-Escape> prefscan
10562 grid $top.buts.ok $top.buts.can
10563 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10564 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10565 grid $top.buts - - -pady 10 -sticky ew
10566 bind $top <Visibility> "focus $top.buts.ok"
10567 }
10569 proc choose_extdiff {} {
10570 global extdifftool
10572 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10573 if {$prog ne {}} {
10574 set extdifftool $prog
10575 }
10576 }
10578 proc choosecolor {v vi w x cmd} {
10579 global $v
10581 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10582 -title [mc "Gitk: choose color for %s" $x]]
10583 if {$c eq {}} return
10584 $w conf -background $c
10585 lset $v $vi $c
10586 eval $cmd $c
10587 }
10589 proc setselbg {c} {
10590 global bglist cflist
10591 foreach w $bglist {
10592 $w configure -selectbackground $c
10593 }
10594 $cflist tag configure highlight \
10595 -background [$cflist cget -selectbackground]
10596 allcanvs itemconf secsel -fill $c
10597 }
10599 proc setui {c} {
10600 tk_setPalette $c
10601 }
10603 proc setbg {c} {
10604 global bglist
10606 foreach w $bglist {
10607 $w conf -background $c
10608 }
10609 }
10611 proc setfg {c} {
10612 global fglist canv
10614 foreach w $fglist {
10615 $w conf -foreground $c
10616 }
10617 allcanvs itemconf text -fill $c
10618 $canv itemconf circle -outline $c
10619 $canv itemconf markid -outline $c
10620 }
10622 proc prefscan {} {
10623 global oldprefs prefstop
10625 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10626 limitdiffs tabstop perfile_attrs hideremotes} {
10627 global $v
10628 set $v $oldprefs($v)
10629 }
10630 catch {destroy $prefstop}
10631 unset prefstop
10632 fontcan
10633 }
10635 proc prefsok {} {
10636 global maxwidth maxgraphpct
10637 global oldprefs prefstop showneartags showlocalchanges
10638 global fontpref mainfont textfont uifont
10639 global limitdiffs treediffs perfile_attrs
10640 global hideremotes
10642 catch {destroy $prefstop}
10643 unset prefstop
10644 fontcan
10645 set fontchanged 0
10646 if {$mainfont ne $fontpref(mainfont)} {
10647 set mainfont $fontpref(mainfont)
10648 parsefont mainfont $mainfont
10649 eval font configure mainfont [fontflags mainfont]
10650 eval font configure mainfontbold [fontflags mainfont 1]
10651 setcoords
10652 set fontchanged 1
10653 }
10654 if {$textfont ne $fontpref(textfont)} {
10655 set textfont $fontpref(textfont)
10656 parsefont textfont $textfont
10657 eval font configure textfont [fontflags textfont]
10658 eval font configure textfontbold [fontflags textfont 1]
10659 }
10660 if {$uifont ne $fontpref(uifont)} {
10661 set uifont $fontpref(uifont)
10662 parsefont uifont $uifont
10663 eval font configure uifont [fontflags uifont]
10664 }
10665 settabs
10666 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10667 if {$showlocalchanges} {
10668 doshowlocalchanges
10669 } else {
10670 dohidelocalchanges
10671 }
10672 }
10673 if {$limitdiffs != $oldprefs(limitdiffs) ||
10674 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10675 # treediffs elements are limited by path;
10676 # won't have encodings cached if perfile_attrs was just turned on
10677 catch {unset treediffs}
10678 }
10679 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10680 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10681 redisplay
10682 } elseif {$showneartags != $oldprefs(showneartags) ||
10683 $limitdiffs != $oldprefs(limitdiffs)} {
10684 reselectline
10685 }
10686 if {$hideremotes != $oldprefs(hideremotes)} {
10687 rereadrefs
10688 }
10689 }
10691 proc formatdate {d} {
10692 global datetimeformat
10693 if {$d ne {}} {
10694 set d [clock format $d -format $datetimeformat]
10695 }
10696 return $d
10697 }
10699 # This list of encoding names and aliases is distilled from
10700 # http://www.iana.org/assignments/character-sets.
10701 # Not all of them are supported by Tcl.
10702 set encoding_aliases {
10703 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10704 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10705 { ISO-10646-UTF-1 csISO10646UTF1 }
10706 { ISO_646.basic:1983 ref csISO646basic1983 }
10707 { INVARIANT csINVARIANT }
10708 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10709 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10710 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10711 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10712 { NATS-DANO iso-ir-9-1 csNATSDANO }
10713 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10714 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10715 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10716 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10717 { ISO-2022-KR csISO2022KR }
10718 { EUC-KR csEUCKR }
10719 { ISO-2022-JP csISO2022JP }
10720 { ISO-2022-JP-2 csISO2022JP2 }
10721 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10722 csISO13JISC6220jp }
10723 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10724 { IT iso-ir-15 ISO646-IT csISO15Italian }
10725 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10726 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10727 { greek7-old iso-ir-18 csISO18Greek7Old }
10728 { latin-greek iso-ir-19 csISO19LatinGreek }
10729 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10730 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10731 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10732 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10733 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10734 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10735 { INIS iso-ir-49 csISO49INIS }
10736 { INIS-8 iso-ir-50 csISO50INIS8 }
10737 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10738 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10739 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10740 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10741 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10742 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10743 csISO60Norwegian1 }
10744 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10745 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10746 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10747 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10748 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10749 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10750 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10751 { greek7 iso-ir-88 csISO88Greek7 }
10752 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10753 { iso-ir-90 csISO90 }
10754 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10755 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10756 csISO92JISC62991984b }
10757 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10758 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10759 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10760 csISO95JIS62291984handadd }
10761 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10762 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10763 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10764 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10765 CP819 csISOLatin1 }
10766 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10767 { T.61-7bit iso-ir-102 csISO102T617bit }
10768 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10769 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10770 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10771 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10772 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10773 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10774 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10775 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10776 arabic csISOLatinArabic }
10777 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10778 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10779 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10780 greek greek8 csISOLatinGreek }
10781 { T.101-G2 iso-ir-128 csISO128T101G2 }
10782 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10783 csISOLatinHebrew }
10784 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10785 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10786 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10787 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10788 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10789 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10790 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10791 csISOLatinCyrillic }
10792 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10793 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10794 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10795 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10796 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10797 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10798 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10799 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10800 { ISO_10367-box iso-ir-155 csISO10367Box }
10801 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10802 { latin-lap lap iso-ir-158 csISO158Lap }
10803 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10804 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10805 { us-dk csUSDK }
10806 { dk-us csDKUS }
10807 { JIS_X0201 X0201 csHalfWidthKatakana }
10808 { KSC5636 ISO646-KR csKSC5636 }
10809 { ISO-10646-UCS-2 csUnicode }
10810 { ISO-10646-UCS-4 csUCS4 }
10811 { DEC-MCS dec csDECMCS }
10812 { hp-roman8 roman8 r8 csHPRoman8 }
10813 { macintosh mac csMacintosh }
10814 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10815 csIBM037 }
10816 { IBM038 EBCDIC-INT cp038 csIBM038 }
10817 { IBM273 CP273 csIBM273 }
10818 { IBM274 EBCDIC-BE CP274 csIBM274 }
10819 { IBM275 EBCDIC-BR cp275 csIBM275 }
10820 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10821 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10822 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10823 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10824 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10825 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10826 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10827 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10828 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10829 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10830 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10831 { IBM437 cp437 437 csPC8CodePage437 }
10832 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10833 { IBM775 cp775 csPC775Baltic }
10834 { IBM850 cp850 850 csPC850Multilingual }
10835 { IBM851 cp851 851 csIBM851 }
10836 { IBM852 cp852 852 csPCp852 }
10837 { IBM855 cp855 855 csIBM855 }
10838 { IBM857 cp857 857 csIBM857 }
10839 { IBM860 cp860 860 csIBM860 }
10840 { IBM861 cp861 861 cp-is csIBM861 }
10841 { IBM862 cp862 862 csPC862LatinHebrew }
10842 { IBM863 cp863 863 csIBM863 }
10843 { IBM864 cp864 csIBM864 }
10844 { IBM865 cp865 865 csIBM865 }
10845 { IBM866 cp866 866 csIBM866 }
10846 { IBM868 CP868 cp-ar csIBM868 }
10847 { IBM869 cp869 869 cp-gr csIBM869 }
10848 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10849 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10850 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10851 { IBM891 cp891 csIBM891 }
10852 { IBM903 cp903 csIBM903 }
10853 { IBM904 cp904 904 csIBBM904 }
10854 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10855 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10856 { IBM1026 CP1026 csIBM1026 }
10857 { EBCDIC-AT-DE csIBMEBCDICATDE }
10858 { EBCDIC-AT-DE-A csEBCDICATDEA }
10859 { EBCDIC-CA-FR csEBCDICCAFR }
10860 { EBCDIC-DK-NO csEBCDICDKNO }
10861 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10862 { EBCDIC-FI-SE csEBCDICFISE }
10863 { EBCDIC-FI-SE-A csEBCDICFISEA }
10864 { EBCDIC-FR csEBCDICFR }
10865 { EBCDIC-IT csEBCDICIT }
10866 { EBCDIC-PT csEBCDICPT }
10867 { EBCDIC-ES csEBCDICES }
10868 { EBCDIC-ES-A csEBCDICESA }
10869 { EBCDIC-ES-S csEBCDICESS }
10870 { EBCDIC-UK csEBCDICUK }
10871 { EBCDIC-US csEBCDICUS }
10872 { UNKNOWN-8BIT csUnknown8BiT }
10873 { MNEMONIC csMnemonic }
10874 { MNEM csMnem }
10875 { VISCII csVISCII }
10876 { VIQR csVIQR }
10877 { KOI8-R csKOI8R }
10878 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10879 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10880 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10881 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10882 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10883 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10884 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10885 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10886 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10887 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10888 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10889 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10890 { IBM1047 IBM-1047 }
10891 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10892 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10893 { UNICODE-1-1 csUnicode11 }
10894 { CESU-8 csCESU-8 }
10895 { BOCU-1 csBOCU-1 }
10896 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10897 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10898 l8 }
10899 { ISO-8859-15 ISO_8859-15 Latin-9 }
10900 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10901 { GBK CP936 MS936 windows-936 }
10902 { JIS_Encoding csJISEncoding }
10903 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10904 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10905 EUC-JP }
10906 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10907 { ISO-10646-UCS-Basic csUnicodeASCII }
10908 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10909 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10910 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10911 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10912 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10913 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10914 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10915 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10916 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10917 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10918 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10919 { Ventura-US csVenturaUS }
10920 { Ventura-International csVenturaInternational }
10921 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10922 { PC8-Turkish csPC8Turkish }
10923 { IBM-Symbols csIBMSymbols }
10924 { IBM-Thai csIBMThai }
10925 { HP-Legal csHPLegal }
10926 { HP-Pi-font csHPPiFont }
10927 { HP-Math8 csHPMath8 }
10928 { Adobe-Symbol-Encoding csHPPSMath }
10929 { HP-DeskTop csHPDesktop }
10930 { Ventura-Math csVenturaMath }
10931 { Microsoft-Publishing csMicrosoftPublishing }
10932 { Windows-31J csWindows31J }
10933 { GB2312 csGB2312 }
10934 { Big5 csBig5 }
10935 }
10937 proc tcl_encoding {enc} {
10938 global encoding_aliases tcl_encoding_cache
10939 if {[info exists tcl_encoding_cache($enc)]} {
10940 return $tcl_encoding_cache($enc)
10941 }
10942 set names [encoding names]
10943 set lcnames [string tolower $names]
10944 set enc [string tolower $enc]
10945 set i [lsearch -exact $lcnames $enc]
10946 if {$i < 0} {
10947 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10948 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10949 set i [lsearch -exact $lcnames $encx]
10950 }
10951 }
10952 if {$i < 0} {
10953 foreach l $encoding_aliases {
10954 set ll [string tolower $l]
10955 if {[lsearch -exact $ll $enc] < 0} continue
10956 # look through the aliases for one that tcl knows about
10957 foreach e $ll {
10958 set i [lsearch -exact $lcnames $e]
10959 if {$i < 0} {
10960 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10961 set i [lsearch -exact $lcnames $ex]
10962 }
10963 }
10964 if {$i >= 0} break
10965 }
10966 break
10967 }
10968 }
10969 set tclenc {}
10970 if {$i >= 0} {
10971 set tclenc [lindex $names $i]
10972 }
10973 set tcl_encoding_cache($enc) $tclenc
10974 return $tclenc
10975 }
10977 proc gitattr {path attr default} {
10978 global path_attr_cache
10979 if {[info exists path_attr_cache($attr,$path)]} {
10980 set r $path_attr_cache($attr,$path)
10981 } else {
10982 set r "unspecified"
10983 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10984 regexp "(.*): $attr: (.*)" $line m f r
10985 }
10986 set path_attr_cache($attr,$path) $r
10987 }
10988 if {$r eq "unspecified"} {
10989 return $default
10990 }
10991 return $r
10992 }
10994 proc cache_gitattr {attr pathlist} {
10995 global path_attr_cache
10996 set newlist {}
10997 foreach path $pathlist {
10998 if {![info exists path_attr_cache($attr,$path)]} {
10999 lappend newlist $path
11000 }
11001 }
11002 set lim 1000
11003 if {[tk windowingsystem] == "win32"} {
11004 # windows has a 32k limit on the arguments to a command...
11005 set lim 30
11006 }
11007 while {$newlist ne {}} {
11008 set head [lrange $newlist 0 [expr {$lim - 1}]]
11009 set newlist [lrange $newlist $lim end]
11010 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11011 foreach row [split $rlist "\n"] {
11012 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11013 if {[string index $path 0] eq "\""} {
11014 set path [encoding convertfrom [lindex $path 0]]
11015 }
11016 set path_attr_cache($attr,$path) $value
11017 }
11018 }
11019 }
11020 }
11021 }
11023 proc get_path_encoding {path} {
11024 global gui_encoding perfile_attrs
11025 set tcl_enc $gui_encoding
11026 if {$path ne {} && $perfile_attrs} {
11027 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11028 if {$enc2 ne {}} {
11029 set tcl_enc $enc2
11030 }
11031 }
11032 return $tcl_enc
11033 }
11035 # First check that Tcl/Tk is recent enough
11036 if {[catch {package require Tk 8.4} err]} {
11037 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11038 Gitk requires at least Tcl/Tk 8.4." list
11039 exit 1
11040 }
11042 # defaults...
11043 set wrcomcmd "git diff-tree --stdin -p --pretty"
11045 set gitencoding {}
11046 catch {
11047 set gitencoding [exec git config --get i18n.commitencoding]
11048 }
11049 catch {
11050 set gitencoding [exec git config --get i18n.logoutputencoding]
11051 }
11052 if {$gitencoding == ""} {
11053 set gitencoding "utf-8"
11054 }
11055 set tclencoding [tcl_encoding $gitencoding]
11056 if {$tclencoding == {}} {
11057 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11058 }
11060 set gui_encoding [encoding system]
11061 catch {
11062 set enc [exec git config --get gui.encoding]
11063 if {$enc ne {}} {
11064 set tclenc [tcl_encoding $enc]
11065 if {$tclenc ne {}} {
11066 set gui_encoding $tclenc
11067 } else {
11068 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11069 }
11070 }
11071 }
11073 if {[tk windowingsystem] eq "aqua"} {
11074 set mainfont {{Lucida Grande} 9}
11075 set textfont {Monaco 9}
11076 set uifont {{Lucida Grande} 9 bold}
11077 } else {
11078 set mainfont {Helvetica 9}
11079 set textfont {Courier 9}
11080 set uifont {Helvetica 9 bold}
11081 }
11082 set tabstop 8
11083 set findmergefiles 0
11084 set maxgraphpct 50
11085 set maxwidth 16
11086 set revlistorder 0
11087 set fastdate 0
11088 set uparrowlen 5
11089 set downarrowlen 5
11090 set mingaplen 100
11091 set cmitmode "patch"
11092 set wrapcomment "none"
11093 set showneartags 1
11094 set hideremotes 0
11095 set maxrefs 20
11096 set maxlinelen 200
11097 set showlocalchanges 1
11098 set limitdiffs 1
11099 set datetimeformat "%Y-%m-%d %H:%M:%S"
11100 set autoselect 1
11101 set perfile_attrs 0
11103 if {[tk windowingsystem] eq "aqua"} {
11104 set extdifftool "opendiff"
11105 } else {
11106 set extdifftool "meld"
11107 }
11109 set colors {green red blue magenta darkgrey brown orange}
11110 set uicolor grey85
11111 set bgcolor white
11112 set fgcolor black
11113 set diffcolors {red "#00a000" blue}
11114 set diffcontext 3
11115 set ignorespace 0
11116 set selectbgcolor gray85
11117 set markbgcolor "#e0e0ff"
11119 set circlecolors {white blue gray blue blue}
11121 # button for popping up context menus
11122 if {[tk windowingsystem] eq "aqua"} {
11123 set ctxbut <Button-2>
11124 } else {
11125 set ctxbut <Button-3>
11126 }
11128 ## For msgcat loading, first locate the installation location.
11129 if { [info exists ::env(GITK_MSGSDIR)] } {
11130 ## Msgsdir was manually set in the environment.
11131 set gitk_msgsdir $::env(GITK_MSGSDIR)
11132 } else {
11133 ## Let's guess the prefix from argv0.
11134 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11135 set gitk_libdir [file join $gitk_prefix share gitk lib]
11136 set gitk_msgsdir [file join $gitk_libdir msgs]
11137 unset gitk_prefix
11138 }
11140 ## Internationalization (i18n) through msgcat and gettext. See
11141 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11142 package require msgcat
11143 namespace import ::msgcat::mc
11144 ## And eventually load the actual message catalog
11145 ::msgcat::mcload $gitk_msgsdir
11147 catch {source ~/.gitk}
11149 font create optionfont -family sans-serif -size -12
11151 parsefont mainfont $mainfont
11152 eval font create mainfont [fontflags mainfont]
11153 eval font create mainfontbold [fontflags mainfont 1]
11155 parsefont textfont $textfont
11156 eval font create textfont [fontflags textfont]
11157 eval font create textfontbold [fontflags textfont 1]
11159 parsefont uifont $uifont
11160 eval font create uifont [fontflags uifont]
11162 tk_setPalette $uicolor
11164 setoptions
11166 # check that we can find a .git directory somewhere...
11167 if {[catch {set gitdir [gitdir]}]} {
11168 show_error {} . [mc "Cannot find a git repository here."]
11169 exit 1
11170 }
11171 if {![file isdirectory $gitdir]} {
11172 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11173 exit 1
11174 }
11176 set selecthead {}
11177 set selectheadid {}
11179 set revtreeargs {}
11180 set cmdline_files {}
11181 set i 0
11182 set revtreeargscmd {}
11183 foreach arg $argv {
11184 switch -glob -- $arg {
11185 "" { }
11186 "--" {
11187 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11188 break
11189 }
11190 "--select-commit=*" {
11191 set selecthead [string range $arg 16 end]
11192 }
11193 "--argscmd=*" {
11194 set revtreeargscmd [string range $arg 10 end]
11195 }
11196 default {
11197 lappend revtreeargs $arg
11198 }
11199 }
11200 incr i
11201 }
11203 if {$selecthead eq "HEAD"} {
11204 set selecthead {}
11205 }
11207 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11208 # no -- on command line, but some arguments (other than --argscmd)
11209 if {[catch {
11210 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11211 set cmdline_files [split $f "\n"]
11212 set n [llength $cmdline_files]
11213 set revtreeargs [lrange $revtreeargs 0 end-$n]
11214 # Unfortunately git rev-parse doesn't produce an error when
11215 # something is both a revision and a filename. To be consistent
11216 # with git log and git rev-list, check revtreeargs for filenames.
11217 foreach arg $revtreeargs {
11218 if {[file exists $arg]} {
11219 show_error {} . [mc "Ambiguous argument '%s': both revision\
11220 and filename" $arg]
11221 exit 1
11222 }
11223 }
11224 } err]} {
11225 # unfortunately we get both stdout and stderr in $err,
11226 # so look for "fatal:".
11227 set i [string first "fatal:" $err]
11228 if {$i > 0} {
11229 set err [string range $err [expr {$i + 6}] end]
11230 }
11231 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11232 exit 1
11233 }
11234 }
11236 set nullid "0000000000000000000000000000000000000000"
11237 set nullid2 "0000000000000000000000000000000000000001"
11238 set nullfile "/dev/null"
11240 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11241 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11243 set runq {}
11244 set history {}
11245 set historyindex 0
11246 set fh_serial 0
11247 set nhl_names {}
11248 set highlight_paths {}
11249 set findpattern {}
11250 set searchdirn -forwards
11251 set boldids {}
11252 set boldnameids {}
11253 set diffelide {0 0}
11254 set markingmatches 0
11255 set linkentercount 0
11256 set need_redisplay 0
11257 set nrows_drawn 0
11258 set firsttabstop 0
11260 set nextviewnum 1
11261 set curview 0
11262 set selectedview 0
11263 set selectedhlview [mc "None"]
11264 set highlight_related [mc "None"]
11265 set highlight_files {}
11266 set viewfiles(0) {}
11267 set viewperm(0) 0
11268 set viewargs(0) {}
11269 set viewargscmd(0) {}
11271 set selectedline {}
11272 set numcommits 0
11273 set loginstance 0
11274 set cmdlineok 0
11275 set stopped 0
11276 set stuffsaved 0
11277 set patchnum 0
11278 set lserial 0
11279 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11280 setcoords
11281 makewindow
11282 catch {
11283 image create photo gitlogo -width 16 -height 16
11285 image create photo gitlogominus -width 4 -height 2
11286 gitlogominus put #C00000 -to 0 0 4 2
11287 gitlogo copy gitlogominus -to 1 5
11288 gitlogo copy gitlogominus -to 6 5
11289 gitlogo copy gitlogominus -to 11 5
11290 image delete gitlogominus
11292 image create photo gitlogoplus -width 4 -height 4
11293 gitlogoplus put #008000 -to 1 0 3 4
11294 gitlogoplus put #008000 -to 0 1 4 3
11295 gitlogo copy gitlogoplus -to 1 9
11296 gitlogo copy gitlogoplus -to 6 9
11297 gitlogo copy gitlogoplus -to 11 9
11298 image delete gitlogoplus
11300 image create photo gitlogo32 -width 32 -height 32
11301 gitlogo32 copy gitlogo -zoom 2 2
11303 wm iconphoto . -default gitlogo gitlogo32
11304 }
11305 # wait for the window to become visible
11306 tkwait visibility .
11307 wm title . "[file tail $argv0]: [file tail [pwd]]"
11308 update
11309 readrefs
11311 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11312 # create a view for the files/dirs specified on the command line
11313 set curview 1
11314 set selectedview 1
11315 set nextviewnum 2
11316 set viewname(1) [mc "Command line"]
11317 set viewfiles(1) $cmdline_files
11318 set viewargs(1) $revtreeargs
11319 set viewargscmd(1) $revtreeargscmd
11320 set viewperm(1) 0
11321 set vdatemode(1) 0
11322 addviewmenu 1
11323 .bar.view entryconf [mca "Edit view..."] -state normal
11324 .bar.view entryconf [mca "Delete view"] -state normal
11325 }
11327 if {[info exists permviews]} {
11328 foreach v $permviews {
11329 set n $nextviewnum
11330 incr nextviewnum
11331 set viewname($n) [lindex $v 0]
11332 set viewfiles($n) [lindex $v 1]
11333 set viewargs($n) [lindex $v 2]
11334 set viewargscmd($n) [lindex $v 3]
11335 set viewperm($n) 1
11336 addviewmenu $n
11337 }
11338 }
11340 if {[tk windowingsystem] eq "win32"} {
11341 focus -force .
11342 }
11344 getcommits {}