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