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