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