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