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