1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
5# Copyright © 2005-2014 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 vinlinediff
160 global worddiff git_version
161
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
179 }
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
187 }
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
197 }
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
207 }
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
213 }
214 }
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
218 }
219 }
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
226 }
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
237 }
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
245 }
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
252 }
253 "--not" - "--all" {
254 lappend revargs $arg
255 }
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
260 }
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
263 }
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
272 }
273 lappend glflags $arg
274 }
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
279 }
280 lappend revargs $arg
281 }
282 }
283 }
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
290}
291
292proc parseviewrevs {view revs} {
293 global vposids vnegids
294
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
299 }
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
315 }
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
318 }
319 break
320 }
321 lappend badrev $line
322 }
323 }
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
326 }
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
339 }
340 }
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
347 }
348 lappend pos $id
349 }
350 incr sdm -1
351 }
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
355}
356
357# Start off a git log process and arrange to read its output
358proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
367
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
374
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
382 }
383 set args [concat $args [split $str "\n"]]
384 }
385 set vcanopt($view) [parseviewargs $view $args]
386
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
398 }
399 return 0
400 }
401 }
402 set vfilelimit($view) $files
403
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
408 }
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
412 }
413
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
420 }
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
427 }
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
430 }
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
434 }
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
440}
441
442proc stop_instance {inst} {
443 global commfd leftover
444
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
448
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
453 }
454 }
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
459}
460
461proc stop_backends {} {
462 global commfd
463
464 foreach inst [array names commfd] {
465 stop_instance $inst
466 }
467}
468
469proc stop_rev_list {view} {
470 global viewinstances
471
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
474 }
475 set viewinstances($view) {}
476}
477
478proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
480
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
487 }
488}
489
490proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
492
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
500 }
501}
502
503proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
511
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
518 }
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
523 }
524 }
525 if {$showlocalchanges} {
526 doshowlocalchanges
527 }
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
534 }
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
549 }
550 } else {
551 lappend $newrevs $rev
552 }
553 }
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
557 }
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
561 }
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
568 }
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
571 }
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
577 }
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
585 }
586}
587
588proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
592
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
596 }
597
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
600 }
601 resetvarcs $curview
602 set selectedline {}
603 unset -nocomplain currentid
604 unset -nocomplain thickerline
605 unset -nocomplain treediffs
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
610 }
611 clear_display
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
618}
619
620# This makes a string representation of a positive integer which
621# sorts as a string in numerical order
622proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
629 }
630 return [format "z%.8x" $n]
631}
632
633# Procedures used in reordering commits from git log (without
634# --topo-order) into the order for display.
635
636proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
639
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
652}
653
654proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
657
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
662 }
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
665 }
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
669 }
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
672 }
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
675 }
676 unset -nocomplain ordertok
677}
678
679# returns a list of the commits with no children
680proc seeds {v} {
681 global vdownptr vleftptr varcstart
682
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
688 }
689 return $ret
690}
691
692proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
696
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
702 }
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
706 }
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
709 }
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
715 }
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
724 }
725 }
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
730 }
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
737 }
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
741 }
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
748 }
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
754 }
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
763}
764
765proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
768
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
785 }
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
795 }
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
798 }
799}
800
801proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
804
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
817 }
818 }
819 }
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
827 }
828 }
829 set a $b
830 }
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
837 }
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
843 }
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
852 }
853 }
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
858 }
859 if {$tok eq $oldtok} {
860 continue
861 }
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
868 }
869 }
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
875 }
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
878 }
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
885 }
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
888 }
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
891 }
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
900 }
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
905 }
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
912 }
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
916 }
917 lset vlastins($v) $ka $a
918 }
919 }
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
924 }
925 }
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
928}
929
930# Fix up the graph after we have found out that in view $v,
931# $p (a commit that we have already seen) is actually the parent
932# of the last commit in arc $a.
933proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
935
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
940 }
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
946 }
947}
948
949proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
953
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
964 }
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
970 }
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
979 }
980 }
981 }
982}
983
984proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
987
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
994 }
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1007 }
1008 }
1009 setcanvscroll
1010 drawvisible
1011}
1012
1013proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1017
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1022 }
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1029 }
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1039 }
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1044 }
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1047 }
1048 setcanvscroll
1049 drawvisible
1050}
1051
1052proc real_children {vp} {
1053 global children nullid nullid2
1054
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1059 }
1060 }
1061 return $kids
1062}
1063
1064proc first_real_child {vp} {
1065 global children nullid nullid2
1066
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1070 }
1071 }
1072 return {}
1073}
1074
1075proc last_real_child {vp} {
1076 global children nullid nullid2
1077
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1083 }
1084 }
1085 return {}
1086}
1087
1088proc vtokcmp {v a b} {
1089 global varctok varcid
1090
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1093}
1094
1095# This assumes that if lim is not given, the caller has checked that
1096# arc a's token is less than $vtokmod($v)
1097proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1099
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1106 }
1107 }
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1114 }
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1119 }
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1121 }
1122 set vrowmod($v) $r
1123 undolayout $r
1124 }
1125}
1126
1127proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1132
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1138 }
1139 unset -nocomplain cached_commitrow
1140 }
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1147 }
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1162 }
1163 set row [lindex $varcrow($v) $a]
1164 }
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1176 }
1177 if {$a == 0} break
1178 }
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1185 }
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1191 }
1192}
1193
1194# Test whether view $v contains commit $id
1195proc commitinview {id v} {
1196 global varcid
1197
1198 return [info exists varcid($v,$id)]
1199}
1200
1201# Return the row number for commit $id in the current view
1202proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1205
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1210 }
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1214 }
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1217 }
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1222 }
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1226}
1227
1228# Returns 1 if a is on an earlier row than b, otherwise 0
1229proc comes_before {a b} {
1230 global varcid varctok curview
1231
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1236 }
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1240 }
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1242}
1243
1244proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1247 }
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1259 }
1260 }
1261 return $lo
1262}
1263
1264# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1269
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1272 }
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1288 }
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1292 }
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1299 }
1300 }
1301 incr r $al
1302 }
1303}
1304
1305proc commitonrow {row} {
1306 global displayorder
1307
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1312 }
1313 return $id
1314}
1315
1316proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1319
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1336 }
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1340 }
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1344 }
1345 }
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1349 }
1350 }
1351}
1352
1353# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354# Assumes we already have an arc for $rwid.
1355proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1357
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1363 }
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1369 }
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1376 }
1377}
1378
1379# Mechanism for registering a command to be executed when we come
1380# across a particular commit. To handle the case when only the
1381# prefix of the commit is known, the commitinterest array is now
1382# indexed by the first 4 characters of the ID. Each element is a
1383# list of id, cmd pairs.
1384proc interestedin {id cmd} {
1385 global commitinterest
1386
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1388}
1389
1390proc check_interest {id scripts} {
1391 global commitinterest
1392
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1401 }
1402 }
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1407 }
1408 }
1409 return $scripts
1410}
1411
1412proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1418
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1423 }
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1427 }
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1434 }
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1441 }
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq "Command line"} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1449 }
1450 } else {
1451 set err "Error reading commits$fv: $err"
1452 }
1453 error_popup $err
1454 }
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1461 }
1462 if {$view == $curview} {
1463 run chewcommits
1464 }
1465 return 0
1466 }
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1475 }
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1482 }
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1495 }
1496 set ids [string range $ids 1 end]
1497 }
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1503 }
1504 }
1505 }
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1510 }
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1513 }
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1516
1517 lappend vshortids($view,[string range $id 0 3]) $id
1518
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1534 }
1535 }
1536 }
1537
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1542 }
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1547 }
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1559 }
1560 }
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1564 }
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1567 }
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1572 }
1573
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 unset -nocomplain ordertok
1583 }
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1586 }
1587 }
1588 incr i
1589 }
1590
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1593 }
1594 if {$gotsome} {
1595 global numcommits hlview
1596
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1600 }
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1604 }
1605 foreach s $scripts {
1606 eval $s
1607 }
1608 }
1609 return 2
1610}
1611
1612proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1615
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1620
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1624
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1630 }
1631 }
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1638 }
1639 notbusy layout
1640 }
1641 return 0
1642}
1643
1644proc do_readcommit {id} {
1645 global tclencoding
1646
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1653 }
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1658
1659 return $contents
1660}
1661
1662proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1665}
1666
1667proc parsecommit {id contents listed} {
1668 global commitinfo
1669
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1681 }
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1693 }
1694 }
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1701 }
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1706 }
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1715 }
1716 set comment $newcomment
1717 }
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1727 }
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1730}
1731
1732proc getcommit {id} {
1733 global commitdata commitinfo
1734
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1741 }
1742 }
1743 return 1
1744}
1745
1746# Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747# and are present in the current view.
1748# This is fairly slow...
1749proc longid {prefix} {
1750 global varcid curview vshortids
1751
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1761 }
1762 }
1763 }
1764 }
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1769 }
1770 }
1771 return $ids
1772}
1773
1774proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1779
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 unset -nocomplain $v
1782 }
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1794 }
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1807 }
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1813 }
1814 }
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1823 }
1824 }
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1829 }
1830 }
1831}
1832
1833# skip over fake commits
1834proc first_real_row {} {
1835 global nullid nullid2 numcommits
1836
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1841 }
1842 }
1843 return $row
1844}
1845
1846# update things for a head moved to a child of its previous location
1847proc movehead {id name} {
1848 global headids idheads
1849
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1853}
1854
1855# update things when a head has been removed
1856proc removehead {id name} {
1857 global headids idheads
1858
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1865 }
1866 }
1867 unset headids($name)
1868}
1869
1870proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1875 }
1876 return $w
1877}
1878
1879proc make_transient {window origin} {
1880 global have_tk85
1881
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1887
1888 wm transient $window $origin
1889
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1894 }
1895}
1896
1897proc show_error {w top msg} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1910}
1911
1912proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1921 }
1922}
1923
1924proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1943}
1944
1945proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1951 }
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1954 }
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1966}
1967
1968# Make a menu and submenus.
1969# m is the window name for the menu, items is the list of menu items to add.
1970# Each item is a list {mc label type description options...}
1971# mc is ignored; it's so we can put mc there to alert xgettext
1972# label is the string that appears in the menu
1973# type is cascade, command or radiobutton (should add checkbutton)
1974# description depends on type; it's the sublist for cascade, the
1975# command to invoke for command, or {variable value} for radiobutton
1976proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1982 }
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1993 }
1994 }
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
1999 }
2000 "command" {
2001 lappend params -command $thing
2002 }
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2006 }
2007 }
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2013 }
2014 }
2015}
2016
2017# translate string and remove ampersands
2018proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2020}
2021
2022proc cleardropsel {w} {
2023 $w selection clear
2024}
2025proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2032 }
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2039 }
2040 return $gm
2041}
2042
2043proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2064
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "File" cascade {
2069 {mc "Update" command updatecommits -accelerator F5}
2070 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread references" command rereadrefs}
2072 {mc "List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "Quit" command doquit -accelerator Meta1-Q}
2077 }}
2078 set edit {
2079 mc "Edit" cascade {
2080 {mc "Preferences" command doprefs}
2081 }}
2082 set view {
2083 mc "View" cascade {
2084 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2089 }}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "Help" cascade {
2093 {mc "About gitk" command about}
2094 {mc "Key bindings" command keys}
2095 }}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "Apple" cascade {
2103 {mc "About gitk" command about}
2104 {xx "" separator}
2105 }}
2106 set help {
2107 mc "Help" cascade {
2108 {mc "Key bindings" command keys}
2109 }}
2110 set bar [list $apple $file $view $help]
2111 }
2112 makemenu .bar $bar
2113 . configure -menu .bar
2114
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2118 }
2119
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2122
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2131 }
2132
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2139 }
2140
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2164 }
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2168 }
2169
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2177
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2181
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2192
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2200 }
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2208 }
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2213
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2219 }
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2226 }
2227 pack .tf.bar.rightbut -side left -fill y
2228
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2240 }
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2243
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2257 }
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2265
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2268
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2277 }
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2281
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2290 }
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2294
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2296
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2307
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2324
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2333 }
2334
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2337
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2345 }
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2349
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2377
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2384 }
2385
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2393 }
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2406
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2436
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2440 }
2441
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2469
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2472
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2478 }
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2481 }
2482 wm geometry . "${w}x$h"
2483 }
2484 }
2485
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2488 }
2489
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2496 }
2497
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2502 }
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2506 }
2507 }
2508
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 bind $ctext <Button> {
2520 if {"%b" eq 6} {
2521 $ctext xview scroll -5 units
2522 } elseif {"%b" eq 7} {
2523 $ctext xview scroll 5 units
2524 }
2525 }
2526 if {[tk windowingsystem] eq "aqua"} {
2527 bindall <MouseWheel> {
2528 set delta [expr {- (%D)}]
2529 allcanvs yview scroll $delta units
2530 }
2531 bindall <Shift-MouseWheel> {
2532 set delta [expr {- (%D)}]
2533 $canv xview scroll $delta units
2534 }
2535 }
2536 }
2537 bindall <$::BM> "canvscan mark %W %x %y"
2538 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540 bind . <$M1B-Key-w> doquit
2541 bindkey <Home> selfirstline
2542 bindkey <End> sellastline
2543 bind . <Key-Up> "selnextline -1"
2544 bind . <Key-Down> "selnextline 1"
2545 bind . <Shift-Key-Up> "dofind -1 0"
2546 bind . <Shift-Key-Down> "dofind 1 0"
2547 bindkey <Key-Right> "goforw"
2548 bindkey <Key-Left> "goback"
2549 bind . <Key-Prior> "selnextpage -1"
2550 bind . <Key-Next> "selnextpage 1"
2551 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559 bindkey <Key-space> "$ctext yview scroll 1 pages"
2560 bindkey p "selnextline -1"
2561 bindkey n "selnextline 1"
2562 bindkey z "goback"
2563 bindkey x "goforw"
2564 bindkey k "selnextline -1"
2565 bindkey j "selnextline 1"
2566 bindkey h "goback"
2567 bindkey l "goforw"
2568 bindkey b prevfile
2569 bindkey d "$ctext yview scroll 18 units"
2570 bindkey u "$ctext yview scroll -18 units"
2571 bindkey / {focus $fstring}
2572 bindkey <Key-KP_Divide> {focus $fstring}
2573 bindkey <Key-Return> {dofind 1 1}
2574 bindkey ? {dofind -1 1}
2575 bindkey f nextfile
2576 bind . <F5> updatecommits
2577 bindmodfunctionkey Shift 5 reloadcommits
2578 bind . <F2> showrefs
2579 bindmodfunctionkey Shift 4 {newview 0}
2580 bind . <F4> edit_or_newview
2581 bind . <$M1B-q> doquit
2582 bind . <$M1B-f> {dofind 1 1}
2583 bind . <$M1B-g> {dofind 1 0}
2584 bind . <$M1B-r> dosearchback
2585 bind . <$M1B-s> dosearch
2586 bind . <$M1B-equal> {incrfont 1}
2587 bind . <$M1B-plus> {incrfont 1}
2588 bind . <$M1B-KP_Add> {incrfont 1}
2589 bind . <$M1B-minus> {incrfont -1}
2590 bind . <$M1B-KP_Subtract> {incrfont -1}
2591 wm protocol . WM_DELETE_WINDOW doquit
2592 bind . <Destroy> {stop_backends}
2593 bind . <Button-1> "click %W"
2594 bind $fstring <Key-Return> {dofind 1 1}
2595 bind $sha1entry <Key-Return> {gotocommit; break}
2596 bind $sha1entry <<PasteSelection>> clearsha1
2597 bind $sha1entry <<Paste>> clearsha1
2598 bind $cflist <1> {sel_flist %W %x %y; break}
2599 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2600 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2601 global ctxbut
2602 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2603 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2604 bind $ctext <Button-1> {focus %W}
2605 bind $ctext <<Selection>> rehighlight_search_results
2606 for {set i 1} {$i < 10} {incr i} {
2607 bind . <$M1B-Key-$i> [list go_to_parent $i]
2608 }
2609
2610 set maincursor [. cget -cursor]
2611 set textcursor [$ctext cget -cursor]
2612 set curtextcursor $textcursor
2613
2614 set rowctxmenu .rowctxmenu
2615 makemenu $rowctxmenu {
2616 {mc "Diff this -> selected" command {diffvssel 0}}
2617 {mc "Diff selected -> this" command {diffvssel 1}}
2618 {mc "Make patch" command mkpatch}
2619 {mc "Create tag" command mktag}
2620 {mc "Write commit to file" command writecommit}
2621 {mc "Create new branch" command mkbranch}
2622 {mc "Cherry-pick this commit" command cherrypick}
2623 {mc "Reset HEAD branch to here" command resethead}
2624 {mc "Mark this commit" command markhere}
2625 {mc "Return to mark" command gotomark}
2626 {mc "Find descendant of this and mark" command find_common_desc}
2627 {mc "Compare with marked commit" command compare_commits}
2628 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2629 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2630 {mc "Revert this commit" command revert}
2631 }
2632 $rowctxmenu configure -tearoff 0
2633
2634 set fakerowmenu .fakerowmenu
2635 makemenu $fakerowmenu {
2636 {mc "Diff this -> selected" command {diffvssel 0}}
2637 {mc "Diff selected -> this" command {diffvssel 1}}
2638 {mc "Make patch" command mkpatch}
2639 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2640 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2641 }
2642 $fakerowmenu configure -tearoff 0
2643
2644 set headctxmenu .headctxmenu
2645 makemenu $headctxmenu {
2646 {mc "Check out this branch" command cobranch}
2647 {mc "Remove this branch" command rmbranch}
2648 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2649 }
2650 $headctxmenu configure -tearoff 0
2651
2652 global flist_menu
2653 set flist_menu .flistctxmenu
2654 makemenu $flist_menu {
2655 {mc "Highlight this too" command {flist_hl 0}}
2656 {mc "Highlight this only" command {flist_hl 1}}
2657 {mc "External diff" command {external_diff}}
2658 {mc "Blame parent commit" command {external_blame 1}}
2659 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2660 }
2661 $flist_menu configure -tearoff 0
2662
2663 global diff_menu
2664 set diff_menu .diffctxmenu
2665 makemenu $diff_menu {
2666 {mc "Show origin of this line" command show_line_source}
2667 {mc "Run git gui blame on this line" command {external_blame_diff}}
2668 }
2669 $diff_menu configure -tearoff 0
2670}
2671
2672# Windows sends all mouse wheel events to the current focused window, not
2673# the one where the mouse hovers, so bind those events here and redirect
2674# to the correct window
2675proc windows_mousewheel_redirector {W X Y D} {
2676 global canv canv2 canv3
2677 set w [winfo containing -displayof $W $X $Y]
2678 if {$w ne ""} {
2679 set u [expr {$D < 0 ? 5 : -5}]
2680 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2681 allcanvs yview scroll $u units
2682 } else {
2683 catch {
2684 $w yview scroll $u units
2685 }
2686 }
2687 }
2688}
2689
2690# Update row number label when selectedline changes
2691proc selectedline_change {n1 n2 op} {
2692 global selectedline rownumsel
2693
2694 if {$selectedline eq {}} {
2695 set rownumsel {}
2696 } else {
2697 set rownumsel [expr {$selectedline + 1}]
2698 }
2699}
2700
2701# mouse-2 makes all windows scan vertically, but only the one
2702# the cursor is in scans horizontally
2703proc canvscan {op w x y} {
2704 global canv canv2 canv3
2705 foreach c [list $canv $canv2 $canv3] {
2706 if {$c == $w} {
2707 $c scan $op $x $y
2708 } else {
2709 $c scan $op 0 $y
2710 }
2711 }
2712}
2713
2714proc scrollcanv {cscroll f0 f1} {
2715 $cscroll set $f0 $f1
2716 drawvisible
2717 flushhighlights
2718}
2719
2720# when we make a key binding for the toplevel, make sure
2721# it doesn't get triggered when that key is pressed in the
2722# find string entry widget.
2723proc bindkey {ev script} {
2724 global entries
2725 bind . $ev $script
2726 set escript [bind Entry $ev]
2727 if {$escript == {}} {
2728 set escript [bind Entry <Key>]
2729 }
2730 foreach e $entries {
2731 bind $e $ev "$escript; break"
2732 }
2733}
2734
2735proc bindmodfunctionkey {mod n script} {
2736 bind . <$mod-F$n> $script
2737 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2738}
2739
2740# set the focus back to the toplevel for any click outside
2741# the entry widgets
2742proc click {w} {
2743 global ctext entries
2744 foreach e [concat $entries $ctext] {
2745 if {$w == $e} return
2746 }
2747 focus .
2748}
2749
2750# Adjust the progress bar for a change in requested extent or canvas size
2751proc adjustprogress {} {
2752 global progresscanv progressitem progresscoords
2753 global fprogitem fprogcoord lastprogupdate progupdatepending
2754 global rprogitem rprogcoord use_ttk
2755
2756 if {$use_ttk} {
2757 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2758 return
2759 }
2760
2761 set w [expr {[winfo width $progresscanv] - 4}]
2762 set x0 [expr {$w * [lindex $progresscoords 0]}]
2763 set x1 [expr {$w * [lindex $progresscoords 1]}]
2764 set h [winfo height $progresscanv]
2765 $progresscanv coords $progressitem $x0 0 $x1 $h
2766 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2767 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2768 set now [clock clicks -milliseconds]
2769 if {$now >= $lastprogupdate + 100} {
2770 set progupdatepending 0
2771 update
2772 } elseif {!$progupdatepending} {
2773 set progupdatepending 1
2774 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2775 }
2776}
2777
2778proc doprogupdate {} {
2779 global lastprogupdate progupdatepending
2780
2781 if {$progupdatepending} {
2782 set progupdatepending 0
2783 set lastprogupdate [clock clicks -milliseconds]
2784 update
2785 }
2786}
2787
2788proc config_check_tmp_exists {tries_left} {
2789 global config_file_tmp
2790
2791 if {[file exists $config_file_tmp]} {
2792 incr tries_left -1
2793 if {$tries_left > 0} {
2794 after 100 [list config_check_tmp_exists $tries_left]
2795 } else {
2796 error_popup "There appears to be a stale $config_file_tmp\
2797 file, which will prevent gitk from saving its configuration on exit.\
2798 Please remove it if it is not being used by any existing gitk process."
2799 }
2800 }
2801}
2802
2803proc config_init_trace {name} {
2804 global config_variable_changed config_variable_original
2805
2806 upvar #0 $name var
2807 set config_variable_changed($name) 0
2808 set config_variable_original($name) $var
2809}
2810
2811proc config_variable_change_cb {name name2 op} {
2812 global config_variable_changed config_variable_original
2813
2814 upvar #0 $name var
2815 if {$op eq "write" &&
2816 (![info exists config_variable_original($name)] ||
2817 $config_variable_original($name) ne $var)} {
2818 set config_variable_changed($name) 1
2819 }
2820}
2821
2822proc savestuff {w} {
2823 global stuffsaved
2824 global config_file config_file_tmp
2825 global config_variables config_variable_changed
2826 global viewchanged
2827
2828 upvar #0 viewname current_viewname
2829 upvar #0 viewfiles current_viewfiles
2830 upvar #0 viewargs current_viewargs
2831 upvar #0 viewargscmd current_viewargscmd
2832 upvar #0 viewperm current_viewperm
2833 upvar #0 nextviewnum current_nextviewnum
2834 upvar #0 use_ttk current_use_ttk
2835
2836 if {$stuffsaved} return
2837 if {![winfo viewable .]} return
2838 set remove_tmp 0
2839 if {[catch {
2840 set try_count 0
2841 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2842 if {[incr try_count] > 50} {
2843 error "Unable to write config file: $config_file_tmp exists"
2844 }
2845 after 100
2846 }
2847 set remove_tmp 1
2848 if {$::tcl_platform(platform) eq {windows}} {
2849 file attributes $config_file_tmp -hidden true
2850 }
2851 if {[file exists $config_file]} {
2852 source $config_file
2853 }
2854 foreach var_name $config_variables {
2855 upvar #0 $var_name var
2856 upvar 0 $var_name old_var
2857 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2858 puts $f [list set $var_name $old_var]
2859 } else {
2860 puts $f [list set $var_name $var]
2861 }
2862 }
2863
2864 puts $f "set geometry(main) [wm geometry .]"
2865 puts $f "set geometry(state) [wm state .]"
2866 puts $f "set geometry(topwidth) [winfo width .tf]"
2867 puts $f "set geometry(topheight) [winfo height .tf]"
2868 if {$current_use_ttk} {
2869 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2870 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2871 } else {
2872 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2873 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2874 }
2875 puts $f "set geometry(botwidth) [winfo width .bleft]"
2876 puts $f "set geometry(botheight) [winfo height .bleft]"
2877
2878 array set view_save {}
2879 array set views {}
2880 if {![info exists permviews]} { set permviews {} }
2881 foreach view $permviews {
2882 set view_save([lindex $view 0]) 1
2883 set views([lindex $view 0]) $view
2884 }
2885 puts -nonewline $f "set permviews {"
2886 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2887 if {$viewchanged($v)} {
2888 if {$current_viewperm($v)} {
2889 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2890 } else {
2891 set view_save($current_viewname($v)) 0
2892 }
2893 }
2894 }
2895 # write old and updated view to their places and append remaining to the end
2896 foreach view $permviews {
2897 set view_name [lindex $view 0]
2898 if {$view_save($view_name)} {
2899 puts $f "{$views($view_name)}"
2900 }
2901 unset views($view_name)
2902 }
2903 foreach view_name [array names views] {
2904 puts $f "{$views($view_name)}"
2905 }
2906 puts $f "}"
2907 close $f
2908 file rename -force $config_file_tmp $config_file
2909 set remove_tmp 0
2910 } err]} {
2911 puts "Error saving config: $err"
2912 }
2913 if {$remove_tmp} {
2914 file delete -force $config_file_tmp
2915 }
2916 set stuffsaved 1
2917}
2918
2919proc resizeclistpanes {win w} {
2920 global oldwidth use_ttk
2921 if {[info exists oldwidth($win)]} {
2922 if {$use_ttk} {
2923 set s0 [$win sashpos 0]
2924 set s1 [$win sashpos 1]
2925 } else {
2926 set s0 [$win sash coord 0]
2927 set s1 [$win sash coord 1]
2928 }
2929 if {$w < 60} {
2930 set sash0 [expr {int($w/2 - 2)}]
2931 set sash1 [expr {int($w*5/6 - 2)}]
2932 } else {
2933 set factor [expr {1.0 * $w / $oldwidth($win)}]
2934 set sash0 [expr {int($factor * [lindex $s0 0])}]
2935 set sash1 [expr {int($factor * [lindex $s1 0])}]
2936 if {$sash0 < 30} {
2937 set sash0 30
2938 }
2939 if {$sash1 < $sash0 + 20} {
2940 set sash1 [expr {$sash0 + 20}]
2941 }
2942 if {$sash1 > $w - 10} {
2943 set sash1 [expr {$w - 10}]
2944 if {$sash0 > $sash1 - 20} {
2945 set sash0 [expr {$sash1 - 20}]
2946 }
2947 }
2948 }
2949 if {$use_ttk} {
2950 $win sashpos 0 $sash0
2951 $win sashpos 1 $sash1
2952 } else {
2953 $win sash place 0 $sash0 [lindex $s0 1]
2954 $win sash place 1 $sash1 [lindex $s1 1]
2955 }
2956 }
2957 set oldwidth($win) $w
2958}
2959
2960proc resizecdetpanes {win w} {
2961 global oldwidth use_ttk
2962 if {[info exists oldwidth($win)]} {
2963 if {$use_ttk} {
2964 set s0 [$win sashpos 0]
2965 } else {
2966 set s0 [$win sash coord 0]
2967 }
2968 if {$w < 60} {
2969 set sash0 [expr {int($w*3/4 - 2)}]
2970 } else {
2971 set factor [expr {1.0 * $w / $oldwidth($win)}]
2972 set sash0 [expr {int($factor * [lindex $s0 0])}]
2973 if {$sash0 < 45} {
2974 set sash0 45
2975 }
2976 if {$sash0 > $w - 15} {
2977 set sash0 [expr {$w - 15}]
2978 }
2979 }
2980 if {$use_ttk} {
2981 $win sashpos 0 $sash0
2982 } else {
2983 $win sash place 0 $sash0 [lindex $s0 1]
2984 }
2985 }
2986 set oldwidth($win) $w
2987}
2988
2989proc allcanvs args {
2990 global canv canv2 canv3
2991 eval $canv $args
2992 eval $canv2 $args
2993 eval $canv3 $args
2994}
2995
2996proc bindall {event action} {
2997 global canv canv2 canv3
2998 bind $canv $event $action
2999 bind $canv2 $event $action
3000 bind $canv3 $event $action
3001}
3002
3003proc about {} {
3004 global uifont NS
3005 set w .about
3006 if {[winfo exists $w]} {
3007 raise $w
3008 return
3009 }
3010 ttk_toplevel $w
3011 wm title $w [mc "About gitk"]
3012 make_transient $w .
3013 message $w.m -text [mc "
3014Gitk - a commit viewer for git
3015
3016Copyright \u00a9 2005-2014 Paul Mackerras
3017
3018Use and redistribute under the terms of the GNU General Public License"] \
3019 -justify center -aspect 400 -border 2 -bg white -relief groove
3020 pack $w.m -side top -fill x -padx 2 -pady 2
3021 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3022 pack $w.ok -side bottom
3023 bind $w <Visibility> "focus $w.ok"
3024 bind $w <Key-Escape> "destroy $w"
3025 bind $w <Key-Return> "destroy $w"
3026 tk::PlaceWindow $w widget .
3027}
3028
3029proc keys {} {
3030 global NS
3031 set w .keys
3032 if {[winfo exists $w]} {
3033 raise $w
3034 return
3035 }
3036 if {[tk windowingsystem] eq {aqua}} {
3037 set M1T Cmd
3038 } else {
3039 set M1T Ctrl
3040 }
3041 ttk_toplevel $w
3042 wm title $w [mc "Gitk key bindings"]
3043 make_transient $w .
3044 message $w.m -text "
3045[mc "Gitk key bindings:"]
3046
3047[mc "<%s-Q> Quit" $M1T]
3048[mc "<%s-W> Close window" $M1T]
3049[mc "<Home> Move to first commit"]
3050[mc "<End> Move to last commit"]
3051[mc "<Up>, p, k Move up one commit"]
3052[mc "<Down>, n, j Move down one commit"]
3053[mc "<Left>, z, h Go back in history list"]
3054[mc "<Right>, x, l Go forward in history list"]
3055[mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3056[mc "<PageUp> Move up one page in commit list"]
3057[mc "<PageDown> Move down one page in commit list"]
3058[mc "<%s-Home> Scroll to top of commit list" $M1T]
3059[mc "<%s-End> Scroll to bottom of commit list" $M1T]
3060[mc "<%s-Up> Scroll commit list up one line" $M1T]
3061[mc "<%s-Down> Scroll commit list down one line" $M1T]
3062[mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3063[mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3064[mc "<Shift-Up> Find backwards (upwards, later commits)"]
3065[mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3066[mc "<Delete>, b Scroll diff view up one page"]
3067[mc "<Backspace> Scroll diff view up one page"]
3068[mc "<Space> Scroll diff view down one page"]
3069[mc "u Scroll diff view up 18 lines"]
3070[mc "d Scroll diff view down 18 lines"]
3071[mc "<%s-F> Find" $M1T]
3072[mc "<%s-G> Move to next find hit" $M1T]
3073[mc "<Return> Move to next find hit"]
3074[mc "/ Focus the search box"]
3075[mc "? Move to previous find hit"]
3076[mc "f Scroll diff view to next file"]
3077[mc "<%s-S> Search for next hit in diff view" $M1T]
3078[mc "<%s-R> Search for previous hit in diff view" $M1T]
3079[mc "<%s-KP+> Increase font size" $M1T]
3080[mc "<%s-plus> Increase font size" $M1T]
3081[mc "<%s-KP-> Decrease font size" $M1T]
3082[mc "<%s-minus> Decrease font size" $M1T]
3083[mc "<F5> Update"]
3084" \
3085 -justify left -bg white -border 2 -relief groove
3086 pack $w.m -side top -fill both -padx 2 -pady 2
3087 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3088 bind $w <Key-Escape> [list destroy $w]
3089 pack $w.ok -side bottom
3090 bind $w <Visibility> "focus $w.ok"
3091 bind $w <Key-Escape> "destroy $w"
3092 bind $w <Key-Return> "destroy $w"
3093}
3094
3095# Procedures for manipulating the file list window at the
3096# bottom right of the overall window.
3097
3098proc treeview {w l openlevs} {
3099 global treecontents treediropen treeheight treeparent treeindex
3100
3101 set ix 0
3102 set treeindex() 0
3103 set lev 0
3104 set prefix {}
3105 set prefixend -1
3106 set prefendstack {}
3107 set htstack {}
3108 set ht 0
3109 set treecontents() {}
3110 $w conf -state normal
3111 foreach f $l {
3112 while {[string range $f 0 $prefixend] ne $prefix} {
3113 if {$lev <= $openlevs} {
3114 $w mark set e:$treeindex($prefix) "end -1c"
3115 $w mark gravity e:$treeindex($prefix) left
3116 }
3117 set treeheight($prefix) $ht
3118 incr ht [lindex $htstack end]
3119 set htstack [lreplace $htstack end end]
3120 set prefixend [lindex $prefendstack end]
3121 set prefendstack [lreplace $prefendstack end end]
3122 set prefix [string range $prefix 0 $prefixend]
3123 incr lev -1
3124 }
3125 set tail [string range $f [expr {$prefixend+1}] end]
3126 while {[set slash [string first "/" $tail]] >= 0} {
3127 lappend htstack $ht
3128 set ht 0
3129 lappend prefendstack $prefixend
3130 incr prefixend [expr {$slash + 1}]
3131 set d [string range $tail 0 $slash]
3132 lappend treecontents($prefix) $d
3133 set oldprefix $prefix
3134 append prefix $d
3135 set treecontents($prefix) {}
3136 set treeindex($prefix) [incr ix]
3137 set treeparent($prefix) $oldprefix
3138 set tail [string range $tail [expr {$slash+1}] end]
3139 if {$lev <= $openlevs} {
3140 set ht 1
3141 set treediropen($prefix) [expr {$lev < $openlevs}]
3142 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3143 $w mark set d:$ix "end -1c"
3144 $w mark gravity d:$ix left
3145 set str "\n"
3146 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3147 $w insert end $str
3148 $w image create end -align center -image $bm -padx 1 \
3149 -name a:$ix
3150 $w insert end $d [highlight_tag $prefix]
3151 $w mark set s:$ix "end -1c"
3152 $w mark gravity s:$ix left
3153 }
3154 incr lev
3155 }
3156 if {$tail ne {}} {
3157 if {$lev <= $openlevs} {
3158 incr ht
3159 set str "\n"
3160 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3161 $w insert end $str
3162 $w insert end $tail [highlight_tag $f]
3163 }
3164 lappend treecontents($prefix) $tail
3165 }
3166 }
3167 while {$htstack ne {}} {
3168 set treeheight($prefix) $ht
3169 incr ht [lindex $htstack end]
3170 set htstack [lreplace $htstack end end]
3171 set prefixend [lindex $prefendstack end]
3172 set prefendstack [lreplace $prefendstack end end]
3173 set prefix [string range $prefix 0 $prefixend]
3174 }
3175 $w conf -state disabled
3176}
3177
3178proc linetoelt {l} {
3179 global treeheight treecontents
3180
3181 set y 2
3182 set prefix {}
3183 while {1} {
3184 foreach e $treecontents($prefix) {
3185 if {$y == $l} {
3186 return "$prefix$e"
3187 }
3188 set n 1
3189 if {[string index $e end] eq "/"} {
3190 set n $treeheight($prefix$e)
3191 if {$y + $n > $l} {
3192 append prefix $e
3193 incr y
3194 break
3195 }
3196 }
3197 incr y $n
3198 }
3199 }
3200}
3201
3202proc highlight_tree {y prefix} {
3203 global treeheight treecontents cflist
3204
3205 foreach e $treecontents($prefix) {
3206 set path $prefix$e
3207 if {[highlight_tag $path] ne {}} {
3208 $cflist tag add bold $y.0 "$y.0 lineend"
3209 }
3210 incr y
3211 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3212 set y [highlight_tree $y $path]
3213 }
3214 }
3215 return $y
3216}
3217
3218proc treeclosedir {w dir} {
3219 global treediropen treeheight treeparent treeindex
3220
3221 set ix $treeindex($dir)
3222 $w conf -state normal
3223 $w delete s:$ix e:$ix
3224 set treediropen($dir) 0
3225 $w image configure a:$ix -image tri-rt
3226 $w conf -state disabled
3227 set n [expr {1 - $treeheight($dir)}]
3228 while {$dir ne {}} {
3229 incr treeheight($dir) $n
3230 set dir $treeparent($dir)
3231 }
3232}
3233
3234proc treeopendir {w dir} {
3235 global treediropen treeheight treeparent treecontents treeindex
3236
3237 set ix $treeindex($dir)
3238 $w conf -state normal
3239 $w image configure a:$ix -image tri-dn
3240 $w mark set e:$ix s:$ix
3241 $w mark gravity e:$ix right
3242 set lev 0
3243 set str "\n"
3244 set n [llength $treecontents($dir)]
3245 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3246 incr lev
3247 append str "\t"
3248 incr treeheight($x) $n
3249 }
3250 foreach e $treecontents($dir) {
3251 set de $dir$e
3252 if {[string index $e end] eq "/"} {
3253 set iy $treeindex($de)
3254 $w mark set d:$iy e:$ix
3255 $w mark gravity d:$iy left
3256 $w insert e:$ix $str
3257 set treediropen($de) 0
3258 $w image create e:$ix -align center -image tri-rt -padx 1 \
3259 -name a:$iy
3260 $w insert e:$ix $e [highlight_tag $de]
3261 $w mark set s:$iy e:$ix
3262 $w mark gravity s:$iy left
3263 set treeheight($de) 1
3264 } else {
3265 $w insert e:$ix $str
3266 $w insert e:$ix $e [highlight_tag $de]
3267 }
3268 }
3269 $w mark gravity e:$ix right
3270 $w conf -state disabled
3271 set treediropen($dir) 1
3272 set top [lindex [split [$w index @0,0] .] 0]
3273 set ht [$w cget -height]
3274 set l [lindex [split [$w index s:$ix] .] 0]
3275 if {$l < $top} {
3276 $w yview $l.0
3277 } elseif {$l + $n + 1 > $top + $ht} {
3278 set top [expr {$l + $n + 2 - $ht}]
3279 if {$l < $top} {
3280 set top $l
3281 }
3282 $w yview $top.0
3283 }
3284}
3285
3286proc treeclick {w x y} {
3287 global treediropen cmitmode ctext cflist cflist_top
3288
3289 if {$cmitmode ne "tree"} return
3290 if {![info exists cflist_top]} return
3291 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3292 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3293 $cflist tag add highlight $l.0 "$l.0 lineend"
3294 set cflist_top $l
3295 if {$l == 1} {
3296 $ctext yview 1.0
3297 return
3298 }
3299 set e [linetoelt $l]
3300 if {[string index $e end] ne "/"} {
3301 showfile $e
3302 } elseif {$treediropen($e)} {
3303 treeclosedir $w $e
3304 } else {
3305 treeopendir $w $e
3306 }
3307}
3308
3309proc setfilelist {id} {
3310 global treefilelist cflist jump_to_here
3311
3312 treeview $cflist $treefilelist($id) 0
3313 if {$jump_to_here ne {}} {
3314 set f [lindex $jump_to_here 0]
3315 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3316 showfile $f
3317 }
3318 }
3319}
3320
3321image create bitmap tri-rt -background black -foreground blue -data {
3322 #define tri-rt_width 13
3323 #define tri-rt_height 13
3324 static unsigned char tri-rt_bits[] = {
3325 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3326 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3327 0x00, 0x00};
3328} -maskdata {
3329 #define tri-rt-mask_width 13
3330 #define tri-rt-mask_height 13
3331 static unsigned char tri-rt-mask_bits[] = {
3332 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3333 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3334 0x08, 0x00};
3335}
3336image create bitmap tri-dn -background black -foreground blue -data {
3337 #define tri-dn_width 13
3338 #define tri-dn_height 13
3339 static unsigned char tri-dn_bits[] = {
3340 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3341 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3342 0x00, 0x00};
3343} -maskdata {
3344 #define tri-dn-mask_width 13
3345 #define tri-dn-mask_height 13
3346 static unsigned char tri-dn-mask_bits[] = {
3347 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3348 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3349 0x00, 0x00};
3350}
3351
3352image create bitmap reficon-T -background black -foreground yellow -data {
3353 #define tagicon_width 13
3354 #define tagicon_height 9
3355 static unsigned char tagicon_bits[] = {
3356 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3357 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3358} -maskdata {
3359 #define tagicon-mask_width 13
3360 #define tagicon-mask_height 9
3361 static unsigned char tagicon-mask_bits[] = {
3362 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3363 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3364}
3365set rectdata {
3366 #define headicon_width 13
3367 #define headicon_height 9
3368 static unsigned char headicon_bits[] = {
3369 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3370 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3371}
3372set rectmask {
3373 #define headicon-mask_width 13
3374 #define headicon-mask_height 9
3375 static unsigned char headicon-mask_bits[] = {
3376 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3377 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3378}
3379image create bitmap reficon-H -background black -foreground green \
3380 -data $rectdata -maskdata $rectmask
3381image create bitmap reficon-o -background black -foreground "#ddddff" \
3382 -data $rectdata -maskdata $rectmask
3383
3384proc init_flist {first} {
3385 global cflist cflist_top difffilestart
3386
3387 $cflist conf -state normal
3388 $cflist delete 0.0 end
3389 if {$first ne {}} {
3390 $cflist insert end $first
3391 set cflist_top 1
3392 $cflist tag add highlight 1.0 "1.0 lineend"
3393 } else {
3394 unset -nocomplain cflist_top
3395 }
3396 $cflist conf -state disabled
3397 set difffilestart {}
3398}
3399
3400proc highlight_tag {f} {
3401 global highlight_paths
3402
3403 foreach p $highlight_paths {
3404 if {[string match $p $f]} {
3405 return "bold"
3406 }
3407 }
3408 return {}
3409}
3410
3411proc highlight_filelist {} {
3412 global cmitmode cflist
3413
3414 $cflist conf -state normal
3415 if {$cmitmode ne "tree"} {
3416 set end [lindex [split [$cflist index end] .] 0]
3417 for {set l 2} {$l < $end} {incr l} {
3418 set line [$cflist get $l.0 "$l.0 lineend"]
3419 if {[highlight_tag $line] ne {}} {
3420 $cflist tag add bold $l.0 "$l.0 lineend"
3421 }
3422 }
3423 } else {
3424 highlight_tree 2 {}
3425 }
3426 $cflist conf -state disabled
3427}
3428
3429proc unhighlight_filelist {} {
3430 global cflist
3431
3432 $cflist conf -state normal
3433 $cflist tag remove bold 1.0 end
3434 $cflist conf -state disabled
3435}
3436
3437proc add_flist {fl} {
3438 global cflist
3439
3440 $cflist conf -state normal
3441 foreach f $fl {
3442 $cflist insert end "\n"
3443 $cflist insert end $f [highlight_tag $f]
3444 }
3445 $cflist conf -state disabled
3446}
3447
3448proc sel_flist {w x y} {
3449 global ctext difffilestart cflist cflist_top cmitmode
3450
3451 if {$cmitmode eq "tree"} return
3452 if {![info exists cflist_top]} return
3453 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3454 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3455 $cflist tag add highlight $l.0 "$l.0 lineend"
3456 set cflist_top $l
3457 if {$l == 1} {
3458 $ctext yview 1.0
3459 } else {
3460 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3461 }
3462 suppress_highlighting_file_for_current_scrollpos
3463}
3464
3465proc pop_flist_menu {w X Y x y} {
3466 global ctext cflist cmitmode flist_menu flist_menu_file
3467 global treediffs diffids
3468
3469 stopfinding
3470 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3471 if {$l <= 1} return
3472 if {$cmitmode eq "tree"} {
3473 set e [linetoelt $l]
3474 if {[string index $e end] eq "/"} return
3475 } else {
3476 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3477 }
3478 set flist_menu_file $e
3479 set xdiffstate "normal"
3480 if {$cmitmode eq "tree"} {
3481 set xdiffstate "disabled"
3482 }
3483 # Disable "External diff" item in tree mode
3484 $flist_menu entryconf 2 -state $xdiffstate
3485 tk_popup $flist_menu $X $Y
3486}
3487
3488proc find_ctext_fileinfo {line} {
3489 global ctext_file_names ctext_file_lines
3490
3491 set ok [bsearch $ctext_file_lines $line]
3492 set tline [lindex $ctext_file_lines $ok]
3493
3494 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3495 return {}
3496 } else {
3497 return [list [lindex $ctext_file_names $ok] $tline]
3498 }
3499}
3500
3501proc pop_diff_menu {w X Y x y} {
3502 global ctext diff_menu flist_menu_file
3503 global diff_menu_txtpos diff_menu_line
3504 global diff_menu_filebase
3505
3506 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3507 set diff_menu_line [lindex $diff_menu_txtpos 0]
3508 # don't pop up the menu on hunk-separator or file-separator lines
3509 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3510 return
3511 }
3512 stopfinding
3513 set f [find_ctext_fileinfo $diff_menu_line]
3514 if {$f eq {}} return
3515 set flist_menu_file [lindex $f 0]
3516 set diff_menu_filebase [lindex $f 1]
3517 tk_popup $diff_menu $X $Y
3518}
3519
3520proc flist_hl {only} {
3521 global flist_menu_file findstring gdttype
3522
3523 set x [shellquote $flist_menu_file]
3524 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3525 set findstring $x
3526 } else {
3527 append findstring " " $x
3528 }
3529 set gdttype [mc "touching paths:"]
3530}
3531
3532proc gitknewtmpdir {} {
3533 global diffnum gitktmpdir gitdir env
3534
3535 if {![info exists gitktmpdir]} {
3536 if {[info exists env(GITK_TMPDIR)]} {
3537 set tmpdir $env(GITK_TMPDIR)
3538 } elseif {[info exists env(TMPDIR)]} {
3539 set tmpdir $env(TMPDIR)
3540 } else {
3541 set tmpdir $gitdir
3542 }
3543 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3544 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3545 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3546 }
3547 if {[catch {file mkdir $gitktmpdir} err]} {
3548 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3549 unset gitktmpdir
3550 return {}
3551 }
3552 set diffnum 0
3553 }
3554 incr diffnum
3555 set diffdir [file join $gitktmpdir $diffnum]
3556 if {[catch {file mkdir $diffdir} err]} {
3557 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3558 return {}
3559 }
3560 return $diffdir
3561}
3562
3563proc save_file_from_commit {filename output what} {
3564 global nullfile
3565
3566 if {[catch {exec git show $filename -- > $output} err]} {
3567 if {[string match "fatal: bad revision *" $err]} {
3568 return $nullfile
3569 }
3570 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3571 return {}
3572 }
3573 return $output
3574}
3575
3576proc external_diff_get_one_file {diffid filename diffdir} {
3577 global nullid nullid2 nullfile
3578 global worktree
3579
3580 if {$diffid == $nullid} {
3581 set difffile [file join $worktree $filename]
3582 if {[file exists $difffile]} {
3583 return $difffile
3584 }
3585 return $nullfile
3586 }
3587 if {$diffid == $nullid2} {
3588 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3589 return [save_file_from_commit :$filename $difffile index]
3590 }
3591 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3592 return [save_file_from_commit $diffid:$filename $difffile \
3593 "revision $diffid"]
3594}
3595
3596proc external_diff {} {
3597 global nullid nullid2
3598 global flist_menu_file
3599 global diffids
3600 global extdifftool
3601
3602 if {[llength $diffids] == 1} {
3603 # no reference commit given
3604 set diffidto [lindex $diffids 0]
3605 if {$diffidto eq $nullid} {
3606 # diffing working copy with index
3607 set diffidfrom $nullid2
3608 } elseif {$diffidto eq $nullid2} {
3609 # diffing index with HEAD
3610 set diffidfrom "HEAD"
3611 } else {
3612 # use first parent commit
3613 global parentlist selectedline
3614 set diffidfrom [lindex $parentlist $selectedline 0]
3615 }
3616 } else {
3617 set diffidfrom [lindex $diffids 0]
3618 set diffidto [lindex $diffids 1]
3619 }
3620
3621 # make sure that several diffs wont collide
3622 set diffdir [gitknewtmpdir]
3623 if {$diffdir eq {}} return
3624
3625 # gather files to diff
3626 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3627 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3628
3629 if {$difffromfile ne {} && $difftofile ne {}} {
3630 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3631 if {[catch {set fl [open |$cmd r]} err]} {
3632 file delete -force $diffdir
3633 error_popup "$extdifftool: [mc "command failed:"] $err"
3634 } else {
3635 fconfigure $fl -blocking 0
3636 filerun $fl [list delete_at_eof $fl $diffdir]
3637 }
3638 }
3639}
3640
3641proc find_hunk_blamespec {base line} {
3642 global ctext
3643
3644 # Find and parse the hunk header
3645 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3646 if {$s_lix eq {}} return
3647
3648 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3649 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3650 s_line old_specs osz osz1 new_line nsz]} {
3651 return
3652 }
3653
3654 # base lines for the parents
3655 set base_lines [list $new_line]
3656 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3657 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3658 old_spec old_line osz]} {
3659 return
3660 }
3661 lappend base_lines $old_line
3662 }
3663
3664 # Now scan the lines to determine offset within the hunk
3665 set max_parent [expr {[llength $base_lines]-2}]
3666 set dline 0
3667 set s_lno [lindex [split $s_lix "."] 0]
3668
3669 # Determine if the line is removed
3670 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3671 if {[string match {[-+ ]*} $chunk]} {
3672 set removed_idx [string first "-" $chunk]
3673 # Choose a parent index
3674 if {$removed_idx >= 0} {
3675 set parent $removed_idx
3676 } else {
3677 set unchanged_idx [string first " " $chunk]
3678 if {$unchanged_idx >= 0} {
3679 set parent $unchanged_idx
3680 } else {
3681 # blame the current commit
3682 set parent -1
3683 }
3684 }
3685 # then count other lines that belong to it
3686 for {set i $line} {[incr i -1] > $s_lno} {} {
3687 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3688 # Determine if the line is removed
3689 set removed_idx [string first "-" $chunk]
3690 if {$parent >= 0} {
3691 set code [string index $chunk $parent]
3692 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3693 incr dline
3694 }
3695 } else {
3696 if {$removed_idx < 0} {
3697 incr dline
3698 }
3699 }
3700 }
3701 incr parent
3702 } else {
3703 set parent 0
3704 }
3705
3706 incr dline [lindex $base_lines $parent]
3707 return [list $parent $dline]
3708}
3709
3710proc external_blame_diff {} {
3711 global currentid cmitmode
3712 global diff_menu_txtpos diff_menu_line
3713 global diff_menu_filebase flist_menu_file
3714
3715 if {$cmitmode eq "tree"} {
3716 set parent_idx 0
3717 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3718 } else {
3719 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3720 if {$hinfo ne {}} {
3721 set parent_idx [lindex $hinfo 0]
3722 set line [lindex $hinfo 1]
3723 } else {
3724 set parent_idx 0
3725 set line 0
3726 }
3727 }
3728
3729 external_blame $parent_idx $line
3730}
3731
3732# Find the SHA1 ID of the blob for file $fname in the index
3733# at stage 0 or 2
3734proc index_sha1 {fname} {
3735 set f [open [list | git ls-files -s $fname] r]
3736 while {[gets $f line] >= 0} {
3737 set info [lindex [split $line "\t"] 0]
3738 set stage [lindex $info 2]
3739 if {$stage eq "0" || $stage eq "2"} {
3740 close $f
3741 return [lindex $info 1]
3742 }
3743 }
3744 close $f
3745 return {}
3746}
3747
3748# Turn an absolute path into one relative to the current directory
3749proc make_relative {f} {
3750 if {[file pathtype $f] eq "relative"} {
3751 return $f
3752 }
3753 set elts [file split $f]
3754 set here [file split [pwd]]
3755 set ei 0
3756 set hi 0
3757 set res {}
3758 foreach d $here {
3759 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3760 lappend res ".."
3761 } else {
3762 incr ei
3763 }
3764 incr hi
3765 }
3766 set elts [concat $res [lrange $elts $ei end]]
3767 return [eval file join $elts]
3768}
3769
3770proc external_blame {parent_idx {line {}}} {
3771 global flist_menu_file cdup
3772 global nullid nullid2
3773 global parentlist selectedline currentid
3774
3775 if {$parent_idx > 0} {
3776 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3777 } else {
3778 set base_commit $currentid
3779 }
3780
3781 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3782 error_popup [mc "No such commit"]
3783 return
3784 }
3785
3786 set cmdline [list git gui blame]
3787 if {$line ne {} && $line > 1} {
3788 lappend cmdline "--line=$line"
3789 }
3790 set f [file join $cdup $flist_menu_file]
3791 # Unfortunately it seems git gui blame doesn't like
3792 # being given an absolute path...
3793 set f [make_relative $f]
3794 lappend cmdline $base_commit $f
3795 if {[catch {eval exec $cmdline &} err]} {
3796 error_popup "[mc "git gui blame: command failed:"] $err"
3797 }
3798}
3799
3800proc show_line_source {} {
3801 global cmitmode currentid parents curview blamestuff blameinst
3802 global diff_menu_line diff_menu_filebase flist_menu_file
3803 global nullid nullid2 gitdir cdup
3804
3805 set from_index {}
3806 if {$cmitmode eq "tree"} {
3807 set id $currentid
3808 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3809 } else {
3810 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3811 if {$h eq {}} return
3812 set pi [lindex $h 0]
3813 if {$pi == 0} {
3814 mark_ctext_line $diff_menu_line
3815 return
3816 }
3817 incr pi -1
3818 if {$currentid eq $nullid} {
3819 if {$pi > 0} {
3820 # must be a merge in progress...
3821 if {[catch {
3822 # get the last line from .git/MERGE_HEAD
3823 set f [open [file join $gitdir MERGE_HEAD] r]
3824 set id [lindex [split [read $f] "\n"] end-1]
3825 close $f
3826 } err]} {
3827 error_popup [mc "Couldn't read merge head: %s" $err]
3828 return
3829 }
3830 } elseif {$parents($curview,$currentid) eq $nullid2} {
3831 # need to do the blame from the index
3832 if {[catch {
3833 set from_index [index_sha1 $flist_menu_file]
3834 } err]} {
3835 error_popup [mc "Error reading index: %s" $err]
3836 return
3837 }
3838 } else {
3839 set id $parents($curview,$currentid)
3840 }
3841 } else {
3842 set id [lindex $parents($curview,$currentid) $pi]
3843 }
3844 set line [lindex $h 1]
3845 }
3846 set blameargs {}
3847 if {$from_index ne {}} {
3848 lappend blameargs | git cat-file blob $from_index
3849 }
3850 lappend blameargs | git blame -p -L$line,+1
3851 if {$from_index ne {}} {
3852 lappend blameargs --contents -
3853 } else {
3854 lappend blameargs $id
3855 }
3856 lappend blameargs -- [file join $cdup $flist_menu_file]
3857 if {[catch {
3858 set f [open $blameargs r]
3859 } err]} {
3860 error_popup [mc "Couldn't start git blame: %s" $err]
3861 return
3862 }
3863 nowbusy blaming [mc "Searching"]
3864 fconfigure $f -blocking 0
3865 set i [reg_instance $f]
3866 set blamestuff($i) {}
3867 set blameinst $i
3868 filerun $f [list read_line_source $f $i]
3869}
3870
3871proc stopblaming {} {
3872 global blameinst
3873
3874 if {[info exists blameinst]} {
3875 stop_instance $blameinst
3876 unset blameinst
3877 notbusy blaming
3878 }
3879}
3880
3881proc read_line_source {fd inst} {
3882 global blamestuff curview commfd blameinst nullid nullid2
3883
3884 while {[gets $fd line] >= 0} {
3885 lappend blamestuff($inst) $line
3886 }
3887 if {![eof $fd]} {
3888 return 1
3889 }
3890 unset commfd($inst)
3891 unset blameinst
3892 notbusy blaming
3893 fconfigure $fd -blocking 1
3894 if {[catch {close $fd} err]} {
3895 error_popup [mc "Error running git blame: %s" $err]
3896 return 0
3897 }
3898
3899 set fname {}
3900 set line [split [lindex $blamestuff($inst) 0] " "]
3901 set id [lindex $line 0]
3902 set lnum [lindex $line 1]
3903 if {[string length $id] == 40 && [string is xdigit $id] &&
3904 [string is digit -strict $lnum]} {
3905 # look for "filename" line
3906 foreach l $blamestuff($inst) {
3907 if {[string match "filename *" $l]} {
3908 set fname [string range $l 9 end]
3909 break
3910 }
3911 }
3912 }
3913 if {$fname ne {}} {
3914 # all looks good, select it
3915 if {$id eq $nullid} {
3916 # blame uses all-zeroes to mean not committed,
3917 # which would mean a change in the index
3918 set id $nullid2
3919 }
3920 if {[commitinview $id $curview]} {
3921 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3922 } else {
3923 error_popup [mc "That line comes from commit %s, \
3924 which is not in this view" [shortids $id]]
3925 }
3926 } else {
3927 puts "oops couldn't parse git blame output"
3928 }
3929 return 0
3930}
3931
3932# delete $dir when we see eof on $f (presumably because the child has exited)
3933proc delete_at_eof {f dir} {
3934 while {[gets $f line] >= 0} {}
3935 if {[eof $f]} {
3936 if {[catch {close $f} err]} {
3937 error_popup "[mc "External diff viewer failed:"] $err"
3938 }
3939 file delete -force $dir
3940 return 0
3941 }
3942 return 1
3943}
3944
3945# Functions for adding and removing shell-type quoting
3946
3947proc shellquote {str} {
3948 if {![string match "*\['\"\\ \t]*" $str]} {
3949 return $str
3950 }
3951 if {![string match "*\['\"\\]*" $str]} {
3952 return "\"$str\""
3953 }
3954 if {![string match "*'*" $str]} {
3955 return "'$str'"
3956 }
3957 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3958}
3959
3960proc shellarglist {l} {
3961 set str {}
3962 foreach a $l {
3963 if {$str ne {}} {
3964 append str " "
3965 }
3966 append str [shellquote $a]
3967 }
3968 return $str
3969}
3970
3971proc shelldequote {str} {
3972 set ret {}
3973 set used -1
3974 while {1} {
3975 incr used
3976 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3977 append ret [string range $str $used end]
3978 set used [string length $str]
3979 break
3980 }
3981 set first [lindex $first 0]
3982 set ch [string index $str $first]
3983 if {$first > $used} {
3984 append ret [string range $str $used [expr {$first - 1}]]
3985 set used $first
3986 }
3987 if {$ch eq " " || $ch eq "\t"} break
3988 incr used
3989 if {$ch eq "'"} {
3990 set first [string first "'" $str $used]
3991 if {$first < 0} {
3992 error "unmatched single-quote"
3993 }
3994 append ret [string range $str $used [expr {$first - 1}]]
3995 set used $first
3996 continue
3997 }
3998 if {$ch eq "\\"} {
3999 if {$used >= [string length $str]} {
4000 error "trailing backslash"
4001 }
4002 append ret [string index $str $used]
4003 continue
4004 }
4005 # here ch == "\""
4006 while {1} {
4007 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4008 error "unmatched double-quote"
4009 }
4010 set first [lindex $first 0]
4011 set ch [string index $str $first]
4012 if {$first > $used} {
4013 append ret [string range $str $used [expr {$first - 1}]]
4014 set used $first
4015 }
4016 if {$ch eq "\""} break
4017 incr used
4018 append ret [string index $str $used]
4019 incr used
4020 }
4021 }
4022 return [list $used $ret]
4023}
4024
4025proc shellsplit {str} {
4026 set l {}
4027 while {1} {
4028 set str [string trimleft $str]
4029 if {$str eq {}} break
4030 set dq [shelldequote $str]
4031 set n [lindex $dq 0]
4032 set word [lindex $dq 1]
4033 set str [string range $str $n end]
4034 lappend l $word
4035 }
4036 return $l
4037}
4038
4039# Code to implement multiple views
4040
4041proc newview {ishighlight} {
4042 global nextviewnum newviewname newishighlight
4043 global revtreeargs viewargscmd newviewopts curview
4044
4045 set newishighlight $ishighlight
4046 set top .gitkview
4047 if {[winfo exists $top]} {
4048 raise $top
4049 return
4050 }
4051 decode_view_opts $nextviewnum $revtreeargs
4052 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4053 set newviewopts($nextviewnum,perm) 0
4054 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4055 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4056}
4057
4058set known_view_options {
4059 {perm b . {} {mc "Remember this view"}}
4060 {reflabel l + {} {mc "References (space separated list):"}}
4061 {refs t15 .. {} {mc "Branches & tags:"}}
4062 {allrefs b *. "--all" {mc "All refs"}}
4063 {branches b . "--branches" {mc "All (local) branches"}}
4064 {tags b . "--tags" {mc "All tags"}}
4065 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4066 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4067 {author t15 .. "--author=*" {mc "Author:"}}
4068 {committer t15 . "--committer=*" {mc "Committer:"}}
4069 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4070 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4071 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4072 {changes_l l + {} {mc "Changes to Files:"}}
4073 {pickaxe_s r0 . {} {mc "Fixed String"}}
4074 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4075 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4076 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4077 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4078 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4079 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4080 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4081 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4082 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4083 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4084 {lright b . "--left-right" {mc "Mark branch sides"}}
4085 {first b . "--first-parent" {mc "Limit to first parent"}}
4086 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4087 {args t50 *. {} {mc "Additional arguments to git log:"}}
4088 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4089 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4090 }
4091
4092# Convert $newviewopts($n, ...) into args for git log.
4093proc encode_view_opts {n} {
4094 global known_view_options newviewopts
4095
4096 set rargs [list]
4097 foreach opt $known_view_options {
4098 set patterns [lindex $opt 3]
4099 if {$patterns eq {}} continue
4100 set pattern [lindex $patterns 0]
4101
4102 if {[lindex $opt 1] eq "b"} {
4103 set val $newviewopts($n,[lindex $opt 0])
4104 if {$val} {
4105 lappend rargs $pattern
4106 }
4107 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4108 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4109 set val $newviewopts($n,$button_id)
4110 if {$val eq $value} {
4111 lappend rargs $pattern
4112 }
4113 } else {
4114 set val $newviewopts($n,[lindex $opt 0])
4115 set val [string trim $val]
4116 if {$val ne {}} {
4117 set pfix [string range $pattern 0 end-1]
4118 lappend rargs $pfix$val
4119 }
4120 }
4121 }
4122 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4123 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4124}
4125
4126# Fill $newviewopts($n, ...) based on args for git log.
4127proc decode_view_opts {n view_args} {
4128 global known_view_options newviewopts
4129
4130 foreach opt $known_view_options {
4131 set id [lindex $opt 0]
4132 if {[lindex $opt 1] eq "b"} {
4133 # Checkboxes
4134 set val 0
4135 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4136 # Radiobuttons
4137 regexp {^(.*_)} $id uselessvar id
4138 set val 0
4139 } else {
4140 # Text fields
4141 set val {}
4142 }
4143 set newviewopts($n,$id) $val
4144 }
4145 set oargs [list]
4146 set refargs [list]
4147 foreach arg $view_args {
4148 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4149 && ![info exists found(limit)]} {
4150 set newviewopts($n,limit) $cnt
4151 set found(limit) 1
4152 continue
4153 }
4154 catch { unset val }
4155 foreach opt $known_view_options {
4156 set id [lindex $opt 0]
4157 if {[info exists found($id)]} continue
4158 foreach pattern [lindex $opt 3] {
4159 if {![string match $pattern $arg]} continue
4160 if {[lindex $opt 1] eq "b"} {
4161 # Check buttons
4162 set val 1
4163 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4164 # Radio buttons
4165 regexp {^(.*_)} $id uselessvar id
4166 set val $num
4167 } else {
4168 # Text input fields
4169 set size [string length $pattern]
4170 set val [string range $arg [expr {$size-1}] end]
4171 }
4172 set newviewopts($n,$id) $val
4173 set found($id) 1
4174 break
4175 }
4176 if {[info exists val]} break
4177 }
4178 if {[info exists val]} continue
4179 if {[regexp {^-} $arg]} {
4180 lappend oargs $arg
4181 } else {
4182 lappend refargs $arg
4183 }
4184 }
4185 set newviewopts($n,refs) [shellarglist $refargs]
4186 set newviewopts($n,args) [shellarglist $oargs]
4187}
4188
4189proc edit_or_newview {} {
4190 global curview
4191
4192 if {$curview > 0} {
4193 editview
4194 } else {
4195 newview 0
4196 }
4197}
4198
4199proc editview {} {
4200 global curview
4201 global viewname viewperm newviewname newviewopts
4202 global viewargs viewargscmd
4203
4204 set top .gitkvedit-$curview
4205 if {[winfo exists $top]} {
4206 raise $top
4207 return
4208 }
4209 decode_view_opts $curview $viewargs($curview)
4210 set newviewname($curview) $viewname($curview)
4211 set newviewopts($curview,perm) $viewperm($curview)
4212 set newviewopts($curview,cmd) $viewargscmd($curview)
4213 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4214}
4215
4216proc vieweditor {top n title} {
4217 global newviewname newviewopts viewfiles bgcolor
4218 global known_view_options NS
4219
4220 ttk_toplevel $top
4221 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4222 make_transient $top .
4223
4224 # View name
4225 ${NS}::frame $top.nfr
4226 ${NS}::label $top.nl -text [mc "View Name"]
4227 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4228 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4229 pack $top.nl -in $top.nfr -side left -padx {0 5}
4230 pack $top.name -in $top.nfr -side left -padx {0 25}
4231
4232 # View options
4233 set cframe $top.nfr
4234 set cexpand 0
4235 set cnt 0
4236 foreach opt $known_view_options {
4237 set id [lindex $opt 0]
4238 set type [lindex $opt 1]
4239 set flags [lindex $opt 2]
4240 set title [eval [lindex $opt 4]]
4241 set lxpad 0
4242
4243 if {$flags eq "+" || $flags eq "*"} {
4244 set cframe $top.fr$cnt
4245 incr cnt
4246 ${NS}::frame $cframe
4247 pack $cframe -in $top -fill x -pady 3 -padx 3
4248 set cexpand [expr {$flags eq "*"}]
4249 } elseif {$flags eq ".." || $flags eq "*."} {
4250 set cframe $top.fr$cnt
4251 incr cnt
4252 ${NS}::frame $cframe
4253 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4254 set cexpand [expr {$flags eq "*."}]
4255 } else {
4256 set lxpad 5
4257 }
4258
4259 if {$type eq "l"} {
4260 ${NS}::label $cframe.l_$id -text $title
4261 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4262 } elseif {$type eq "b"} {
4263 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4264 pack $cframe.c_$id -in $cframe -side left \
4265 -padx [list $lxpad 0] -expand $cexpand -anchor w
4266 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4267 regexp {^(.*_)} $id uselessvar button_id
4268 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4269 pack $cframe.c_$id -in $cframe -side left \
4270 -padx [list $lxpad 0] -expand $cexpand -anchor w
4271 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4272 ${NS}::label $cframe.l_$id -text $title
4273 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4274 -textvariable newviewopts($n,$id)
4275 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4276 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4277 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4278 ${NS}::label $cframe.l_$id -text $title
4279 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4280 -textvariable newviewopts($n,$id)
4281 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4282 pack $cframe.e_$id -in $cframe -side top -fill x
4283 } elseif {$type eq "path"} {
4284 ${NS}::label $top.l -text $title
4285 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4286 text $top.t -width 40 -height 5 -background $bgcolor
4287 if {[info exists viewfiles($n)]} {
4288 foreach f $viewfiles($n) {
4289 $top.t insert end $f
4290 $top.t insert end "\n"
4291 }
4292 $top.t delete {end - 1c} end
4293 $top.t mark set insert 0.0
4294 }
4295 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4296 }
4297 }
4298
4299 ${NS}::frame $top.buts
4300 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4301 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4302 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4303 bind $top <Control-Return> [list newviewok $top $n]
4304 bind $top <F5> [list newviewok $top $n 1]
4305 bind $top <Escape> [list destroy $top]
4306 grid $top.buts.ok $top.buts.apply $top.buts.can
4307 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4308 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4309 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4310 pack $top.buts -in $top -side top -fill x
4311 focus $top.t
4312}
4313
4314proc doviewmenu {m first cmd op argv} {
4315 set nmenu [$m index end]
4316 for {set i $first} {$i <= $nmenu} {incr i} {
4317 if {[$m entrycget $i -command] eq $cmd} {
4318 eval $m $op $i $argv
4319 break
4320 }
4321 }
4322}
4323
4324proc allviewmenus {n op args} {
4325 # global viewhlmenu
4326
4327 doviewmenu .bar.view 5 [list showview $n] $op $args
4328 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4329}
4330
4331proc newviewok {top n {apply 0}} {
4332 global nextviewnum newviewperm newviewname newishighlight
4333 global viewname viewfiles viewperm viewchanged selectedview curview
4334 global viewargs viewargscmd newviewopts viewhlmenu
4335
4336 if {[catch {
4337 set newargs [encode_view_opts $n]
4338 } err]} {
4339 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4340 return
4341 }
4342 set files {}
4343 foreach f [split [$top.t get 0.0 end] "\n"] {
4344 set ft [string trim $f]
4345 if {$ft ne {}} {
4346 lappend files $ft
4347 }
4348 }
4349 if {![info exists viewfiles($n)]} {
4350 # creating a new view
4351 incr nextviewnum
4352 set viewname($n) $newviewname($n)
4353 set viewperm($n) $newviewopts($n,perm)
4354 set viewchanged($n) 1
4355 set viewfiles($n) $files
4356 set viewargs($n) $newargs
4357 set viewargscmd($n) $newviewopts($n,cmd)
4358 addviewmenu $n
4359 if {!$newishighlight} {
4360 run showview $n
4361 } else {
4362 run addvhighlight $n
4363 }
4364 } else {
4365 # editing an existing view
4366 set viewperm($n) $newviewopts($n,perm)
4367 set viewchanged($n) 1
4368 if {$newviewname($n) ne $viewname($n)} {
4369 set viewname($n) $newviewname($n)
4370 doviewmenu .bar.view 5 [list showview $n] \
4371 entryconf [list -label $viewname($n)]
4372 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4373 # entryconf [list -label $viewname($n) -value $viewname($n)]
4374 }
4375 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4376 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4377 set viewfiles($n) $files
4378 set viewargs($n) $newargs
4379 set viewargscmd($n) $newviewopts($n,cmd)
4380 if {$curview == $n} {
4381 run reloadcommits
4382 }
4383 }
4384 }
4385 if {$apply} return
4386 catch {destroy $top}
4387}
4388
4389proc delview {} {
4390 global curview viewperm hlview selectedhlview viewchanged
4391
4392 if {$curview == 0} return
4393 if {[info exists hlview] && $hlview == $curview} {
4394 set selectedhlview [mc "None"]
4395 unset hlview
4396 }
4397 allviewmenus $curview delete
4398 set viewperm($curview) 0
4399 set viewchanged($curview) 1
4400 showview 0
4401}
4402
4403proc addviewmenu {n} {
4404 global viewname viewhlmenu
4405
4406 .bar.view add radiobutton -label $viewname($n) \
4407 -command [list showview $n] -variable selectedview -value $n
4408 #$viewhlmenu add radiobutton -label $viewname($n) \
4409 # -command [list addvhighlight $n] -variable selectedhlview
4410}
4411
4412proc showview {n} {
4413 global curview cached_commitrow ordertok
4414 global displayorder parentlist rowidlist rowisopt rowfinal
4415 global colormap rowtextx nextcolor canvxmax
4416 global numcommits viewcomplete
4417 global selectedline currentid canv canvy0
4418 global treediffs
4419 global pending_select mainheadid
4420 global commitidx
4421 global selectedview
4422 global hlview selectedhlview commitinterest
4423
4424 if {$n == $curview} return
4425 set selid {}
4426 set ymax [lindex [$canv cget -scrollregion] 3]
4427 set span [$canv yview]
4428 set ytop [expr {[lindex $span 0] * $ymax}]
4429 set ybot [expr {[lindex $span 1] * $ymax}]
4430 set yscreen [expr {($ybot - $ytop) / 2}]
4431 if {$selectedline ne {}} {
4432 set selid $currentid
4433 set y [yc $selectedline]
4434 if {$ytop < $y && $y < $ybot} {
4435 set yscreen [expr {$y - $ytop}]
4436 }
4437 } elseif {[info exists pending_select]} {
4438 set selid $pending_select
4439 unset pending_select
4440 }
4441 unselectline
4442 normalline
4443 unset -nocomplain treediffs
4444 clear_display
4445 if {[info exists hlview] && $hlview == $n} {
4446 unset hlview
4447 set selectedhlview [mc "None"]
4448 }
4449 unset -nocomplain commitinterest
4450 unset -nocomplain cached_commitrow
4451 unset -nocomplain ordertok
4452
4453 set curview $n
4454 set selectedview $n
4455 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4456 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4457
4458 run refill_reflist
4459 if {![info exists viewcomplete($n)]} {
4460 getcommits $selid
4461 return
4462 }
4463
4464 set displayorder {}
4465 set parentlist {}
4466 set rowidlist {}
4467 set rowisopt {}
4468 set rowfinal {}
4469 set numcommits $commitidx($n)
4470
4471 unset -nocomplain colormap
4472 unset -nocomplain rowtextx
4473 set nextcolor 0
4474 set canvxmax [$canv cget -width]
4475 set curview $n
4476 set row 0
4477 setcanvscroll
4478 set yf 0
4479 set row {}
4480 if {$selid ne {} && [commitinview $selid $n]} {
4481 set row [rowofcommit $selid]
4482 # try to get the selected row in the same position on the screen
4483 set ymax [lindex [$canv cget -scrollregion] 3]
4484 set ytop [expr {[yc $row] - $yscreen}]
4485 if {$ytop < 0} {
4486 set ytop 0
4487 }
4488 set yf [expr {$ytop * 1.0 / $ymax}]
4489 }
4490 allcanvs yview moveto $yf
4491 drawvisible
4492 if {$row ne {}} {
4493 selectline $row 0
4494 } elseif {!$viewcomplete($n)} {
4495 reset_pending_select $selid
4496 } else {
4497 reset_pending_select {}
4498
4499 if {[commitinview $pending_select $curview]} {
4500 selectline [rowofcommit $pending_select] 1
4501 } else {
4502 set row [first_real_row]
4503 if {$row < $numcommits} {
4504 selectline $row 0
4505 }
4506 }
4507 }
4508 if {!$viewcomplete($n)} {
4509 if {$numcommits == 0} {
4510 show_status [mc "Reading commits..."]
4511 }
4512 } elseif {$numcommits == 0} {
4513 show_status [mc "No commits selected"]
4514 }
4515}
4516
4517# Stuff relating to the highlighting facility
4518
4519proc ishighlighted {id} {
4520 global vhighlights fhighlights nhighlights rhighlights
4521
4522 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4523 return $nhighlights($id)
4524 }
4525 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4526 return $vhighlights($id)
4527 }
4528 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4529 return $fhighlights($id)
4530 }
4531 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4532 return $rhighlights($id)
4533 }
4534 return 0
4535}
4536
4537proc bolden {id font} {
4538 global canv linehtag currentid boldids need_redisplay markedid
4539
4540 # need_redisplay = 1 means the display is stale and about to be redrawn
4541 if {$need_redisplay} return
4542 lappend boldids $id
4543 $canv itemconf $linehtag($id) -font $font
4544 if {[info exists currentid] && $id eq $currentid} {
4545 $canv delete secsel
4546 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4547 -outline {{}} -tags secsel \
4548 -fill [$canv cget -selectbackground]]
4549 $canv lower $t
4550 }
4551 if {[info exists markedid] && $id eq $markedid} {
4552 make_idmark $id
4553 }
4554}
4555
4556proc bolden_name {id font} {
4557 global canv2 linentag currentid boldnameids need_redisplay
4558
4559 if {$need_redisplay} return
4560 lappend boldnameids $id
4561 $canv2 itemconf $linentag($id) -font $font
4562 if {[info exists currentid] && $id eq $currentid} {
4563 $canv2 delete secsel
4564 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4565 -outline {{}} -tags secsel \
4566 -fill [$canv2 cget -selectbackground]]
4567 $canv2 lower $t
4568 }
4569}
4570
4571proc unbolden {} {
4572 global boldids
4573
4574 set stillbold {}
4575 foreach id $boldids {
4576 if {![ishighlighted $id]} {
4577 bolden $id mainfont
4578 } else {
4579 lappend stillbold $id
4580 }
4581 }
4582 set boldids $stillbold
4583}
4584
4585proc addvhighlight {n} {
4586 global hlview viewcomplete curview vhl_done commitidx
4587
4588 if {[info exists hlview]} {
4589 delvhighlight
4590 }
4591 set hlview $n
4592 if {$n != $curview && ![info exists viewcomplete($n)]} {
4593 start_rev_list $n
4594 }
4595 set vhl_done $commitidx($hlview)
4596 if {$vhl_done > 0} {
4597 drawvisible
4598 }
4599}
4600
4601proc delvhighlight {} {
4602 global hlview vhighlights
4603
4604 if {![info exists hlview]} return
4605 unset hlview
4606 unset -nocomplain vhighlights
4607 unbolden
4608}
4609
4610proc vhighlightmore {} {
4611 global hlview vhl_done commitidx vhighlights curview
4612
4613 set max $commitidx($hlview)
4614 set vr [visiblerows]
4615 set r0 [lindex $vr 0]
4616 set r1 [lindex $vr 1]
4617 for {set i $vhl_done} {$i < $max} {incr i} {
4618 set id [commitonrow $i $hlview]
4619 if {[commitinview $id $curview]} {
4620 set row [rowofcommit $id]
4621 if {$r0 <= $row && $row <= $r1} {
4622 if {![highlighted $row]} {
4623 bolden $id mainfontbold
4624 }
4625 set vhighlights($id) 1
4626 }
4627 }
4628 }
4629 set vhl_done $max
4630 return 0
4631}
4632
4633proc askvhighlight {row id} {
4634 global hlview vhighlights iddrawn
4635
4636 if {[commitinview $id $hlview]} {
4637 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4638 bolden $id mainfontbold
4639 }
4640 set vhighlights($id) 1
4641 } else {
4642 set vhighlights($id) 0
4643 }
4644}
4645
4646proc hfiles_change {} {
4647 global highlight_files filehighlight fhighlights fh_serial
4648 global highlight_paths
4649
4650 if {[info exists filehighlight]} {
4651 # delete previous highlights
4652 catch {close $filehighlight}
4653 unset filehighlight
4654 unset -nocomplain fhighlights
4655 unbolden
4656 unhighlight_filelist
4657 }
4658 set highlight_paths {}
4659 after cancel do_file_hl $fh_serial
4660 incr fh_serial
4661 if {$highlight_files ne {}} {
4662 after 300 do_file_hl $fh_serial
4663 }
4664}
4665
4666proc gdttype_change {name ix op} {
4667 global gdttype highlight_files findstring findpattern
4668
4669 stopfinding
4670 if {$findstring ne {}} {
4671 if {$gdttype eq [mc "containing:"]} {
4672 if {$highlight_files ne {}} {
4673 set highlight_files {}
4674 hfiles_change
4675 }
4676 findcom_change
4677 } else {
4678 if {$findpattern ne {}} {
4679 set findpattern {}
4680 findcom_change
4681 }
4682 set highlight_files $findstring
4683 hfiles_change
4684 }
4685 drawvisible
4686 }
4687 # enable/disable findtype/findloc menus too
4688}
4689
4690proc find_change {name ix op} {
4691 global gdttype findstring highlight_files
4692
4693 stopfinding
4694 if {$gdttype eq [mc "containing:"]} {
4695 findcom_change
4696 } else {
4697 if {$highlight_files ne $findstring} {
4698 set highlight_files $findstring
4699 hfiles_change
4700 }
4701 }
4702 drawvisible
4703}
4704
4705proc findcom_change args {
4706 global nhighlights boldnameids
4707 global findpattern findtype findstring gdttype
4708
4709 stopfinding
4710 # delete previous highlights, if any
4711 foreach id $boldnameids {
4712 bolden_name $id mainfont
4713 }
4714 set boldnameids {}
4715 unset -nocomplain nhighlights
4716 unbolden
4717 unmarkmatches
4718 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4719 set findpattern {}
4720 } elseif {$findtype eq [mc "Regexp"]} {
4721 set findpattern $findstring
4722 } else {
4723 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4724 $findstring]
4725 set findpattern "*$e*"
4726 }
4727}
4728
4729proc makepatterns {l} {
4730 set ret {}
4731 foreach e $l {
4732 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4733 if {[string index $ee end] eq "/"} {
4734 lappend ret "$ee*"
4735 } else {
4736 lappend ret $ee
4737 lappend ret "$ee/*"
4738 }
4739 }
4740 return $ret
4741}
4742
4743proc do_file_hl {serial} {
4744 global highlight_files filehighlight highlight_paths gdttype fhl_list
4745 global cdup findtype
4746
4747 if {$gdttype eq [mc "touching paths:"]} {
4748 # If "exact" match then convert backslashes to forward slashes.
4749 # Most useful to support Windows-flavoured file paths.
4750 if {$findtype eq [mc "Exact"]} {
4751 set highlight_files [string map {"\\" "/"} $highlight_files]
4752 }
4753 if {[catch {set paths [shellsplit $highlight_files]}]} return
4754 set highlight_paths [makepatterns $paths]
4755 highlight_filelist
4756 set relative_paths {}
4757 foreach path $paths {
4758 lappend relative_paths [file join $cdup $path]
4759 }
4760 set gdtargs [concat -- $relative_paths]
4761 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4762 set gdtargs [list "-S$highlight_files"]
4763 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4764 set gdtargs [list "-G$highlight_files"]
4765 } else {
4766 # must be "containing:", i.e. we're searching commit info
4767 return
4768 }
4769 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4770 set filehighlight [open $cmd r+]
4771 fconfigure $filehighlight -blocking 0
4772 filerun $filehighlight readfhighlight
4773 set fhl_list {}
4774 drawvisible
4775 flushhighlights
4776}
4777
4778proc flushhighlights {} {
4779 global filehighlight fhl_list
4780
4781 if {[info exists filehighlight]} {
4782 lappend fhl_list {}
4783 puts $filehighlight ""
4784 flush $filehighlight
4785 }
4786}
4787
4788proc askfilehighlight {row id} {
4789 global filehighlight fhighlights fhl_list
4790
4791 lappend fhl_list $id
4792 set fhighlights($id) -1
4793 puts $filehighlight $id
4794}
4795
4796proc readfhighlight {} {
4797 global filehighlight fhighlights curview iddrawn
4798 global fhl_list find_dirn
4799
4800 if {![info exists filehighlight]} {
4801 return 0
4802 }
4803 set nr 0
4804 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4805 set line [string trim $line]
4806 set i [lsearch -exact $fhl_list $line]
4807 if {$i < 0} continue
4808 for {set j 0} {$j < $i} {incr j} {
4809 set id [lindex $fhl_list $j]
4810 set fhighlights($id) 0
4811 }
4812 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4813 if {$line eq {}} continue
4814 if {![commitinview $line $curview]} continue
4815 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4816 bolden $line mainfontbold
4817 }
4818 set fhighlights($line) 1
4819 }
4820 if {[eof $filehighlight]} {
4821 # strange...
4822 puts "oops, git diff-tree died"
4823 catch {close $filehighlight}
4824 unset filehighlight
4825 return 0
4826 }
4827 if {[info exists find_dirn]} {
4828 run findmore
4829 }
4830 return 1
4831}
4832
4833proc doesmatch {f} {
4834 global findtype findpattern
4835
4836 if {$findtype eq [mc "Regexp"]} {
4837 return [regexp $findpattern $f]
4838 } elseif {$findtype eq [mc "IgnCase"]} {
4839 return [string match -nocase $findpattern $f]
4840 } else {
4841 return [string match $findpattern $f]
4842 }
4843}
4844
4845proc askfindhighlight {row id} {
4846 global nhighlights commitinfo iddrawn
4847 global findloc
4848 global markingmatches
4849
4850 if {![info exists commitinfo($id)]} {
4851 getcommit $id
4852 }
4853 set info $commitinfo($id)
4854 set isbold 0
4855 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4856 foreach f $info ty $fldtypes {
4857 if {$ty eq ""} continue
4858 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4859 [doesmatch $f]} {
4860 if {$ty eq [mc "Author"]} {
4861 set isbold 2
4862 break
4863 }
4864 set isbold 1
4865 }
4866 }
4867 if {$isbold && [info exists iddrawn($id)]} {
4868 if {![ishighlighted $id]} {
4869 bolden $id mainfontbold
4870 if {$isbold > 1} {
4871 bolden_name $id mainfontbold
4872 }
4873 }
4874 if {$markingmatches} {
4875 markrowmatches $row $id
4876 }
4877 }
4878 set nhighlights($id) $isbold
4879}
4880
4881proc markrowmatches {row id} {
4882 global canv canv2 linehtag linentag commitinfo findloc
4883
4884 set headline [lindex $commitinfo($id) 0]
4885 set author [lindex $commitinfo($id) 1]
4886 $canv delete match$row
4887 $canv2 delete match$row
4888 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4889 set m [findmatches $headline]
4890 if {$m ne {}} {
4891 markmatches $canv $row $headline $linehtag($id) $m \
4892 [$canv itemcget $linehtag($id) -font] $row
4893 }
4894 }
4895 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4896 set m [findmatches $author]
4897 if {$m ne {}} {
4898 markmatches $canv2 $row $author $linentag($id) $m \
4899 [$canv2 itemcget $linentag($id) -font] $row
4900 }
4901 }
4902}
4903
4904proc vrel_change {name ix op} {
4905 global highlight_related
4906
4907 rhighlight_none
4908 if {$highlight_related ne [mc "None"]} {
4909 run drawvisible
4910 }
4911}
4912
4913# prepare for testing whether commits are descendents or ancestors of a
4914proc rhighlight_sel {a} {
4915 global descendent desc_todo ancestor anc_todo
4916 global highlight_related
4917
4918 unset -nocomplain descendent
4919 set desc_todo [list $a]
4920 unset -nocomplain ancestor
4921 set anc_todo [list $a]
4922 if {$highlight_related ne [mc "None"]} {
4923 rhighlight_none
4924 run drawvisible
4925 }
4926}
4927
4928proc rhighlight_none {} {
4929 global rhighlights
4930
4931 unset -nocomplain rhighlights
4932 unbolden
4933}
4934
4935proc is_descendent {a} {
4936 global curview children descendent desc_todo
4937
4938 set v $curview
4939 set la [rowofcommit $a]
4940 set todo $desc_todo
4941 set leftover {}
4942 set done 0
4943 for {set i 0} {$i < [llength $todo]} {incr i} {
4944 set do [lindex $todo $i]
4945 if {[rowofcommit $do] < $la} {
4946 lappend leftover $do
4947 continue
4948 }
4949 foreach nk $children($v,$do) {
4950 if {![info exists descendent($nk)]} {
4951 set descendent($nk) 1
4952 lappend todo $nk
4953 if {$nk eq $a} {
4954 set done 1
4955 }
4956 }
4957 }
4958 if {$done} {
4959 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4960 return
4961 }
4962 }
4963 set descendent($a) 0
4964 set desc_todo $leftover
4965}
4966
4967proc is_ancestor {a} {
4968 global curview parents ancestor anc_todo
4969
4970 set v $curview
4971 set la [rowofcommit $a]
4972 set todo $anc_todo
4973 set leftover {}
4974 set done 0
4975 for {set i 0} {$i < [llength $todo]} {incr i} {
4976 set do [lindex $todo $i]
4977 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4978 lappend leftover $do
4979 continue
4980 }
4981 foreach np $parents($v,$do) {
4982 if {![info exists ancestor($np)]} {
4983 set ancestor($np) 1
4984 lappend todo $np
4985 if {$np eq $a} {
4986 set done 1
4987 }
4988 }
4989 }
4990 if {$done} {
4991 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4992 return
4993 }
4994 }
4995 set ancestor($a) 0
4996 set anc_todo $leftover
4997}
4998
4999proc askrelhighlight {row id} {
5000 global descendent highlight_related iddrawn rhighlights
5001 global selectedline ancestor
5002
5003 if {$selectedline eq {}} return
5004 set isbold 0
5005 if {$highlight_related eq [mc "Descendant"] ||
5006 $highlight_related eq [mc "Not descendant"]} {
5007 if {![info exists descendent($id)]} {
5008 is_descendent $id
5009 }
5010 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5011 set isbold 1
5012 }
5013 } elseif {$highlight_related eq [mc "Ancestor"] ||
5014 $highlight_related eq [mc "Not ancestor"]} {
5015 if {![info exists ancestor($id)]} {
5016 is_ancestor $id
5017 }
5018 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5019 set isbold 1
5020 }
5021 }
5022 if {[info exists iddrawn($id)]} {
5023 if {$isbold && ![ishighlighted $id]} {
5024 bolden $id mainfontbold
5025 }
5026 }
5027 set rhighlights($id) $isbold
5028}
5029
5030# Graph layout functions
5031
5032proc shortids {ids} {
5033 set res {}
5034 foreach id $ids {
5035 if {[llength $id] > 1} {
5036 lappend res [shortids $id]
5037 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5038 lappend res [string range $id 0 7]
5039 } else {
5040 lappend res $id
5041 }
5042 }
5043 return $res
5044}
5045
5046proc ntimes {n o} {
5047 set ret {}
5048 set o [list $o]
5049 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5050 if {($n & $mask) != 0} {
5051 set ret [concat $ret $o]
5052 }
5053 set o [concat $o $o]
5054 }
5055 return $ret
5056}
5057
5058proc ordertoken {id} {
5059 global ordertok curview varcid varcstart varctok curview parents children
5060 global nullid nullid2
5061
5062 if {[info exists ordertok($id)]} {
5063 return $ordertok($id)
5064 }
5065 set origid $id
5066 set todo {}
5067 while {1} {
5068 if {[info exists varcid($curview,$id)]} {
5069 set a $varcid($curview,$id)
5070 set p [lindex $varcstart($curview) $a]
5071 } else {
5072 set p [lindex $children($curview,$id) 0]
5073 }
5074 if {[info exists ordertok($p)]} {
5075 set tok $ordertok($p)
5076 break
5077 }
5078 set id [first_real_child $curview,$p]
5079 if {$id eq {}} {
5080 # it's a root
5081 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5082 break
5083 }
5084 if {[llength $parents($curview,$id)] == 1} {
5085 lappend todo [list $p {}]
5086 } else {
5087 set j [lsearch -exact $parents($curview,$id) $p]
5088 if {$j < 0} {
5089 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5090 }
5091 lappend todo [list $p [strrep $j]]
5092 }
5093 }
5094 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5095 set p [lindex $todo $i 0]
5096 append tok [lindex $todo $i 1]
5097 set ordertok($p) $tok
5098 }
5099 set ordertok($origid) $tok
5100 return $tok
5101}
5102
5103# Work out where id should go in idlist so that order-token
5104# values increase from left to right
5105proc idcol {idlist id {i 0}} {
5106 set t [ordertoken $id]
5107 if {$i < 0} {
5108 set i 0
5109 }
5110 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5111 if {$i > [llength $idlist]} {
5112 set i [llength $idlist]
5113 }
5114 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5115 incr i
5116 } else {
5117 if {$t > [ordertoken [lindex $idlist $i]]} {
5118 while {[incr i] < [llength $idlist] &&
5119 $t >= [ordertoken [lindex $idlist $i]]} {}
5120 }
5121 }
5122 return $i
5123}
5124
5125proc initlayout {} {
5126 global rowidlist rowisopt rowfinal displayorder parentlist
5127 global numcommits canvxmax canv
5128 global nextcolor
5129 global colormap rowtextx
5130
5131 set numcommits 0
5132 set displayorder {}
5133 set parentlist {}
5134 set nextcolor 0
5135 set rowidlist {}
5136 set rowisopt {}
5137 set rowfinal {}
5138 set canvxmax [$canv cget -width]
5139 unset -nocomplain colormap
5140 unset -nocomplain rowtextx
5141 setcanvscroll
5142}
5143
5144proc setcanvscroll {} {
5145 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5146 global lastscrollset lastscrollrows
5147
5148 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5149 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5150 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5151 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5152 set lastscrollset [clock clicks -milliseconds]
5153 set lastscrollrows $numcommits
5154}
5155
5156proc visiblerows {} {
5157 global canv numcommits linespc
5158
5159 set ymax [lindex [$canv cget -scrollregion] 3]
5160 if {$ymax eq {} || $ymax == 0} return
5161 set f [$canv yview]
5162 set y0 [expr {int([lindex $f 0] * $ymax)}]
5163 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5164 if {$r0 < 0} {
5165 set r0 0
5166 }
5167 set y1 [expr {int([lindex $f 1] * $ymax)}]
5168 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5169 if {$r1 >= $numcommits} {
5170 set r1 [expr {$numcommits - 1}]
5171 }
5172 return [list $r0 $r1]
5173}
5174
5175proc layoutmore {} {
5176 global commitidx viewcomplete curview
5177 global numcommits pending_select curview
5178 global lastscrollset lastscrollrows
5179
5180 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5181 [clock clicks -milliseconds] - $lastscrollset > 500} {
5182 setcanvscroll
5183 }
5184 if {[info exists pending_select] &&
5185 [commitinview $pending_select $curview]} {
5186 update
5187 selectline [rowofcommit $pending_select] 1
5188 }
5189 drawvisible
5190}
5191
5192# With path limiting, we mightn't get the actual HEAD commit,
5193# so ask git rev-list what is the first ancestor of HEAD that
5194# touches a file in the path limit.
5195proc get_viewmainhead {view} {
5196 global viewmainheadid vfilelimit viewinstances mainheadid
5197
5198 catch {
5199 set rfd [open [concat | git rev-list -1 $mainheadid \
5200 -- $vfilelimit($view)] r]
5201 set j [reg_instance $rfd]
5202 lappend viewinstances($view) $j
5203 fconfigure $rfd -blocking 0
5204 filerun $rfd [list getviewhead $rfd $j $view]
5205 set viewmainheadid($curview) {}
5206 }
5207}
5208
5209# git rev-list should give us just 1 line to use as viewmainheadid($view)
5210proc getviewhead {fd inst view} {
5211 global viewmainheadid commfd curview viewinstances showlocalchanges
5212
5213 set id {}
5214 if {[gets $fd line] < 0} {
5215 if {![eof $fd]} {
5216 return 1
5217 }
5218 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5219 set id $line
5220 }
5221 set viewmainheadid($view) $id
5222 close $fd
5223 unset commfd($inst)
5224 set i [lsearch -exact $viewinstances($view) $inst]
5225 if {$i >= 0} {
5226 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5227 }
5228 if {$showlocalchanges && $id ne {} && $view == $curview} {
5229 doshowlocalchanges
5230 }
5231 return 0
5232}
5233
5234proc doshowlocalchanges {} {
5235 global curview viewmainheadid
5236
5237 if {$viewmainheadid($curview) eq {}} return
5238 if {[commitinview $viewmainheadid($curview) $curview]} {
5239 dodiffindex
5240 } else {
5241 interestedin $viewmainheadid($curview) dodiffindex
5242 }
5243}
5244
5245proc dohidelocalchanges {} {
5246 global nullid nullid2 lserial curview
5247
5248 if {[commitinview $nullid $curview]} {
5249 removefakerow $nullid
5250 }
5251 if {[commitinview $nullid2 $curview]} {
5252 removefakerow $nullid2
5253 }
5254 incr lserial
5255}
5256
5257# spawn off a process to do git diff-index --cached HEAD
5258proc dodiffindex {} {
5259 global lserial showlocalchanges vfilelimit curview
5260 global hasworktree git_version
5261
5262 if {!$showlocalchanges || !$hasworktree} return
5263 incr lserial
5264 if {[package vcompare $git_version "1.7.2"] >= 0} {
5265 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5266 } else {
5267 set cmd "|git diff-index --cached HEAD"
5268 }
5269 if {$vfilelimit($curview) ne {}} {
5270 set cmd [concat $cmd -- $vfilelimit($curview)]
5271 }
5272 set fd [open $cmd r]
5273 fconfigure $fd -blocking 0
5274 set i [reg_instance $fd]
5275 filerun $fd [list readdiffindex $fd $lserial $i]
5276}
5277
5278proc readdiffindex {fd serial inst} {
5279 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5280 global vfilelimit
5281
5282 set isdiff 1
5283 if {[gets $fd line] < 0} {
5284 if {![eof $fd]} {
5285 return 1
5286 }
5287 set isdiff 0
5288 }
5289 # we only need to see one line and we don't really care what it says...
5290 stop_instance $inst
5291
5292 if {$serial != $lserial} {
5293 return 0
5294 }
5295
5296 # now see if there are any local changes not checked in to the index
5297 set cmd "|git diff-files"
5298 if {$vfilelimit($curview) ne {}} {
5299 set cmd [concat $cmd -- $vfilelimit($curview)]
5300 }
5301 set fd [open $cmd r]
5302 fconfigure $fd -blocking 0
5303 set i [reg_instance $fd]
5304 filerun $fd [list readdifffiles $fd $serial $i]
5305
5306 if {$isdiff && ![commitinview $nullid2 $curview]} {
5307 # add the line for the changes in the index to the graph
5308 set hl [mc "Local changes checked in to index but not committed"]
5309 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5310 set commitdata($nullid2) "\n $hl\n"
5311 if {[commitinview $nullid $curview]} {
5312 removefakerow $nullid
5313 }
5314 insertfakerow $nullid2 $viewmainheadid($curview)
5315 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5316 if {[commitinview $nullid $curview]} {
5317 removefakerow $nullid
5318 }
5319 removefakerow $nullid2
5320 }
5321 return 0
5322}
5323
5324proc readdifffiles {fd serial inst} {
5325 global viewmainheadid nullid nullid2 curview
5326 global commitinfo commitdata lserial
5327
5328 set isdiff 1
5329 if {[gets $fd line] < 0} {
5330 if {![eof $fd]} {
5331 return 1
5332 }
5333 set isdiff 0
5334 }
5335 # we only need to see one line and we don't really care what it says...
5336 stop_instance $inst
5337
5338 if {$serial != $lserial} {
5339 return 0
5340 }
5341
5342 if {$isdiff && ![commitinview $nullid $curview]} {
5343 # add the line for the local diff to the graph
5344 set hl [mc "Local uncommitted changes, not checked in to index"]
5345 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5346 set commitdata($nullid) "\n $hl\n"
5347 if {[commitinview $nullid2 $curview]} {
5348 set p $nullid2
5349 } else {
5350 set p $viewmainheadid($curview)
5351 }
5352 insertfakerow $nullid $p
5353 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5354 removefakerow $nullid
5355 }
5356 return 0
5357}
5358
5359proc nextuse {id row} {
5360 global curview children
5361
5362 if {[info exists children($curview,$id)]} {
5363 foreach kid $children($curview,$id) {
5364 if {![commitinview $kid $curview]} {
5365 return -1
5366 }
5367 if {[rowofcommit $kid] > $row} {
5368 return [rowofcommit $kid]
5369 }
5370 }
5371 }
5372 if {[commitinview $id $curview]} {
5373 return [rowofcommit $id]
5374 }
5375 return -1
5376}
5377
5378proc prevuse {id row} {
5379 global curview children
5380
5381 set ret -1
5382 if {[info exists children($curview,$id)]} {
5383 foreach kid $children($curview,$id) {
5384 if {![commitinview $kid $curview]} break
5385 if {[rowofcommit $kid] < $row} {
5386 set ret [rowofcommit $kid]
5387 }
5388 }
5389 }
5390 return $ret
5391}
5392
5393proc make_idlist {row} {
5394 global displayorder parentlist uparrowlen downarrowlen mingaplen
5395 global commitidx curview children
5396
5397 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5398 if {$r < 0} {
5399 set r 0
5400 }
5401 set ra [expr {$row - $downarrowlen}]
5402 if {$ra < 0} {
5403 set ra 0
5404 }
5405 set rb [expr {$row + $uparrowlen}]
5406 if {$rb > $commitidx($curview)} {
5407 set rb $commitidx($curview)
5408 }
5409 make_disporder $r [expr {$rb + 1}]
5410 set ids {}
5411 for {} {$r < $ra} {incr r} {
5412 set nextid [lindex $displayorder [expr {$r + 1}]]
5413 foreach p [lindex $parentlist $r] {
5414 if {$p eq $nextid} continue
5415 set rn [nextuse $p $r]
5416 if {$rn >= $row &&
5417 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5418 lappend ids [list [ordertoken $p] $p]
5419 }
5420 }
5421 }
5422 for {} {$r < $row} {incr r} {
5423 set nextid [lindex $displayorder [expr {$r + 1}]]
5424 foreach p [lindex $parentlist $r] {
5425 if {$p eq $nextid} continue
5426 set rn [nextuse $p $r]
5427 if {$rn < 0 || $rn >= $row} {
5428 lappend ids [list [ordertoken $p] $p]
5429 }
5430 }
5431 }
5432 set id [lindex $displayorder $row]
5433 lappend ids [list [ordertoken $id] $id]
5434 while {$r < $rb} {
5435 foreach p [lindex $parentlist $r] {
5436 set firstkid [lindex $children($curview,$p) 0]
5437 if {[rowofcommit $firstkid] < $row} {
5438 lappend ids [list [ordertoken $p] $p]
5439 }
5440 }
5441 incr r
5442 set id [lindex $displayorder $r]
5443 if {$id ne {}} {
5444 set firstkid [lindex $children($curview,$id) 0]
5445 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5446 lappend ids [list [ordertoken $id] $id]
5447 }
5448 }
5449 }
5450 set idlist {}
5451 foreach idx [lsort -unique $ids] {
5452 lappend idlist [lindex $idx 1]
5453 }
5454 return $idlist
5455}
5456
5457proc rowsequal {a b} {
5458 while {[set i [lsearch -exact $a {}]] >= 0} {
5459 set a [lreplace $a $i $i]
5460 }
5461 while {[set i [lsearch -exact $b {}]] >= 0} {
5462 set b [lreplace $b $i $i]
5463 }
5464 return [expr {$a eq $b}]
5465}
5466
5467proc makeupline {id row rend col} {
5468 global rowidlist uparrowlen downarrowlen mingaplen
5469
5470 for {set r $rend} {1} {set r $rstart} {
5471 set rstart [prevuse $id $r]
5472 if {$rstart < 0} return
5473 if {$rstart < $row} break
5474 }
5475 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5476 set rstart [expr {$rend - $uparrowlen - 1}]
5477 }
5478 for {set r $rstart} {[incr r] <= $row} {} {
5479 set idlist [lindex $rowidlist $r]
5480 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5481 set col [idcol $idlist $id $col]
5482 lset rowidlist $r [linsert $idlist $col $id]
5483 changedrow $r
5484 }
5485 }
5486}
5487
5488proc layoutrows {row endrow} {
5489 global rowidlist rowisopt rowfinal displayorder
5490 global uparrowlen downarrowlen maxwidth mingaplen
5491 global children parentlist
5492 global commitidx viewcomplete curview
5493
5494 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5495 set idlist {}
5496 if {$row > 0} {
5497 set rm1 [expr {$row - 1}]
5498 foreach id [lindex $rowidlist $rm1] {
5499 if {$id ne {}} {
5500 lappend idlist $id
5501 }
5502 }
5503 set final [lindex $rowfinal $rm1]
5504 }
5505 for {} {$row < $endrow} {incr row} {
5506 set rm1 [expr {$row - 1}]
5507 if {$rm1 < 0 || $idlist eq {}} {
5508 set idlist [make_idlist $row]
5509 set final 1
5510 } else {
5511 set id [lindex $displayorder $rm1]
5512 set col [lsearch -exact $idlist $id]
5513 set idlist [lreplace $idlist $col $col]
5514 foreach p [lindex $parentlist $rm1] {
5515 if {[lsearch -exact $idlist $p] < 0} {
5516 set col [idcol $idlist $p $col]
5517 set idlist [linsert $idlist $col $p]
5518 # if not the first child, we have to insert a line going up
5519 if {$id ne [lindex $children($curview,$p) 0]} {
5520 makeupline $p $rm1 $row $col
5521 }
5522 }
5523 }
5524 set id [lindex $displayorder $row]
5525 if {$row > $downarrowlen} {
5526 set termrow [expr {$row - $downarrowlen - 1}]
5527 foreach p [lindex $parentlist $termrow] {
5528 set i [lsearch -exact $idlist $p]
5529 if {$i < 0} continue
5530 set nr [nextuse $p $termrow]
5531 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5532 set idlist [lreplace $idlist $i $i]
5533 }
5534 }
5535 }
5536 set col [lsearch -exact $idlist $id]
5537 if {$col < 0} {
5538 set col [idcol $idlist $id]
5539 set idlist [linsert $idlist $col $id]
5540 if {$children($curview,$id) ne {}} {
5541 makeupline $id $rm1 $row $col
5542 }
5543 }
5544 set r [expr {$row + $uparrowlen - 1}]
5545 if {$r < $commitidx($curview)} {
5546 set x $col
5547 foreach p [lindex $parentlist $r] {
5548 if {[lsearch -exact $idlist $p] >= 0} continue
5549 set fk [lindex $children($curview,$p) 0]
5550 if {[rowofcommit $fk] < $row} {
5551 set x [idcol $idlist $p $x]
5552 set idlist [linsert $idlist $x $p]
5553 }
5554 }
5555 if {[incr r] < $commitidx($curview)} {
5556 set p [lindex $displayorder $r]
5557 if {[lsearch -exact $idlist $p] < 0} {
5558 set fk [lindex $children($curview,$p) 0]
5559 if {$fk ne {} && [rowofcommit $fk] < $row} {
5560 set x [idcol $idlist $p $x]
5561 set idlist [linsert $idlist $x $p]
5562 }
5563 }
5564 }
5565 }
5566 }
5567 if {$final && !$viewcomplete($curview) &&
5568 $row + $uparrowlen + $mingaplen + $downarrowlen
5569 >= $commitidx($curview)} {
5570 set final 0
5571 }
5572 set l [llength $rowidlist]
5573 if {$row == $l} {
5574 lappend rowidlist $idlist
5575 lappend rowisopt 0
5576 lappend rowfinal $final
5577 } elseif {$row < $l} {
5578 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5579 lset rowidlist $row $idlist
5580 changedrow $row
5581 }
5582 lset rowfinal $row $final
5583 } else {
5584 set pad [ntimes [expr {$row - $l}] {}]
5585 set rowidlist [concat $rowidlist $pad]
5586 lappend rowidlist $idlist
5587 set rowfinal [concat $rowfinal $pad]
5588 lappend rowfinal $final
5589 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5590 }
5591 }
5592 return $row
5593}
5594
5595proc changedrow {row} {
5596 global displayorder iddrawn rowisopt need_redisplay
5597
5598 set l [llength $rowisopt]
5599 if {$row < $l} {
5600 lset rowisopt $row 0
5601 if {$row + 1 < $l} {
5602 lset rowisopt [expr {$row + 1}] 0
5603 if {$row + 2 < $l} {
5604 lset rowisopt [expr {$row + 2}] 0
5605 }
5606 }
5607 }
5608 set id [lindex $displayorder $row]
5609 if {[info exists iddrawn($id)]} {
5610 set need_redisplay 1
5611 }
5612}
5613
5614proc insert_pad {row col npad} {
5615 global rowidlist
5616
5617 set pad [ntimes $npad {}]
5618 set idlist [lindex $rowidlist $row]
5619 set bef [lrange $idlist 0 [expr {$col - 1}]]
5620 set aft [lrange $idlist $col end]
5621 set i [lsearch -exact $aft {}]
5622 if {$i > 0} {
5623 set aft [lreplace $aft $i $i]
5624 }
5625 lset rowidlist $row [concat $bef $pad $aft]
5626 changedrow $row
5627}
5628
5629proc optimize_rows {row col endrow} {
5630 global rowidlist rowisopt displayorder curview children
5631
5632 if {$row < 1} {
5633 set row 1
5634 }
5635 for {} {$row < $endrow} {incr row; set col 0} {
5636 if {[lindex $rowisopt $row]} continue
5637 set haspad 0
5638 set y0 [expr {$row - 1}]
5639 set ym [expr {$row - 2}]
5640 set idlist [lindex $rowidlist $row]
5641 set previdlist [lindex $rowidlist $y0]
5642 if {$idlist eq {} || $previdlist eq {}} continue
5643 if {$ym >= 0} {
5644 set pprevidlist [lindex $rowidlist $ym]
5645 if {$pprevidlist eq {}} continue
5646 } else {
5647 set pprevidlist {}
5648 }
5649 set x0 -1
5650 set xm -1
5651 for {} {$col < [llength $idlist]} {incr col} {
5652 set id [lindex $idlist $col]
5653 if {[lindex $previdlist $col] eq $id} continue
5654 if {$id eq {}} {
5655 set haspad 1
5656 continue
5657 }
5658 set x0 [lsearch -exact $previdlist $id]
5659 if {$x0 < 0} continue
5660 set z [expr {$x0 - $col}]
5661 set isarrow 0
5662 set z0 {}
5663 if {$ym >= 0} {
5664 set xm [lsearch -exact $pprevidlist $id]
5665 if {$xm >= 0} {
5666 set z0 [expr {$xm - $x0}]
5667 }
5668 }
5669 if {$z0 eq {}} {
5670 # if row y0 is the first child of $id then it's not an arrow
5671 if {[lindex $children($curview,$id) 0] ne
5672 [lindex $displayorder $y0]} {
5673 set isarrow 1
5674 }
5675 }
5676 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5677 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5678 set isarrow 1
5679 }
5680 # Looking at lines from this row to the previous row,
5681 # make them go straight up if they end in an arrow on
5682 # the previous row; otherwise make them go straight up
5683 # or at 45 degrees.
5684 if {$z < -1 || ($z < 0 && $isarrow)} {
5685 # Line currently goes left too much;
5686 # insert pads in the previous row, then optimize it
5687 set npad [expr {-1 - $z + $isarrow}]
5688 insert_pad $y0 $x0 $npad
5689 if {$y0 > 0} {
5690 optimize_rows $y0 $x0 $row
5691 }
5692 set previdlist [lindex $rowidlist $y0]
5693 set x0 [lsearch -exact $previdlist $id]
5694 set z [expr {$x0 - $col}]
5695 if {$z0 ne {}} {
5696 set pprevidlist [lindex $rowidlist $ym]
5697 set xm [lsearch -exact $pprevidlist $id]
5698 set z0 [expr {$xm - $x0}]
5699 }
5700 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5701 # Line currently goes right too much;
5702 # insert pads in this line
5703 set npad [expr {$z - 1 + $isarrow}]
5704 insert_pad $row $col $npad
5705 set idlist [lindex $rowidlist $row]
5706 incr col $npad
5707 set z [expr {$x0 - $col}]
5708 set haspad 1
5709 }
5710 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5711 # this line links to its first child on row $row-2
5712 set id [lindex $displayorder $ym]
5713 set xc [lsearch -exact $pprevidlist $id]
5714 if {$xc >= 0} {
5715 set z0 [expr {$xc - $x0}]
5716 }
5717 }
5718 # avoid lines jigging left then immediately right
5719 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5720 insert_pad $y0 $x0 1
5721 incr x0
5722 optimize_rows $y0 $x0 $row
5723 set previdlist [lindex $rowidlist $y0]
5724 }
5725 }
5726 if {!$haspad} {
5727 # Find the first column that doesn't have a line going right
5728 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5729 set id [lindex $idlist $col]
5730 if {$id eq {}} break
5731 set x0 [lsearch -exact $previdlist $id]
5732 if {$x0 < 0} {
5733 # check if this is the link to the first child
5734 set kid [lindex $displayorder $y0]
5735 if {[lindex $children($curview,$id) 0] eq $kid} {
5736 # it is, work out offset to child
5737 set x0 [lsearch -exact $previdlist $kid]
5738 }
5739 }
5740 if {$x0 <= $col} break
5741 }
5742 # Insert a pad at that column as long as it has a line and
5743 # isn't the last column
5744 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5745 set idlist [linsert $idlist $col {}]
5746 lset rowidlist $row $idlist
5747 changedrow $row
5748 }
5749 }
5750 }
5751}
5752
5753proc xc {row col} {
5754 global canvx0 linespc
5755 return [expr {$canvx0 + $col * $linespc}]
5756}
5757
5758proc yc {row} {
5759 global canvy0 linespc
5760 return [expr {$canvy0 + $row * $linespc}]
5761}
5762
5763proc linewidth {id} {
5764 global thickerline lthickness
5765
5766 set wid $lthickness
5767 if {[info exists thickerline] && $id eq $thickerline} {
5768 set wid [expr {2 * $lthickness}]
5769 }
5770 return $wid
5771}
5772
5773proc rowranges {id} {
5774 global curview children uparrowlen downarrowlen
5775 global rowidlist
5776
5777 set kids $children($curview,$id)
5778 if {$kids eq {}} {
5779 return {}
5780 }
5781 set ret {}
5782 lappend kids $id
5783 foreach child $kids {
5784 if {![commitinview $child $curview]} break
5785 set row [rowofcommit $child]
5786 if {![info exists prev]} {
5787 lappend ret [expr {$row + 1}]
5788 } else {
5789 if {$row <= $prevrow} {
5790 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5791 }
5792 # see if the line extends the whole way from prevrow to row
5793 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5794 [lsearch -exact [lindex $rowidlist \
5795 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5796 # it doesn't, see where it ends
5797 set r [expr {$prevrow + $downarrowlen}]
5798 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5799 while {[incr r -1] > $prevrow &&
5800 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5801 } else {
5802 while {[incr r] <= $row &&
5803 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5804 incr r -1
5805 }
5806 lappend ret $r
5807 # see where it starts up again
5808 set r [expr {$row - $uparrowlen}]
5809 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5810 while {[incr r] < $row &&
5811 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5812 } else {
5813 while {[incr r -1] >= $prevrow &&
5814 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5815 incr r
5816 }
5817 lappend ret $r
5818 }
5819 }
5820 if {$child eq $id} {
5821 lappend ret $row
5822 }
5823 set prev $child
5824 set prevrow $row
5825 }
5826 return $ret
5827}
5828
5829proc drawlineseg {id row endrow arrowlow} {
5830 global rowidlist displayorder iddrawn linesegs
5831 global canv colormap linespc curview maxlinelen parentlist
5832
5833 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5834 set le [expr {$row + 1}]
5835 set arrowhigh 1
5836 while {1} {
5837 set c [lsearch -exact [lindex $rowidlist $le] $id]
5838 if {$c < 0} {
5839 incr le -1
5840 break
5841 }
5842 lappend cols $c
5843 set x [lindex $displayorder $le]
5844 if {$x eq $id} {
5845 set arrowhigh 0
5846 break
5847 }
5848 if {[info exists iddrawn($x)] || $le == $endrow} {
5849 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5850 if {$c >= 0} {
5851 lappend cols $c
5852 set arrowhigh 0
5853 }
5854 break
5855 }
5856 incr le
5857 }
5858 if {$le <= $row} {
5859 return $row
5860 }
5861
5862 set lines {}
5863 set i 0
5864 set joinhigh 0
5865 if {[info exists linesegs($id)]} {
5866 set lines $linesegs($id)
5867 foreach li $lines {
5868 set r0 [lindex $li 0]
5869 if {$r0 > $row} {
5870 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5871 set joinhigh 1
5872 }
5873 break
5874 }
5875 incr i
5876 }
5877 }
5878 set joinlow 0
5879 if {$i > 0} {
5880 set li [lindex $lines [expr {$i-1}]]
5881 set r1 [lindex $li 1]
5882 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5883 set joinlow 1
5884 }
5885 }
5886
5887 set x [lindex $cols [expr {$le - $row}]]
5888 set xp [lindex $cols [expr {$le - 1 - $row}]]
5889 set dir [expr {$xp - $x}]
5890 if {$joinhigh} {
5891 set ith [lindex $lines $i 2]
5892 set coords [$canv coords $ith]
5893 set ah [$canv itemcget $ith -arrow]
5894 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5895 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5896 if {$x2 ne {} && $x - $x2 == $dir} {
5897 set coords [lrange $coords 0 end-2]
5898 }
5899 } else {
5900 set coords [list [xc $le $x] [yc $le]]
5901 }
5902 if {$joinlow} {
5903 set itl [lindex $lines [expr {$i-1}] 2]
5904 set al [$canv itemcget $itl -arrow]
5905 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5906 } elseif {$arrowlow} {
5907 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5908 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5909 set arrowlow 0
5910 }
5911 }
5912 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5913 for {set y $le} {[incr y -1] > $row} {} {
5914 set x $xp
5915 set xp [lindex $cols [expr {$y - 1 - $row}]]
5916 set ndir [expr {$xp - $x}]
5917 if {$dir != $ndir || $xp < 0} {
5918 lappend coords [xc $y $x] [yc $y]
5919 }
5920 set dir $ndir
5921 }
5922 if {!$joinlow} {
5923 if {$xp < 0} {
5924 # join parent line to first child
5925 set ch [lindex $displayorder $row]
5926 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5927 if {$xc < 0} {
5928 puts "oops: drawlineseg: child $ch not on row $row"
5929 } elseif {$xc != $x} {
5930 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5931 set d [expr {int(0.5 * $linespc)}]
5932 set x1 [xc $row $x]
5933 if {$xc < $x} {
5934 set x2 [expr {$x1 - $d}]
5935 } else {
5936 set x2 [expr {$x1 + $d}]
5937 }
5938 set y2 [yc $row]
5939 set y1 [expr {$y2 + $d}]
5940 lappend coords $x1 $y1 $x2 $y2
5941 } elseif {$xc < $x - 1} {
5942 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5943 } elseif {$xc > $x + 1} {
5944 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5945 }
5946 set x $xc
5947 }
5948 lappend coords [xc $row $x] [yc $row]
5949 } else {
5950 set xn [xc $row $xp]
5951 set yn [yc $row]
5952 lappend coords $xn $yn
5953 }
5954 if {!$joinhigh} {
5955 assigncolor $id
5956 set t [$canv create line $coords -width [linewidth $id] \
5957 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5958 $canv lower $t
5959 bindline $t $id
5960 set lines [linsert $lines $i [list $row $le $t]]
5961 } else {
5962 $canv coords $ith $coords
5963 if {$arrow ne $ah} {
5964 $canv itemconf $ith -arrow $arrow
5965 }
5966 lset lines $i 0 $row
5967 }
5968 } else {
5969 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5970 set ndir [expr {$xo - $xp}]
5971 set clow [$canv coords $itl]
5972 if {$dir == $ndir} {
5973 set clow [lrange $clow 2 end]
5974 }
5975 set coords [concat $coords $clow]
5976 if {!$joinhigh} {
5977 lset lines [expr {$i-1}] 1 $le
5978 } else {
5979 # coalesce two pieces
5980 $canv delete $ith
5981 set b [lindex $lines [expr {$i-1}] 0]
5982 set e [lindex $lines $i 1]
5983 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5984 }
5985 $canv coords $itl $coords
5986 if {$arrow ne $al} {
5987 $canv itemconf $itl -arrow $arrow
5988 }
5989 }
5990
5991 set linesegs($id) $lines
5992 return $le
5993}
5994
5995proc drawparentlinks {id row} {
5996 global rowidlist canv colormap curview parentlist
5997 global idpos linespc
5998
5999 set rowids [lindex $rowidlist $row]
6000 set col [lsearch -exact $rowids $id]
6001 if {$col < 0} return
6002 set olds [lindex $parentlist $row]
6003 set row2 [expr {$row + 1}]
6004 set x [xc $row $col]
6005 set y [yc $row]
6006 set y2 [yc $row2]
6007 set d [expr {int(0.5 * $linespc)}]
6008 set ymid [expr {$y + $d}]
6009 set ids [lindex $rowidlist $row2]
6010 # rmx = right-most X coord used
6011 set rmx 0
6012 foreach p $olds {
6013 set i [lsearch -exact $ids $p]
6014 if {$i < 0} {
6015 puts "oops, parent $p of $id not in list"
6016 continue
6017 }
6018 set x2 [xc $row2 $i]
6019 if {$x2 > $rmx} {
6020 set rmx $x2
6021 }
6022 set j [lsearch -exact $rowids $p]
6023 if {$j < 0} {
6024 # drawlineseg will do this one for us
6025 continue
6026 }
6027 assigncolor $p
6028 # should handle duplicated parents here...
6029 set coords [list $x $y]
6030 if {$i != $col} {
6031 # if attaching to a vertical segment, draw a smaller
6032 # slant for visual distinctness
6033 if {$i == $j} {
6034 if {$i < $col} {
6035 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6036 } else {
6037 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6038 }
6039 } elseif {$i < $col && $i < $j} {
6040 # segment slants towards us already
6041 lappend coords [xc $row $j] $y
6042 } else {
6043 if {$i < $col - 1} {
6044 lappend coords [expr {$x2 + $linespc}] $y
6045 } elseif {$i > $col + 1} {
6046 lappend coords [expr {$x2 - $linespc}] $y
6047 }
6048 lappend coords $x2 $y2
6049 }
6050 } else {
6051 lappend coords $x2 $y2
6052 }
6053 set t [$canv create line $coords -width [linewidth $p] \
6054 -fill $colormap($p) -tags lines.$p]
6055 $canv lower $t
6056 bindline $t $p
6057 }
6058 if {$rmx > [lindex $idpos($id) 1]} {
6059 lset idpos($id) 1 $rmx
6060 redrawtags $id
6061 }
6062}
6063
6064proc drawlines {id} {
6065 global canv
6066
6067 $canv itemconf lines.$id -width [linewidth $id]
6068}
6069
6070proc drawcmittext {id row col} {
6071 global linespc canv canv2 canv3 fgcolor curview
6072 global cmitlisted commitinfo rowidlist parentlist
6073 global rowtextx idpos idtags idheads idotherrefs
6074 global linehtag linentag linedtag selectedline
6075 global canvxmax boldids boldnameids fgcolor markedid
6076 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6077 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6078 global circleoutlinecolor
6079
6080 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6081 set listed $cmitlisted($curview,$id)
6082 if {$id eq $nullid} {
6083 set ofill $workingfilescirclecolor
6084 } elseif {$id eq $nullid2} {
6085 set ofill $indexcirclecolor
6086 } elseif {$id eq $mainheadid} {
6087 set ofill $mainheadcirclecolor
6088 } else {
6089 set ofill [lindex $circlecolors $listed]
6090 }
6091 set x [xc $row $col]
6092 set y [yc $row]
6093 set orad [expr {$linespc / 3}]
6094 if {$listed <= 2} {
6095 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6096 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6097 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6098 } elseif {$listed == 3} {
6099 # triangle pointing left for left-side commits
6100 set t [$canv create polygon \
6101 [expr {$x - $orad}] $y \
6102 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6103 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6104 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6105 } else {
6106 # triangle pointing right for right-side commits
6107 set t [$canv create polygon \
6108 [expr {$x + $orad - 1}] $y \
6109 [expr {$x - $orad}] [expr {$y - $orad}] \
6110 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6111 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6112 }
6113 set circleitem($row) $t
6114 $canv raise $t
6115 $canv bind $t <1> {selcanvline {} %x %y}
6116 set rmx [llength [lindex $rowidlist $row]]
6117 set olds [lindex $parentlist $row]
6118 if {$olds ne {}} {
6119 set nextids [lindex $rowidlist [expr {$row + 1}]]
6120 foreach p $olds {
6121 set i [lsearch -exact $nextids $p]
6122 if {$i > $rmx} {
6123 set rmx $i
6124 }
6125 }
6126 }
6127 set xt [xc $row $rmx]
6128 set rowtextx($row) $xt
6129 set idpos($id) [list $x $xt $y]
6130 if {[info exists idtags($id)] || [info exists idheads($id)]
6131 || [info exists idotherrefs($id)]} {
6132 set xt [drawtags $id $x $xt $y]
6133 }
6134 if {[lindex $commitinfo($id) 6] > 0} {
6135 set xt [drawnotesign $xt $y]
6136 }
6137 set headline [lindex $commitinfo($id) 0]
6138 set name [lindex $commitinfo($id) 1]
6139 set date [lindex $commitinfo($id) 2]
6140 set date [formatdate $date]
6141 set font mainfont
6142 set nfont mainfont
6143 set isbold [ishighlighted $id]
6144 if {$isbold > 0} {
6145 lappend boldids $id
6146 set font mainfontbold
6147 if {$isbold > 1} {
6148 lappend boldnameids $id
6149 set nfont mainfontbold
6150 }
6151 }
6152 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6153 -text $headline -font $font -tags text]
6154 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6155 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6156 -text $name -font $nfont -tags text]
6157 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6158 -text $date -font mainfont -tags text]
6159 if {$selectedline == $row} {
6160 make_secsel $id
6161 }
6162 if {[info exists markedid] && $markedid eq $id} {
6163 make_idmark $id
6164 }
6165 set xr [expr {$xt + [font measure $font $headline]}]
6166 if {$xr > $canvxmax} {
6167 set canvxmax $xr
6168 setcanvscroll
6169 }
6170}
6171
6172proc drawcmitrow {row} {
6173 global displayorder rowidlist nrows_drawn
6174 global iddrawn markingmatches
6175 global commitinfo numcommits
6176 global filehighlight fhighlights findpattern nhighlights
6177 global hlview vhighlights
6178 global highlight_related rhighlights
6179
6180 if {$row >= $numcommits} return
6181
6182 set id [lindex $displayorder $row]
6183 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6184 askvhighlight $row $id
6185 }
6186 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6187 askfilehighlight $row $id
6188 }
6189 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6190 askfindhighlight $row $id
6191 }
6192 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6193 askrelhighlight $row $id
6194 }
6195 if {![info exists iddrawn($id)]} {
6196 set col [lsearch -exact [lindex $rowidlist $row] $id]
6197 if {$col < 0} {
6198 puts "oops, row $row id $id not in list"
6199 return
6200 }
6201 if {![info exists commitinfo($id)]} {
6202 getcommit $id
6203 }
6204 assigncolor $id
6205 drawcmittext $id $row $col
6206 set iddrawn($id) 1
6207 incr nrows_drawn
6208 }
6209 if {$markingmatches} {
6210 markrowmatches $row $id
6211 }
6212}
6213
6214proc drawcommits {row {endrow {}}} {
6215 global numcommits iddrawn displayorder curview need_redisplay
6216 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6217
6218 if {$row < 0} {
6219 set row 0
6220 }
6221 if {$endrow eq {}} {
6222 set endrow $row
6223 }
6224 if {$endrow >= $numcommits} {
6225 set endrow [expr {$numcommits - 1}]
6226 }
6227
6228 set rl1 [expr {$row - $downarrowlen - 3}]
6229 if {$rl1 < 0} {
6230 set rl1 0
6231 }
6232 set ro1 [expr {$row - 3}]
6233 if {$ro1 < 0} {
6234 set ro1 0
6235 }
6236 set r2 [expr {$endrow + $uparrowlen + 3}]
6237 if {$r2 > $numcommits} {
6238 set r2 $numcommits
6239 }
6240 for {set r $rl1} {$r < $r2} {incr r} {
6241 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6242 if {$rl1 < $r} {
6243 layoutrows $rl1 $r
6244 }
6245 set rl1 [expr {$r + 1}]
6246 }
6247 }
6248 if {$rl1 < $r} {
6249 layoutrows $rl1 $r
6250 }
6251 optimize_rows $ro1 0 $r2
6252 if {$need_redisplay || $nrows_drawn > 2000} {
6253 clear_display
6254 }
6255
6256 # make the lines join to already-drawn rows either side
6257 set r [expr {$row - 1}]
6258 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6259 set r $row
6260 }
6261 set er [expr {$endrow + 1}]
6262 if {$er >= $numcommits ||
6263 ![info exists iddrawn([lindex $displayorder $er])]} {
6264 set er $endrow
6265 }
6266 for {} {$r <= $er} {incr r} {
6267 set id [lindex $displayorder $r]
6268 set wasdrawn [info exists iddrawn($id)]
6269 drawcmitrow $r
6270 if {$r == $er} break
6271 set nextid [lindex $displayorder [expr {$r + 1}]]
6272 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6273 drawparentlinks $id $r
6274
6275 set rowids [lindex $rowidlist $r]
6276 foreach lid $rowids {
6277 if {$lid eq {}} continue
6278 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6279 if {$lid eq $id} {
6280 # see if this is the first child of any of its parents
6281 foreach p [lindex $parentlist $r] {
6282 if {[lsearch -exact $rowids $p] < 0} {
6283 # make this line extend up to the child
6284 set lineend($p) [drawlineseg $p $r $er 0]
6285 }
6286 }
6287 } else {
6288 set lineend($lid) [drawlineseg $lid $r $er 1]
6289 }
6290 }
6291 }
6292}
6293
6294proc undolayout {row} {
6295 global uparrowlen mingaplen downarrowlen
6296 global rowidlist rowisopt rowfinal need_redisplay
6297
6298 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6299 if {$r < 0} {
6300 set r 0
6301 }
6302 if {[llength $rowidlist] > $r} {
6303 incr r -1
6304 set rowidlist [lrange $rowidlist 0 $r]
6305 set rowfinal [lrange $rowfinal 0 $r]
6306 set rowisopt [lrange $rowisopt 0 $r]
6307 set need_redisplay 1
6308 run drawvisible
6309 }
6310}
6311
6312proc drawvisible {} {
6313 global canv linespc curview vrowmod selectedline targetrow targetid
6314 global need_redisplay cscroll numcommits
6315
6316 set fs [$canv yview]
6317 set ymax [lindex [$canv cget -scrollregion] 3]
6318 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6319 set f0 [lindex $fs 0]
6320 set f1 [lindex $fs 1]
6321 set y0 [expr {int($f0 * $ymax)}]
6322 set y1 [expr {int($f1 * $ymax)}]
6323
6324 if {[info exists targetid]} {
6325 if {[commitinview $targetid $curview]} {
6326 set r [rowofcommit $targetid]
6327 if {$r != $targetrow} {
6328 # Fix up the scrollregion and change the scrolling position
6329 # now that our target row has moved.
6330 set diff [expr {($r - $targetrow) * $linespc}]
6331 set targetrow $r
6332 setcanvscroll
6333 set ymax [lindex [$canv cget -scrollregion] 3]
6334 incr y0 $diff
6335 incr y1 $diff
6336 set f0 [expr {$y0 / $ymax}]
6337 set f1 [expr {$y1 / $ymax}]
6338 allcanvs yview moveto $f0
6339 $cscroll set $f0 $f1
6340 set need_redisplay 1
6341 }
6342 } else {
6343 unset targetid
6344 }
6345 }
6346
6347 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6348 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6349 if {$endrow >= $vrowmod($curview)} {
6350 update_arcrows $curview
6351 }
6352 if {$selectedline ne {} &&
6353 $row <= $selectedline && $selectedline <= $endrow} {
6354 set targetrow $selectedline
6355 } elseif {[info exists targetid]} {
6356 set targetrow [expr {int(($row + $endrow) / 2)}]
6357 }
6358 if {[info exists targetrow]} {
6359 if {$targetrow >= $numcommits} {
6360 set targetrow [expr {$numcommits - 1}]
6361 }
6362 set targetid [commitonrow $targetrow]
6363 }
6364 drawcommits $row $endrow
6365}
6366
6367proc clear_display {} {
6368 global iddrawn linesegs need_redisplay nrows_drawn
6369 global vhighlights fhighlights nhighlights rhighlights
6370 global linehtag linentag linedtag boldids boldnameids
6371
6372 allcanvs delete all
6373 unset -nocomplain iddrawn
6374 unset -nocomplain linesegs
6375 unset -nocomplain linehtag
6376 unset -nocomplain linentag
6377 unset -nocomplain linedtag
6378 set boldids {}
6379 set boldnameids {}
6380 unset -nocomplain vhighlights
6381 unset -nocomplain fhighlights
6382 unset -nocomplain nhighlights
6383 unset -nocomplain rhighlights
6384 set need_redisplay 0
6385 set nrows_drawn 0
6386}
6387
6388proc findcrossings {id} {
6389 global rowidlist parentlist numcommits displayorder
6390
6391 set cross {}
6392 set ccross {}
6393 foreach {s e} [rowranges $id] {
6394 if {$e >= $numcommits} {
6395 set e [expr {$numcommits - 1}]
6396 }
6397 if {$e <= $s} continue
6398 for {set row $e} {[incr row -1] >= $s} {} {
6399 set x [lsearch -exact [lindex $rowidlist $row] $id]
6400 if {$x < 0} break
6401 set olds [lindex $parentlist $row]
6402 set kid [lindex $displayorder $row]
6403 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6404 if {$kidx < 0} continue
6405 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6406 foreach p $olds {
6407 set px [lsearch -exact $nextrow $p]
6408 if {$px < 0} continue
6409 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6410 if {[lsearch -exact $ccross $p] >= 0} continue
6411 if {$x == $px + ($kidx < $px? -1: 1)} {
6412 lappend ccross $p
6413 } elseif {[lsearch -exact $cross $p] < 0} {
6414 lappend cross $p
6415 }
6416 }
6417 }
6418 }
6419 }
6420 return [concat $ccross {{}} $cross]
6421}
6422
6423proc assigncolor {id} {
6424 global colormap colors nextcolor
6425 global parents children children curview
6426
6427 if {[info exists colormap($id)]} return
6428 set ncolors [llength $colors]
6429 if {[info exists children($curview,$id)]} {
6430 set kids $children($curview,$id)
6431 } else {
6432 set kids {}
6433 }
6434 if {[llength $kids] == 1} {
6435 set child [lindex $kids 0]
6436 if {[info exists colormap($child)]
6437 && [llength $parents($curview,$child)] == 1} {
6438 set colormap($id) $colormap($child)
6439 return
6440 }
6441 }
6442 set badcolors {}
6443 set origbad {}
6444 foreach x [findcrossings $id] {
6445 if {$x eq {}} {
6446 # delimiter between corner crossings and other crossings
6447 if {[llength $badcolors] >= $ncolors - 1} break
6448 set origbad $badcolors
6449 }
6450 if {[info exists colormap($x)]
6451 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6452 lappend badcolors $colormap($x)
6453 }
6454 }
6455 if {[llength $badcolors] >= $ncolors} {
6456 set badcolors $origbad
6457 }
6458 set origbad $badcolors
6459 if {[llength $badcolors] < $ncolors - 1} {
6460 foreach child $kids {
6461 if {[info exists colormap($child)]
6462 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6463 lappend badcolors $colormap($child)
6464 }
6465 foreach p $parents($curview,$child) {
6466 if {[info exists colormap($p)]
6467 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6468 lappend badcolors $colormap($p)
6469 }
6470 }
6471 }
6472 if {[llength $badcolors] >= $ncolors} {
6473 set badcolors $origbad
6474 }
6475 }
6476 for {set i 0} {$i <= $ncolors} {incr i} {
6477 set c [lindex $colors $nextcolor]
6478 if {[incr nextcolor] >= $ncolors} {
6479 set nextcolor 0
6480 }
6481 if {[lsearch -exact $badcolors $c]} break
6482 }
6483 set colormap($id) $c
6484}
6485
6486proc bindline {t id} {
6487 global canv
6488
6489 $canv bind $t <Enter> "lineenter %x %y $id"
6490 $canv bind $t <Motion> "linemotion %x %y $id"
6491 $canv bind $t <Leave> "lineleave $id"
6492 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6493}
6494
6495proc graph_pane_width {} {
6496 global use_ttk
6497
6498 if {$use_ttk} {
6499 set g [.tf.histframe.pwclist sashpos 0]
6500 } else {
6501 set g [.tf.histframe.pwclist sash coord 0]
6502 }
6503 return [lindex $g 0]
6504}
6505
6506proc totalwidth {l font extra} {
6507 set tot 0
6508 foreach str $l {
6509 set tot [expr {$tot + [font measure $font $str] + $extra}]
6510 }
6511 return $tot
6512}
6513
6514proc drawtags {id x xt y1} {
6515 global idtags idheads idotherrefs mainhead
6516 global linespc lthickness
6517 global canv rowtextx curview fgcolor bgcolor ctxbut
6518 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6519 global tagbgcolor tagfgcolor tagoutlinecolor
6520 global reflinecolor
6521
6522 set marks {}
6523 set ntags 0
6524 set nheads 0
6525 set singletag 0
6526 set maxtags 3
6527 set maxtagpct 25
6528 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6529 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6530 set extra [expr {$delta + $lthickness + $linespc}]
6531
6532 if {[info exists idtags($id)]} {
6533 set marks $idtags($id)
6534 set ntags [llength $marks]
6535 if {$ntags > $maxtags ||
6536 [totalwidth $marks mainfont $extra] > $maxwidth} {
6537 # show just a single "n tags..." tag
6538 set singletag 1
6539 if {$ntags == 1} {
6540 set marks [list "tag..."]
6541 } else {
6542 set marks [list [format "%d tags..." $ntags]]
6543 }
6544 set ntags 1
6545 }
6546 }
6547 if {[info exists idheads($id)]} {
6548 set marks [concat $marks $idheads($id)]
6549 set nheads [llength $idheads($id)]
6550 }
6551 if {[info exists idotherrefs($id)]} {
6552 set marks [concat $marks $idotherrefs($id)]
6553 }
6554 if {$marks eq {}} {
6555 return $xt
6556 }
6557
6558 set yt [expr {$y1 - 0.5 * $linespc}]
6559 set yb [expr {$yt + $linespc - 1}]
6560 set xvals {}
6561 set wvals {}
6562 set i -1
6563 foreach tag $marks {
6564 incr i
6565 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6566 set wid [font measure mainfontbold $tag]
6567 } else {
6568 set wid [font measure mainfont $tag]
6569 }
6570 lappend xvals $xt
6571 lappend wvals $wid
6572 set xt [expr {$xt + $wid + $extra}]
6573 }
6574 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6575 -width $lthickness -fill $reflinecolor -tags tag.$id]
6576 $canv lower $t
6577 foreach tag $marks x $xvals wid $wvals {
6578 set tag_quoted [string map {% %%} $tag]
6579 set xl [expr {$x + $delta}]
6580 set xr [expr {$x + $delta + $wid + $lthickness}]
6581 set font mainfont
6582 if {[incr ntags -1] >= 0} {
6583 # draw a tag
6584 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6585 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6586 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6587 -tags tag.$id]
6588 if {$singletag} {
6589 set tagclick [list showtags $id 1]
6590 } else {
6591 set tagclick [list showtag $tag_quoted 1]
6592 }
6593 $canv bind $t <1> $tagclick
6594 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6595 } else {
6596 # draw a head or other ref
6597 if {[incr nheads -1] >= 0} {
6598 set col $headbgcolor
6599 if {$tag eq $mainhead} {
6600 set font mainfontbold
6601 }
6602 } else {
6603 set col "#ddddff"
6604 }
6605 set xl [expr {$xl - $delta/2}]
6606 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6607 -width 1 -outline black -fill $col -tags tag.$id
6608 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6609 set rwid [font measure mainfont $remoteprefix]
6610 set xi [expr {$x + 1}]
6611 set yti [expr {$yt + 1}]
6612 set xri [expr {$x + $rwid}]
6613 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6614 -width 0 -fill $remotebgcolor -tags tag.$id
6615 }
6616 }
6617 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6618 -font $font -tags [list tag.$id text]]
6619 if {$ntags >= 0} {
6620 $canv bind $t <1> $tagclick
6621 } elseif {$nheads >= 0} {
6622 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6623 }
6624 }
6625 return $xt
6626}
6627
6628proc drawnotesign {xt y} {
6629 global linespc canv fgcolor
6630
6631 set orad [expr {$linespc / 3}]
6632 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6633 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6634 -fill yellow -outline $fgcolor -width 1 -tags circle]
6635 set xt [expr {$xt + $orad * 3}]
6636 return $xt
6637}
6638
6639proc xcoord {i level ln} {
6640 global canvx0 xspc1 xspc2
6641
6642 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6643 if {$i > 0 && $i == $level} {
6644 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6645 } elseif {$i > $level} {
6646 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6647 }
6648 return $x
6649}
6650
6651proc show_status {msg} {
6652 global canv fgcolor
6653
6654 clear_display
6655 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6656 -tags text -fill $fgcolor
6657}
6658
6659# Don't change the text pane cursor if it is currently the hand cursor,
6660# showing that we are over a sha1 ID link.
6661proc settextcursor {c} {
6662 global ctext curtextcursor
6663
6664 if {[$ctext cget -cursor] == $curtextcursor} {
6665 $ctext config -cursor $c
6666 }
6667 set curtextcursor $c
6668}
6669
6670proc nowbusy {what {name {}}} {
6671 global isbusy busyname statusw
6672
6673 if {[array names isbusy] eq {}} {
6674 . config -cursor watch
6675 settextcursor watch
6676 }
6677 set isbusy($what) 1
6678 set busyname($what) $name
6679 if {$name ne {}} {
6680 $statusw conf -text $name
6681 }
6682}
6683
6684proc notbusy {what} {
6685 global isbusy maincursor textcursor busyname statusw
6686
6687 catch {
6688 unset isbusy($what)
6689 if {$busyname($what) ne {} &&
6690 [$statusw cget -text] eq $busyname($what)} {
6691 $statusw conf -text {}
6692 }
6693 }
6694 if {[array names isbusy] eq {}} {
6695 . config -cursor $maincursor
6696 settextcursor $textcursor
6697 }
6698}
6699
6700proc findmatches {f} {
6701 global findtype findstring
6702 if {$findtype == [mc "Regexp"]} {
6703 set matches [regexp -indices -all -inline $findstring $f]
6704 } else {
6705 set fs $findstring
6706 if {$findtype == [mc "IgnCase"]} {
6707 set f [string tolower $f]
6708 set fs [string tolower $fs]
6709 }
6710 set matches {}
6711 set i 0
6712 set l [string length $fs]
6713 while {[set j [string first $fs $f $i]] >= 0} {
6714 lappend matches [list $j [expr {$j+$l-1}]]
6715 set i [expr {$j + $l}]
6716 }
6717 }
6718 return $matches
6719}
6720
6721proc dofind {{dirn 1} {wrap 1}} {
6722 global findstring findstartline findcurline selectedline numcommits
6723 global gdttype filehighlight fh_serial find_dirn findallowwrap
6724
6725 if {[info exists find_dirn]} {
6726 if {$find_dirn == $dirn} return
6727 stopfinding
6728 }
6729 focus .
6730 if {$findstring eq {} || $numcommits == 0} return
6731 if {$selectedline eq {}} {
6732 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6733 } else {
6734 set findstartline $selectedline
6735 }
6736 set findcurline $findstartline
6737 nowbusy finding [mc "Searching"]
6738 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6739 after cancel do_file_hl $fh_serial
6740 do_file_hl $fh_serial
6741 }
6742 set find_dirn $dirn
6743 set findallowwrap $wrap
6744 run findmore
6745}
6746
6747proc stopfinding {} {
6748 global find_dirn findcurline fprogcoord
6749
6750 if {[info exists find_dirn]} {
6751 unset find_dirn
6752 unset findcurline
6753 notbusy finding
6754 set fprogcoord 0
6755 adjustprogress
6756 }
6757 stopblaming
6758}
6759
6760proc findmore {} {
6761 global commitdata commitinfo numcommits findpattern findloc
6762 global findstartline findcurline findallowwrap
6763 global find_dirn gdttype fhighlights fprogcoord
6764 global curview varcorder vrownum varccommits vrowmod
6765
6766 if {![info exists find_dirn]} {
6767 return 0
6768 }
6769 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6770 set l $findcurline
6771 set moretodo 0
6772 if {$find_dirn > 0} {
6773 incr l
6774 if {$l >= $numcommits} {
6775 set l 0
6776 }
6777 if {$l <= $findstartline} {
6778 set lim [expr {$findstartline + 1}]
6779 } else {
6780 set lim $numcommits
6781 set moretodo $findallowwrap
6782 }
6783 } else {
6784 if {$l == 0} {
6785 set l $numcommits
6786 }
6787 incr l -1
6788 if {$l >= $findstartline} {
6789 set lim [expr {$findstartline - 1}]
6790 } else {
6791 set lim -1
6792 set moretodo $findallowwrap
6793 }
6794 }
6795 set n [expr {($lim - $l) * $find_dirn}]
6796 if {$n > 500} {
6797 set n 500
6798 set moretodo 1
6799 }
6800 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6801 update_arcrows $curview
6802 }
6803 set found 0
6804 set domore 1
6805 set ai [bsearch $vrownum($curview) $l]
6806 set a [lindex $varcorder($curview) $ai]
6807 set arow [lindex $vrownum($curview) $ai]
6808 set ids [lindex $varccommits($curview,$a)]
6809 set arowend [expr {$arow + [llength $ids]}]
6810 if {$gdttype eq [mc "containing:"]} {
6811 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6812 if {$l < $arow || $l >= $arowend} {
6813 incr ai $find_dirn
6814 set a [lindex $varcorder($curview) $ai]
6815 set arow [lindex $vrownum($curview) $ai]
6816 set ids [lindex $varccommits($curview,$a)]
6817 set arowend [expr {$arow + [llength $ids]}]
6818 }
6819 set id [lindex $ids [expr {$l - $arow}]]
6820 # shouldn't happen unless git log doesn't give all the commits...
6821 if {![info exists commitdata($id)] ||
6822 ![doesmatch $commitdata($id)]} {
6823 continue
6824 }
6825 if {![info exists commitinfo($id)]} {
6826 getcommit $id
6827 }
6828 set info $commitinfo($id)
6829 foreach f $info ty $fldtypes {
6830 if {$ty eq ""} continue
6831 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6832 [doesmatch $f]} {
6833 set found 1
6834 break
6835 }
6836 }
6837 if {$found} break
6838 }
6839 } else {
6840 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6841 if {$l < $arow || $l >= $arowend} {
6842 incr ai $find_dirn
6843 set a [lindex $varcorder($curview) $ai]
6844 set arow [lindex $vrownum($curview) $ai]
6845 set ids [lindex $varccommits($curview,$a)]
6846 set arowend [expr {$arow + [llength $ids]}]
6847 }
6848 set id [lindex $ids [expr {$l - $arow}]]
6849 if {![info exists fhighlights($id)]} {
6850 # this sets fhighlights($id) to -1
6851 askfilehighlight $l $id
6852 }
6853 if {$fhighlights($id) > 0} {
6854 set found $domore
6855 break
6856 }
6857 if {$fhighlights($id) < 0} {
6858 if {$domore} {
6859 set domore 0
6860 set findcurline [expr {$l - $find_dirn}]
6861 }
6862 }
6863 }
6864 }
6865 if {$found || ($domore && !$moretodo)} {
6866 unset findcurline
6867 unset find_dirn
6868 notbusy finding
6869 set fprogcoord 0
6870 adjustprogress
6871 if {$found} {
6872 findselectline $l
6873 } else {
6874 bell
6875 }
6876 return 0
6877 }
6878 if {!$domore} {
6879 flushhighlights
6880 } else {
6881 set findcurline [expr {$l - $find_dirn}]
6882 }
6883 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6884 if {$n < 0} {
6885 incr n $numcommits
6886 }
6887 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6888 adjustprogress
6889 return $domore
6890}
6891
6892proc findselectline {l} {
6893 global findloc commentend ctext findcurline markingmatches gdttype
6894
6895 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6896 set findcurline $l
6897 selectline $l 1
6898 if {$markingmatches &&
6899 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6900 # highlight the matches in the comments
6901 set f [$ctext get 1.0 $commentend]
6902 set matches [findmatches $f]
6903 foreach match $matches {
6904 set start [lindex $match 0]
6905 set end [expr {[lindex $match 1] + 1}]
6906 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6907 }
6908 }
6909 drawvisible
6910}
6911
6912# mark the bits of a headline or author that match a find string
6913proc markmatches {canv l str tag matches font row} {
6914 global selectedline
6915
6916 set bbox [$canv bbox $tag]
6917 set x0 [lindex $bbox 0]
6918 set y0 [lindex $bbox 1]
6919 set y1 [lindex $bbox 3]
6920 foreach match $matches {
6921 set start [lindex $match 0]
6922 set end [lindex $match 1]
6923 if {$start > $end} continue
6924 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6925 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6926 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6927 [expr {$x0+$xlen+2}] $y1 \
6928 -outline {} -tags [list match$l matches] -fill yellow]
6929 $canv lower $t
6930 if {$row == $selectedline} {
6931 $canv raise $t secsel
6932 }
6933 }
6934}
6935
6936proc unmarkmatches {} {
6937 global markingmatches
6938
6939 allcanvs delete matches
6940 set markingmatches 0
6941 stopfinding
6942}
6943
6944proc selcanvline {w x y} {
6945 global canv canvy0 ctext linespc
6946 global rowtextx
6947 set ymax [lindex [$canv cget -scrollregion] 3]
6948 if {$ymax == {}} return
6949 set yfrac [lindex [$canv yview] 0]
6950 set y [expr {$y + $yfrac * $ymax}]
6951 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6952 if {$l < 0} {
6953 set l 0
6954 }
6955 if {$w eq $canv} {
6956 set xmax [lindex [$canv cget -scrollregion] 2]
6957 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6958 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6959 }
6960 unmarkmatches
6961 selectline $l 1
6962}
6963
6964proc commit_descriptor {p} {
6965 global commitinfo
6966 if {![info exists commitinfo($p)]} {
6967 getcommit $p
6968 }
6969 set l "..."
6970 if {[llength $commitinfo($p)] > 1} {
6971 set l [lindex $commitinfo($p) 0]
6972 }
6973 return "$p ($l)\n"
6974}
6975
6976# append some text to the ctext widget, and make any SHA1 ID
6977# that we know about be a clickable link.
6978proc appendwithlinks {text tags} {
6979 global ctext linknum curview
6980
6981 set start [$ctext index "end - 1c"]
6982 $ctext insert end $text $tags
6983 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6984 foreach l $links {
6985 set s [lindex $l 0]
6986 set e [lindex $l 1]
6987 set linkid [string range $text $s $e]
6988 incr e
6989 $ctext tag delete link$linknum
6990 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6991 setlink $linkid link$linknum
6992 incr linknum
6993 }
6994}
6995
6996proc setlink {id lk} {
6997 global curview ctext pendinglinks
6998 global linkfgcolor
6999
7000 if {[string range $id 0 1] eq "-g"} {
7001 set id [string range $id 2 end]
7002 }
7003
7004 set known 0
7005 if {[string length $id] < 40} {
7006 set matches [longid $id]
7007 if {[llength $matches] > 0} {
7008 if {[llength $matches] > 1} return
7009 set known 1
7010 set id [lindex $matches 0]
7011 }
7012 } else {
7013 set known [commitinview $id $curview]
7014 }
7015 if {$known} {
7016 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7017 $ctext tag bind $lk <1> [list selbyid $id]
7018 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7019 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7020 } else {
7021 lappend pendinglinks($id) $lk
7022 interestedin $id {makelink %P}
7023 }
7024}
7025
7026proc appendshortlink {id {pre {}} {post {}}} {
7027 global ctext linknum
7028
7029 $ctext insert end $pre
7030 $ctext tag delete link$linknum
7031 $ctext insert end [string range $id 0 7] link$linknum
7032 $ctext insert end $post
7033 setlink $id link$linknum
7034 incr linknum
7035}
7036
7037proc makelink {id} {
7038 global pendinglinks
7039
7040 if {![info exists pendinglinks($id)]} return
7041 foreach lk $pendinglinks($id) {
7042 setlink $id $lk
7043 }
7044 unset pendinglinks($id)
7045}
7046
7047proc linkcursor {w inc} {
7048 global linkentercount curtextcursor
7049
7050 if {[incr linkentercount $inc] > 0} {
7051 $w configure -cursor hand2
7052 } else {
7053 $w configure -cursor $curtextcursor
7054 if {$linkentercount < 0} {
7055 set linkentercount 0
7056 }
7057 }
7058}
7059
7060proc viewnextline {dir} {
7061 global canv linespc
7062
7063 $canv delete hover
7064 set ymax [lindex [$canv cget -scrollregion] 3]
7065 set wnow [$canv yview]
7066 set wtop [expr {[lindex $wnow 0] * $ymax}]
7067 set newtop [expr {$wtop + $dir * $linespc}]
7068 if {$newtop < 0} {
7069 set newtop 0
7070 } elseif {$newtop > $ymax} {
7071 set newtop $ymax
7072 }
7073 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7074}
7075
7076# add a list of tag or branch names at position pos
7077# returns the number of names inserted
7078proc appendrefs {pos ids var} {
7079 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7080
7081 if {[catch {$ctext index $pos}]} {
7082 return 0
7083 }
7084 $ctext conf -state normal
7085 $ctext delete $pos "$pos lineend"
7086 set tags {}
7087 foreach id $ids {
7088 foreach tag [set $var\($id\)] {
7089 lappend tags [list $tag $id]
7090 }
7091 }
7092
7093 set sep {}
7094 set tags [lsort -index 0 -decreasing $tags]
7095 set nutags 0
7096
7097 if {[llength $tags] > $maxrefs} {
7098 # If we are displaying heads, and there are too many,
7099 # see if there are some important heads to display.
7100 # Currently that are the current head and heads listed in $visiblerefs option
7101 set itags {}
7102 if {$var eq "idheads"} {
7103 set utags {}
7104 foreach ti $tags {
7105 set hname [lindex $ti 0]
7106 set id [lindex $ti 1]
7107 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7108 [llength $itags] < $maxrefs} {
7109 lappend itags $ti
7110 } else {
7111 lappend utags $ti
7112 }
7113 }
7114 set tags $utags
7115 }
7116 if {$itags ne {}} {
7117 set str [mc "and many more"]
7118 set sep " "
7119 } else {
7120 set str [mc "many"]
7121 }
7122 $ctext insert $pos "$str ([llength $tags])"
7123 set nutags [llength $tags]
7124 set tags $itags
7125 }
7126
7127 foreach ti $tags {
7128 set id [lindex $ti 1]
7129 set lk link$linknum
7130 incr linknum
7131 $ctext tag delete $lk
7132 $ctext insert $pos $sep
7133 $ctext insert $pos [lindex $ti 0] $lk
7134 setlink $id $lk
7135 set sep ", "
7136 }
7137 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7138 $ctext conf -state disabled
7139 return [expr {[llength $tags] + $nutags}]
7140}
7141
7142# called when we have finished computing the nearby tags
7143proc dispneartags {delay} {
7144 global selectedline currentid showneartags tagphase
7145
7146 if {$selectedline eq {} || !$showneartags} return
7147 after cancel dispnexttag
7148 if {$delay} {
7149 after 200 dispnexttag
7150 set tagphase -1
7151 } else {
7152 after idle dispnexttag
7153 set tagphase 0
7154 }
7155}
7156
7157proc dispnexttag {} {
7158 global selectedline currentid showneartags tagphase ctext
7159
7160 if {$selectedline eq {} || !$showneartags} return
7161 switch -- $tagphase {
7162 0 {
7163 set dtags [desctags $currentid]
7164 if {$dtags ne {}} {
7165 appendrefs precedes $dtags idtags
7166 }
7167 }
7168 1 {
7169 set atags [anctags $currentid]
7170 if {$atags ne {}} {
7171 appendrefs follows $atags idtags
7172 }
7173 }
7174 2 {
7175 set dheads [descheads $currentid]
7176 if {$dheads ne {}} {
7177 if {[appendrefs branch $dheads idheads] > 1
7178 && [$ctext get "branch -3c"] eq "h"} {
7179 # turn "Branch" into "Branches"
7180 $ctext conf -state normal
7181 $ctext insert "branch -2c" "es"
7182 $ctext conf -state disabled
7183 }
7184 }
7185 }
7186 }
7187 if {[incr tagphase] <= 2} {
7188 after idle dispnexttag
7189 }
7190}
7191
7192proc make_secsel {id} {
7193 global linehtag linentag linedtag canv canv2 canv3
7194
7195 if {![info exists linehtag($id)]} return
7196 $canv delete secsel
7197 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7198 -tags secsel -fill [$canv cget -selectbackground]]
7199 $canv lower $t
7200 $canv2 delete secsel
7201 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7202 -tags secsel -fill [$canv2 cget -selectbackground]]
7203 $canv2 lower $t
7204 $canv3 delete secsel
7205 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7206 -tags secsel -fill [$canv3 cget -selectbackground]]
7207 $canv3 lower $t
7208}
7209
7210proc make_idmark {id} {
7211 global linehtag canv fgcolor
7212
7213 if {![info exists linehtag($id)]} return
7214 $canv delete markid
7215 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7216 -tags markid -outline $fgcolor]
7217 $canv raise $t
7218}
7219
7220proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7221 global canv ctext commitinfo selectedline
7222 global canvy0 linespc parents children curview
7223 global currentid sha1entry
7224 global commentend idtags linknum
7225 global mergemax numcommits pending_select
7226 global cmitmode showneartags allcommits
7227 global targetrow targetid lastscrollrows
7228 global autoselect autosellen jump_to_here
7229 global vinlinediff
7230
7231 unset -nocomplain pending_select
7232 $canv delete hover
7233 normalline
7234 unsel_reflist
7235 stopfinding
7236 if {$l < 0 || $l >= $numcommits} return
7237 set id [commitonrow $l]
7238 set targetid $id
7239 set targetrow $l
7240 set selectedline $l
7241 set currentid $id
7242 if {$lastscrollrows < $numcommits} {
7243 setcanvscroll
7244 }
7245
7246 if {$cmitmode ne "patch" && $switch_to_patch} {
7247 set cmitmode "patch"
7248 }
7249
7250 set y [expr {$canvy0 + $l * $linespc}]
7251 set ymax [lindex [$canv cget -scrollregion] 3]
7252 set ytop [expr {$y - $linespc - 1}]
7253 set ybot [expr {$y + $linespc + 1}]
7254 set wnow [$canv yview]
7255 set wtop [expr {[lindex $wnow 0] * $ymax}]
7256 set wbot [expr {[lindex $wnow 1] * $ymax}]
7257 set wh [expr {$wbot - $wtop}]
7258 set newtop $wtop
7259 if {$ytop < $wtop} {
7260 if {$ybot < $wtop} {
7261 set newtop [expr {$y - $wh / 2.0}]
7262 } else {
7263 set newtop $ytop
7264 if {$newtop > $wtop - $linespc} {
7265 set newtop [expr {$wtop - $linespc}]
7266 }
7267 }
7268 } elseif {$ybot > $wbot} {
7269 if {$ytop > $wbot} {
7270 set newtop [expr {$y - $wh / 2.0}]
7271 } else {
7272 set newtop [expr {$ybot - $wh}]
7273 if {$newtop < $wtop + $linespc} {
7274 set newtop [expr {$wtop + $linespc}]
7275 }
7276 }
7277 }
7278 if {$newtop != $wtop} {
7279 if {$newtop < 0} {
7280 set newtop 0
7281 }
7282 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7283 drawvisible
7284 }
7285
7286 make_secsel $id
7287
7288 if {$isnew} {
7289 addtohistory [list selbyid $id 0] savecmitpos
7290 }
7291
7292 $sha1entry delete 0 end
7293 $sha1entry insert 0 $id
7294 if {$autoselect} {
7295 $sha1entry selection range 0 $autosellen
7296 }
7297 rhighlight_sel $id
7298
7299 $ctext conf -state normal
7300 clear_ctext
7301 set linknum 0
7302 if {![info exists commitinfo($id)]} {
7303 getcommit $id
7304 }
7305 set info $commitinfo($id)
7306 set date [formatdate [lindex $info 2]]
7307 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7308 set date [formatdate [lindex $info 4]]
7309 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7310 if {[info exists idtags($id)]} {
7311 $ctext insert end [mc "Tags:"]
7312 foreach tag $idtags($id) {
7313 $ctext insert end " $tag"
7314 }
7315 $ctext insert end "\n"
7316 }
7317
7318 set headers {}
7319 set olds $parents($curview,$id)
7320 if {[llength $olds] > 1} {
7321 set np 0
7322 foreach p $olds {
7323 if {$np >= $mergemax} {
7324 set tag mmax
7325 } else {
7326 set tag m$np
7327 }
7328 $ctext insert end "[mc "Parent"]: " $tag
7329 appendwithlinks [commit_descriptor $p] {}
7330 incr np
7331 }
7332 } else {
7333 foreach p $olds {
7334 append headers "[mc "Parent"]: [commit_descriptor $p]"
7335 }
7336 }
7337
7338 foreach c $children($curview,$id) {
7339 append headers "[mc "Child"]: [commit_descriptor $c]"
7340 }
7341
7342 # make anything that looks like a SHA1 ID be a clickable link
7343 appendwithlinks $headers {}
7344 if {$showneartags} {
7345 if {![info exists allcommits]} {
7346 getallcommits
7347 }
7348 $ctext insert end "[mc "Branch"]: "
7349 $ctext mark set branch "end -1c"
7350 $ctext mark gravity branch left
7351 $ctext insert end "\n[mc "Follows"]: "
7352 $ctext mark set follows "end -1c"
7353 $ctext mark gravity follows left
7354 $ctext insert end "\n[mc "Precedes"]: "
7355 $ctext mark set precedes "end -1c"
7356 $ctext mark gravity precedes left
7357 $ctext insert end "\n"
7358 dispneartags 1
7359 }
7360 $ctext insert end "\n"
7361 set comment [lindex $info 5]
7362 if {[string first "\r" $comment] >= 0} {
7363 set comment [string map {"\r" "\n "} $comment]
7364 }
7365 appendwithlinks $comment {comment}
7366
7367 $ctext tag remove found 1.0 end
7368 $ctext conf -state disabled
7369 set commentend [$ctext index "end - 1c"]
7370
7371 set jump_to_here $desired_loc
7372 init_flist [mc "Comments"]
7373 if {$cmitmode eq "tree"} {
7374 gettree $id
7375 } elseif {$vinlinediff($curview) == 1} {
7376 showinlinediff $id
7377 } elseif {[llength $olds] <= 1} {
7378 startdiff $id
7379 } else {
7380 mergediff $id
7381 }
7382}
7383
7384proc selfirstline {} {
7385 unmarkmatches
7386 selectline 0 1
7387}
7388
7389proc sellastline {} {
7390 global numcommits
7391 unmarkmatches
7392 set l [expr {$numcommits - 1}]
7393 selectline $l 1
7394}
7395
7396proc selnextline {dir} {
7397 global selectedline
7398 focus .
7399 if {$selectedline eq {}} return
7400 set l [expr {$selectedline + $dir}]
7401 unmarkmatches
7402 selectline $l 1
7403}
7404
7405proc selnextpage {dir} {
7406 global canv linespc selectedline numcommits
7407
7408 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7409 if {$lpp < 1} {
7410 set lpp 1
7411 }
7412 allcanvs yview scroll [expr {$dir * $lpp}] units
7413 drawvisible
7414 if {$selectedline eq {}} return
7415 set l [expr {$selectedline + $dir * $lpp}]
7416 if {$l < 0} {
7417 set l 0
7418 } elseif {$l >= $numcommits} {
7419 set l [expr $numcommits - 1]
7420 }
7421 unmarkmatches
7422 selectline $l 1
7423}
7424
7425proc unselectline {} {
7426 global selectedline currentid
7427
7428 set selectedline {}
7429 unset -nocomplain currentid
7430 allcanvs delete secsel
7431 rhighlight_none
7432}
7433
7434proc reselectline {} {
7435 global selectedline
7436
7437 if {$selectedline ne {}} {
7438 selectline $selectedline 0
7439 }
7440}
7441
7442proc addtohistory {cmd {saveproc {}}} {
7443 global history historyindex curview
7444
7445 unset_posvars
7446 save_position
7447 set elt [list $curview $cmd $saveproc {}]
7448 if {$historyindex > 0
7449 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7450 return
7451 }
7452
7453 if {$historyindex < [llength $history]} {
7454 set history [lreplace $history $historyindex end $elt]
7455 } else {
7456 lappend history $elt
7457 }
7458 incr historyindex
7459 if {$historyindex > 1} {
7460 .tf.bar.leftbut conf -state normal
7461 } else {
7462 .tf.bar.leftbut conf -state disabled
7463 }
7464 .tf.bar.rightbut conf -state disabled
7465}
7466
7467# save the scrolling position of the diff display pane
7468proc save_position {} {
7469 global historyindex history
7470
7471 if {$historyindex < 1} return
7472 set hi [expr {$historyindex - 1}]
7473 set fn [lindex $history $hi 2]
7474 if {$fn ne {}} {
7475 lset history $hi 3 [eval $fn]
7476 }
7477}
7478
7479proc unset_posvars {} {
7480 global last_posvars
7481
7482 if {[info exists last_posvars]} {
7483 foreach {var val} $last_posvars {
7484 global $var
7485 unset -nocomplain $var
7486 }
7487 unset last_posvars
7488 }
7489}
7490
7491proc godo {elt} {
7492 global curview last_posvars
7493
7494 set view [lindex $elt 0]
7495 set cmd [lindex $elt 1]
7496 set pv [lindex $elt 3]
7497 if {$curview != $view} {
7498 showview $view
7499 }
7500 unset_posvars
7501 foreach {var val} $pv {
7502 global $var
7503 set $var $val
7504 }
7505 set last_posvars $pv
7506 eval $cmd
7507}
7508
7509proc goback {} {
7510 global history historyindex
7511 focus .
7512
7513 if {$historyindex > 1} {
7514 save_position
7515 incr historyindex -1
7516 godo [lindex $history [expr {$historyindex - 1}]]
7517 .tf.bar.rightbut conf -state normal
7518 }
7519 if {$historyindex <= 1} {
7520 .tf.bar.leftbut conf -state disabled
7521 }
7522}
7523
7524proc goforw {} {
7525 global history historyindex
7526 focus .
7527
7528 if {$historyindex < [llength $history]} {
7529 save_position
7530 set cmd [lindex $history $historyindex]
7531 incr historyindex
7532 godo $cmd
7533 .tf.bar.leftbut conf -state normal
7534 }
7535 if {$historyindex >= [llength $history]} {
7536 .tf.bar.rightbut conf -state disabled
7537 }
7538}
7539
7540proc go_to_parent {i} {
7541 global parents curview targetid
7542 set ps $parents($curview,$targetid)
7543 if {[llength $ps] >= $i} {
7544 selbyid [lindex $ps [expr $i - 1]]
7545 }
7546}
7547
7548proc gettree {id} {
7549 global treefilelist treeidlist diffids diffmergeid treepending
7550 global nullid nullid2
7551
7552 set diffids $id
7553 unset -nocomplain diffmergeid
7554 if {![info exists treefilelist($id)]} {
7555 if {![info exists treepending]} {
7556 if {$id eq $nullid} {
7557 set cmd [list | git ls-files]
7558 } elseif {$id eq $nullid2} {
7559 set cmd [list | git ls-files --stage -t]
7560 } else {
7561 set cmd [list | git ls-tree -r $id]
7562 }
7563 if {[catch {set gtf [open $cmd r]}]} {
7564 return
7565 }
7566 set treepending $id
7567 set treefilelist($id) {}
7568 set treeidlist($id) {}
7569 fconfigure $gtf -blocking 0 -encoding binary
7570 filerun $gtf [list gettreeline $gtf $id]
7571 }
7572 } else {
7573 setfilelist $id
7574 }
7575}
7576
7577proc gettreeline {gtf id} {
7578 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7579
7580 set nl 0
7581 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7582 if {$diffids eq $nullid} {
7583 set fname $line
7584 } else {
7585 set i [string first "\t" $line]
7586 if {$i < 0} continue
7587 set fname [string range $line [expr {$i+1}] end]
7588 set line [string range $line 0 [expr {$i-1}]]
7589 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7590 set sha1 [lindex $line 2]
7591 lappend treeidlist($id) $sha1
7592 }
7593 if {[string index $fname 0] eq "\""} {
7594 set fname [lindex $fname 0]
7595 }
7596 set fname [encoding convertfrom $fname]
7597 lappend treefilelist($id) $fname
7598 }
7599 if {![eof $gtf]} {
7600 return [expr {$nl >= 1000? 2: 1}]
7601 }
7602 close $gtf
7603 unset treepending
7604 if {$cmitmode ne "tree"} {
7605 if {![info exists diffmergeid]} {
7606 gettreediffs $diffids
7607 }
7608 } elseif {$id ne $diffids} {
7609 gettree $diffids
7610 } else {
7611 setfilelist $id
7612 }
7613 return 0
7614}
7615
7616proc showfile {f} {
7617 global treefilelist treeidlist diffids nullid nullid2
7618 global ctext_file_names ctext_file_lines
7619 global ctext commentend
7620
7621 set i [lsearch -exact $treefilelist($diffids) $f]
7622 if {$i < 0} {
7623 puts "oops, $f not in list for id $diffids"
7624 return
7625 }
7626 if {$diffids eq $nullid} {
7627 if {[catch {set bf [open $f r]} err]} {
7628 puts "oops, can't read $f: $err"
7629 return
7630 }
7631 } else {
7632 set blob [lindex $treeidlist($diffids) $i]
7633 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7634 puts "oops, error reading blob $blob: $err"
7635 return
7636 }
7637 }
7638 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7639 filerun $bf [list getblobline $bf $diffids]
7640 $ctext config -state normal
7641 clear_ctext $commentend
7642 lappend ctext_file_names $f
7643 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7644 $ctext insert end "\n"
7645 $ctext insert end "$f\n" filesep
7646 $ctext config -state disabled
7647 $ctext yview $commentend
7648 settabs 0
7649}
7650
7651proc getblobline {bf id} {
7652 global diffids cmitmode ctext
7653
7654 if {$id ne $diffids || $cmitmode ne "tree"} {
7655 catch {close $bf}
7656 return 0
7657 }
7658 $ctext config -state normal
7659 set nl 0
7660 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7661 $ctext insert end "$line\n"
7662 }
7663 if {[eof $bf]} {
7664 global jump_to_here ctext_file_names commentend
7665
7666 # delete last newline
7667 $ctext delete "end - 2c" "end - 1c"
7668 close $bf
7669 if {$jump_to_here ne {} &&
7670 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7671 set lnum [expr {[lindex $jump_to_here 1] +
7672 [lindex [split $commentend .] 0]}]
7673 mark_ctext_line $lnum
7674 }
7675 $ctext config -state disabled
7676 return 0
7677 }
7678 $ctext config -state disabled
7679 return [expr {$nl >= 1000? 2: 1}]
7680}
7681
7682proc mark_ctext_line {lnum} {
7683 global ctext markbgcolor
7684
7685 $ctext tag delete omark
7686 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7687 $ctext tag conf omark -background $markbgcolor
7688 $ctext see $lnum.0
7689}
7690
7691proc mergediff {id} {
7692 global diffmergeid
7693 global diffids treediffs
7694 global parents curview
7695
7696 set diffmergeid $id
7697 set diffids $id
7698 set treediffs($id) {}
7699 set np [llength $parents($curview,$id)]
7700 settabs $np
7701 getblobdiffs $id
7702}
7703
7704proc startdiff {ids} {
7705 global treediffs diffids treepending diffmergeid nullid nullid2
7706
7707 settabs 1
7708 set diffids $ids
7709 unset -nocomplain diffmergeid
7710 if {![info exists treediffs($ids)] ||
7711 [lsearch -exact $ids $nullid] >= 0 ||
7712 [lsearch -exact $ids $nullid2] >= 0} {
7713 if {![info exists treepending]} {
7714 gettreediffs $ids
7715 }
7716 } else {
7717 addtocflist $ids
7718 }
7719}
7720
7721proc showinlinediff {ids} {
7722 global commitinfo commitdata ctext
7723 global treediffs
7724
7725 set info $commitinfo($ids)
7726 set diff [lindex $info 7]
7727 set difflines [split $diff "\n"]
7728
7729 initblobdiffvars
7730 set treediff {}
7731
7732 set inhdr 0
7733 foreach line $difflines {
7734 if {![string compare -length 5 "diff " $line]} {
7735 set inhdr 1
7736 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7737 # offset also accounts for the b/ prefix
7738 lappend treediff [string range $line 6 end]
7739 set inhdr 0
7740 }
7741 }
7742
7743 set treediffs($ids) $treediff
7744 add_flist $treediff
7745
7746 $ctext conf -state normal
7747 foreach line $difflines {
7748 parseblobdiffline $ids $line
7749 }
7750 maybe_scroll_ctext 1
7751 $ctext conf -state disabled
7752}
7753
7754# If the filename (name) is under any of the passed filter paths
7755# then return true to include the file in the listing.
7756proc path_filter {filter name} {
7757 set worktree [gitworktree]
7758 foreach p $filter {
7759 set fq_p [file normalize $p]
7760 set fq_n [file normalize [file join $worktree $name]]
7761 if {[string match [file normalize $fq_p]* $fq_n]} {
7762 return 1
7763 }
7764 }
7765 return 0
7766}
7767
7768proc addtocflist {ids} {
7769 global treediffs
7770
7771 add_flist $treediffs($ids)
7772 getblobdiffs $ids
7773}
7774
7775proc diffcmd {ids flags} {
7776 global log_showroot nullid nullid2 git_version
7777
7778 set i [lsearch -exact $ids $nullid]
7779 set j [lsearch -exact $ids $nullid2]
7780 if {$i >= 0} {
7781 if {[llength $ids] > 1 && $j < 0} {
7782 # comparing working directory with some specific revision
7783 set cmd [concat | git diff-index $flags]
7784 if {$i == 0} {
7785 lappend cmd -R [lindex $ids 1]
7786 } else {
7787 lappend cmd [lindex $ids 0]
7788 }
7789 } else {
7790 # comparing working directory with index
7791 set cmd [concat | git diff-files $flags]
7792 if {$j == 1} {
7793 lappend cmd -R
7794 }
7795 }
7796 } elseif {$j >= 0} {
7797 if {[package vcompare $git_version "1.7.2"] >= 0} {
7798 set flags "$flags --ignore-submodules=dirty"
7799 }
7800 set cmd [concat | git diff-index --cached $flags]
7801 if {[llength $ids] > 1} {
7802 # comparing index with specific revision
7803 if {$j == 0} {
7804 lappend cmd -R [lindex $ids 1]
7805 } else {
7806 lappend cmd [lindex $ids 0]
7807 }
7808 } else {
7809 # comparing index with HEAD
7810 lappend cmd HEAD
7811 }
7812 } else {
7813 if {$log_showroot} {
7814 lappend flags --root
7815 }
7816 set cmd [concat | git diff-tree -r $flags $ids]
7817 }
7818 return $cmd
7819}
7820
7821proc gettreediffs {ids} {
7822 global treediff treepending limitdiffs vfilelimit curview
7823
7824 set cmd [diffcmd $ids {--no-commit-id}]
7825 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7826 set cmd [concat $cmd -- $vfilelimit($curview)]
7827 }
7828 if {[catch {set gdtf [open $cmd r]}]} return
7829
7830 set treepending $ids
7831 set treediff {}
7832 fconfigure $gdtf -blocking 0 -encoding binary
7833 filerun $gdtf [list gettreediffline $gdtf $ids]
7834}
7835
7836proc gettreediffline {gdtf ids} {
7837 global treediff treediffs treepending diffids diffmergeid
7838 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7839
7840 set nr 0
7841 set sublist {}
7842 set max 1000
7843 if {$perfile_attrs} {
7844 # cache_gitattr is slow, and even slower on win32 where we
7845 # have to invoke it for only about 30 paths at a time
7846 set max 500
7847 if {[tk windowingsystem] == "win32"} {
7848 set max 120
7849 }
7850 }
7851 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7852 set i [string first "\t" $line]
7853 if {$i >= 0} {
7854 set file [string range $line [expr {$i+1}] end]
7855 if {[string index $file 0] eq "\""} {
7856 set file [lindex $file 0]
7857 }
7858 set file [encoding convertfrom $file]
7859 if {$file ne [lindex $treediff end]} {
7860 lappend treediff $file
7861 lappend sublist $file
7862 }
7863 }
7864 }
7865 if {$perfile_attrs} {
7866 cache_gitattr encoding $sublist
7867 }
7868 if {![eof $gdtf]} {
7869 return [expr {$nr >= $max? 2: 1}]
7870 }
7871 close $gdtf
7872 set treediffs($ids) $treediff
7873 unset treepending
7874 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7875 gettree $diffids
7876 } elseif {$ids != $diffids} {
7877 if {![info exists diffmergeid]} {
7878 gettreediffs $diffids
7879 }
7880 } else {
7881 addtocflist $ids
7882 }
7883 return 0
7884}
7885
7886# empty string or positive integer
7887proc diffcontextvalidate {v} {
7888 return [regexp {^(|[1-9][0-9]*)$} $v]
7889}
7890
7891proc diffcontextchange {n1 n2 op} {
7892 global diffcontextstring diffcontext
7893
7894 if {[string is integer -strict $diffcontextstring]} {
7895 if {$diffcontextstring >= 0} {
7896 set diffcontext $diffcontextstring
7897 reselectline
7898 }
7899 }
7900}
7901
7902proc changeignorespace {} {
7903 reselectline
7904}
7905
7906proc changeworddiff {name ix op} {
7907 reselectline
7908}
7909
7910proc initblobdiffvars {} {
7911 global diffencoding targetline diffnparents
7912 global diffinhdr currdiffsubmod diffseehere
7913 set targetline {}
7914 set diffnparents 0
7915 set diffinhdr 0
7916 set diffencoding [get_path_encoding {}]
7917 set currdiffsubmod ""
7918 set diffseehere -1
7919}
7920
7921proc getblobdiffs {ids} {
7922 global blobdifffd diffids env
7923 global treediffs
7924 global diffcontext
7925 global ignorespace
7926 global worddiff
7927 global limitdiffs vfilelimit curview
7928 global git_version
7929
7930 set textconv {}
7931 if {[package vcompare $git_version "1.6.1"] >= 0} {
7932 set textconv "--textconv"
7933 }
7934 set submodule {}
7935 if {[package vcompare $git_version "1.6.6"] >= 0} {
7936 set submodule "--submodule"
7937 }
7938 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7939 if {$ignorespace} {
7940 append cmd " -w"
7941 }
7942 if {$worddiff ne [mc "Line diff"]} {
7943 append cmd " --word-diff=porcelain"
7944 }
7945 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7946 set cmd [concat $cmd -- $vfilelimit($curview)]
7947 }
7948 if {[catch {set bdf [open $cmd r]} err]} {
7949 error_popup [mc "Error getting diffs: %s" $err]
7950 return
7951 }
7952 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7953 set blobdifffd($ids) $bdf
7954 initblobdiffvars
7955 filerun $bdf [list getblobdiffline $bdf $diffids]
7956}
7957
7958proc savecmitpos {} {
7959 global ctext cmitmode
7960
7961 if {$cmitmode eq "tree"} {
7962 return {}
7963 }
7964 return [list target_scrollpos [$ctext index @0,0]]
7965}
7966
7967proc savectextpos {} {
7968 global ctext
7969
7970 return [list target_scrollpos [$ctext index @0,0]]
7971}
7972
7973proc maybe_scroll_ctext {ateof} {
7974 global ctext target_scrollpos
7975
7976 if {![info exists target_scrollpos]} return
7977 if {!$ateof} {
7978 set nlines [expr {[winfo height $ctext]
7979 / [font metrics textfont -linespace]}]
7980 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7981 }
7982 $ctext yview $target_scrollpos
7983 unset target_scrollpos
7984}
7985
7986proc setinlist {var i val} {
7987 global $var
7988
7989 while {[llength [set $var]] < $i} {
7990 lappend $var {}
7991 }
7992 if {[llength [set $var]] == $i} {
7993 lappend $var $val
7994 } else {
7995 lset $var $i $val
7996 }
7997}
7998
7999proc makediffhdr {fname ids} {
8000 global ctext curdiffstart treediffs diffencoding
8001 global ctext_file_names jump_to_here targetline diffline
8002
8003 set fname [encoding convertfrom $fname]
8004 set diffencoding [get_path_encoding $fname]
8005 set i [lsearch -exact $treediffs($ids) $fname]
8006 if {$i >= 0} {
8007 setinlist difffilestart $i $curdiffstart
8008 }
8009 lset ctext_file_names end $fname
8010 set l [expr {(78 - [string length $fname]) / 2}]
8011 set pad [string range "----------------------------------------" 1 $l]
8012 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8013 set targetline {}
8014 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8015 set targetline [lindex $jump_to_here 1]
8016 }
8017 set diffline 0
8018}
8019
8020proc blobdiffmaybeseehere {ateof} {
8021 global diffseehere
8022 if {$diffseehere >= 0} {
8023 mark_ctext_line [lindex [split $diffseehere .] 0]
8024 }
8025 maybe_scroll_ctext $ateof
8026}
8027
8028proc getblobdiffline {bdf ids} {
8029 global diffids blobdifffd
8030 global ctext
8031
8032 set nr 0
8033 $ctext conf -state normal
8034 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8035 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8036 catch {close $bdf}
8037 return 0
8038 }
8039 parseblobdiffline $ids $line
8040 }
8041 $ctext conf -state disabled
8042 blobdiffmaybeseehere [eof $bdf]
8043 if {[eof $bdf]} {
8044 catch {close $bdf}
8045 return 0
8046 }
8047 return [expr {$nr >= 1000? 2: 1}]
8048}
8049
8050proc parseblobdiffline {ids line} {
8051 global ctext curdiffstart
8052 global diffnexthead diffnextnote difffilestart
8053 global ctext_file_names ctext_file_lines
8054 global diffinhdr treediffs mergemax diffnparents
8055 global diffencoding jump_to_here targetline diffline currdiffsubmod
8056 global worddiff diffseehere
8057
8058 if {![string compare -length 5 "diff " $line]} {
8059 if {![regexp {^diff (--cc|--git) } $line m type]} {
8060 set line [encoding convertfrom $line]
8061 $ctext insert end "$line\n" hunksep
8062 continue
8063 }
8064 # start of a new file
8065 set diffinhdr 1
8066 $ctext insert end "\n"
8067 set curdiffstart [$ctext index "end - 1c"]
8068 lappend ctext_file_names ""
8069 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8070 $ctext insert end "\n" filesep
8071
8072 if {$type eq "--cc"} {
8073 # start of a new file in a merge diff
8074 set fname [string range $line 10 end]
8075 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8076 lappend treediffs($ids) $fname
8077 add_flist [list $fname]
8078 }
8079
8080 } else {
8081 set line [string range $line 11 end]
8082 # If the name hasn't changed the length will be odd,
8083 # the middle char will be a space, and the two bits either
8084 # side will be a/name and b/name, or "a/name" and "b/name".
8085 # If the name has changed we'll get "rename from" and
8086 # "rename to" or "copy from" and "copy to" lines following
8087 # this, and we'll use them to get the filenames.
8088 # This complexity is necessary because spaces in the
8089 # filename(s) don't get escaped.
8090 set l [string length $line]
8091 set i [expr {$l / 2}]
8092 if {!(($l & 1) && [string index $line $i] eq " " &&
8093 [string range $line 2 [expr {$i - 1}]] eq \
8094 [string range $line [expr {$i + 3}] end])} {
8095 return
8096 }
8097 # unescape if quoted and chop off the a/ from the front
8098 if {[string index $line 0] eq "\""} {
8099 set fname [string range [lindex $line 0] 2 end]
8100 } else {
8101 set fname [string range $line 2 [expr {$i - 1}]]
8102 }
8103 }
8104 makediffhdr $fname $ids
8105
8106 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8107 set fname [encoding convertfrom [string range $line 16 end]]
8108 $ctext insert end "\n"
8109 set curdiffstart [$ctext index "end - 1c"]
8110 lappend ctext_file_names $fname
8111 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8112 $ctext insert end "$line\n" filesep
8113 set i [lsearch -exact $treediffs($ids) $fname]
8114 if {$i >= 0} {
8115 setinlist difffilestart $i $curdiffstart
8116 }
8117
8118 } elseif {![string compare -length 2 "@@" $line]} {
8119 regexp {^@@+} $line ats
8120 set line [encoding convertfrom $diffencoding $line]
8121 $ctext insert end "$line\n" hunksep
8122 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8123 set diffline $nl
8124 }
8125 set diffnparents [expr {[string length $ats] - 1}]
8126 set diffinhdr 0
8127
8128 } elseif {![string compare -length 10 "Submodule " $line]} {
8129 # start of a new submodule
8130 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8131 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8132 } else {
8133 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8134 }
8135 if {$currdiffsubmod != $fname} {
8136 $ctext insert end "\n"; # Add newline after commit message
8137 }
8138 set curdiffstart [$ctext index "end - 1c"]
8139 lappend ctext_file_names ""
8140 if {$currdiffsubmod != $fname} {
8141 lappend ctext_file_lines $fname
8142 makediffhdr $fname $ids
8143 set currdiffsubmod $fname
8144 $ctext insert end "\n$line\n" filesep
8145 } else {
8146 $ctext insert end "$line\n" filesep
8147 }
8148 } elseif {![string compare -length 3 " >" $line]} {
8149 set $currdiffsubmod ""
8150 set line [encoding convertfrom $diffencoding $line]
8151 $ctext insert end "$line\n" dresult
8152 } elseif {![string compare -length 3 " <" $line]} {
8153 set $currdiffsubmod ""
8154 set line [encoding convertfrom $diffencoding $line]
8155 $ctext insert end "$line\n" d0
8156 } elseif {$diffinhdr} {
8157 if {![string compare -length 12 "rename from " $line]} {
8158 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8159 if {[string index $fname 0] eq "\""} {
8160 set fname [lindex $fname 0]
8161 }
8162 set fname [encoding convertfrom $fname]
8163 set i [lsearch -exact $treediffs($ids) $fname]
8164 if {$i >= 0} {
8165 setinlist difffilestart $i $curdiffstart
8166 }
8167 } elseif {![string compare -length 10 $line "rename to "] ||
8168 ![string compare -length 8 $line "copy to "]} {
8169 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8170 if {[string index $fname 0] eq "\""} {
8171 set fname [lindex $fname 0]
8172 }
8173 makediffhdr $fname $ids
8174 } elseif {[string compare -length 3 $line "---"] == 0} {
8175 # do nothing
8176 return
8177 } elseif {[string compare -length 3 $line "+++"] == 0} {
8178 set diffinhdr 0
8179 return
8180 }
8181 $ctext insert end "$line\n" filesep
8182
8183 } else {
8184 set line [string map {\x1A ^Z} \
8185 [encoding convertfrom $diffencoding $line]]
8186 # parse the prefix - one ' ', '-' or '+' for each parent
8187 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8188 set tag [expr {$diffnparents > 1? "m": "d"}]
8189 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8190 set words_pre_markup ""
8191 set words_post_markup ""
8192 if {[string trim $prefix " -+"] eq {}} {
8193 # prefix only has " ", "-" and "+" in it: normal diff line
8194 set num [string first "-" $prefix]
8195 if {$dowords} {
8196 set line [string range $line 1 end]
8197 }
8198 if {$num >= 0} {
8199 # removed line, first parent with line is $num
8200 if {$num >= $mergemax} {
8201 set num "max"
8202 }
8203 if {$dowords && $worddiff eq [mc "Markup words"]} {
8204 $ctext insert end "\[-$line-\]" $tag$num
8205 } else {
8206 $ctext insert end "$line" $tag$num
8207 }
8208 if {!$dowords} {
8209 $ctext insert end "\n" $tag$num
8210 }
8211 } else {
8212 set tags {}
8213 if {[string first "+" $prefix] >= 0} {
8214 # added line
8215 lappend tags ${tag}result
8216 if {$diffnparents > 1} {
8217 set num [string first " " $prefix]
8218 if {$num >= 0} {
8219 if {$num >= $mergemax} {
8220 set num "max"
8221 }
8222 lappend tags m$num
8223 }
8224 }
8225 set words_pre_markup "{+"
8226 set words_post_markup "+}"
8227 }
8228 if {$targetline ne {}} {
8229 if {$diffline == $targetline} {
8230 set diffseehere [$ctext index "end - 1 chars"]
8231 set targetline {}
8232 } else {
8233 incr diffline
8234 }
8235 }
8236 if {$dowords && $worddiff eq [mc "Markup words"]} {
8237 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8238 } else {
8239 $ctext insert end "$line" $tags
8240 }
8241 if {!$dowords} {
8242 $ctext insert end "\n" $tags
8243 }
8244 }
8245 } elseif {$dowords && $prefix eq "~"} {
8246 $ctext insert end "\n" {}
8247 } else {
8248 # "\ No newline at end of file",
8249 # or something else we don't recognize
8250 $ctext insert end "$line\n" hunksep
8251 }
8252 }
8253}
8254
8255proc changediffdisp {} {
8256 global ctext diffelide
8257
8258 $ctext tag conf d0 -elide [lindex $diffelide 0]
8259 $ctext tag conf dresult -elide [lindex $diffelide 1]
8260}
8261
8262proc highlightfile {cline} {
8263 global cflist cflist_top
8264
8265 if {![info exists cflist_top]} return
8266
8267 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8268 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8269 $cflist see $cline.0
8270 set cflist_top $cline
8271}
8272
8273proc highlightfile_for_scrollpos {topidx} {
8274 global cmitmode difffilestart
8275
8276 if {$cmitmode eq "tree"} return
8277 if {![info exists difffilestart]} return
8278
8279 set top [lindex [split $topidx .] 0]
8280 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8281 highlightfile 0
8282 } else {
8283 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8284 }
8285}
8286
8287proc prevfile {} {
8288 global difffilestart ctext cmitmode
8289
8290 if {$cmitmode eq "tree"} return
8291 set prev 0.0
8292 set here [$ctext index @0,0]
8293 foreach loc $difffilestart {
8294 if {[$ctext compare $loc >= $here]} {
8295 $ctext yview $prev
8296 return
8297 }
8298 set prev $loc
8299 }
8300 $ctext yview $prev
8301}
8302
8303proc nextfile {} {
8304 global difffilestart ctext cmitmode
8305
8306 if {$cmitmode eq "tree"} return
8307 set here [$ctext index @0,0]
8308 foreach loc $difffilestart {
8309 if {[$ctext compare $loc > $here]} {
8310 $ctext yview $loc
8311 return
8312 }
8313 }
8314}
8315
8316proc clear_ctext {{first 1.0}} {
8317 global ctext smarktop smarkbot
8318 global ctext_file_names ctext_file_lines
8319 global pendinglinks
8320
8321 set l [lindex [split $first .] 0]
8322 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8323 set smarktop $l
8324 }
8325 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8326 set smarkbot $l
8327 }
8328 $ctext delete $first end
8329 if {$first eq "1.0"} {
8330 unset -nocomplain pendinglinks
8331 }
8332 set ctext_file_names {}
8333 set ctext_file_lines {}
8334}
8335
8336proc settabs {{firstab {}}} {
8337 global firsttabstop tabstop ctext have_tk85
8338
8339 if {$firstab ne {} && $have_tk85} {
8340 set firsttabstop $firstab
8341 }
8342 set w [font measure textfont "0"]
8343 if {$firsttabstop != 0} {
8344 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8345 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8346 } elseif {$have_tk85 || $tabstop != 8} {
8347 $ctext conf -tabs [expr {$tabstop * $w}]
8348 } else {
8349 $ctext conf -tabs {}
8350 }
8351}
8352
8353proc incrsearch {name ix op} {
8354 global ctext searchstring searchdirn
8355
8356 if {[catch {$ctext index anchor}]} {
8357 # no anchor set, use start of selection, or of visible area
8358 set sel [$ctext tag ranges sel]
8359 if {$sel ne {}} {
8360 $ctext mark set anchor [lindex $sel 0]
8361 } elseif {$searchdirn eq "-forwards"} {
8362 $ctext mark set anchor @0,0
8363 } else {
8364 $ctext mark set anchor @0,[winfo height $ctext]
8365 }
8366 }
8367 if {$searchstring ne {}} {
8368 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8369 if {$here ne {}} {
8370 $ctext see $here
8371 set mend "$here + $mlen c"
8372 $ctext tag remove sel 1.0 end
8373 $ctext tag add sel $here $mend
8374 suppress_highlighting_file_for_current_scrollpos
8375 highlightfile_for_scrollpos $here
8376 }
8377 }
8378 rehighlight_search_results
8379}
8380
8381proc dosearch {} {
8382 global sstring ctext searchstring searchdirn
8383
8384 focus $sstring
8385 $sstring icursor end
8386 set searchdirn -forwards
8387 if {$searchstring ne {}} {
8388 set sel [$ctext tag ranges sel]
8389 if {$sel ne {}} {
8390 set start "[lindex $sel 0] + 1c"
8391 } elseif {[catch {set start [$ctext index anchor]}]} {
8392 set start "@0,0"
8393 }
8394 set match [$ctext search -count mlen -- $searchstring $start]
8395 $ctext tag remove sel 1.0 end
8396 if {$match eq {}} {
8397 bell
8398 return
8399 }
8400 $ctext see $match
8401 suppress_highlighting_file_for_current_scrollpos
8402 highlightfile_for_scrollpos $match
8403 set mend "$match + $mlen c"
8404 $ctext tag add sel $match $mend
8405 $ctext mark unset anchor
8406 rehighlight_search_results
8407 }
8408}
8409
8410proc dosearchback {} {
8411 global sstring ctext searchstring searchdirn
8412
8413 focus $sstring
8414 $sstring icursor end
8415 set searchdirn -backwards
8416 if {$searchstring ne {}} {
8417 set sel [$ctext tag ranges sel]
8418 if {$sel ne {}} {
8419 set start [lindex $sel 0]
8420 } elseif {[catch {set start [$ctext index anchor]}]} {
8421 set start @0,[winfo height $ctext]
8422 }
8423 set match [$ctext search -backwards -count ml -- $searchstring $start]
8424 $ctext tag remove sel 1.0 end
8425 if {$match eq {}} {
8426 bell
8427 return
8428 }
8429 $ctext see $match
8430 suppress_highlighting_file_for_current_scrollpos
8431 highlightfile_for_scrollpos $match
8432 set mend "$match + $ml c"
8433 $ctext tag add sel $match $mend
8434 $ctext mark unset anchor
8435 rehighlight_search_results
8436 }
8437}
8438
8439proc rehighlight_search_results {} {
8440 global ctext searchstring
8441
8442 $ctext tag remove found 1.0 end
8443 $ctext tag remove currentsearchhit 1.0 end
8444
8445 if {$searchstring ne {}} {
8446 searchmarkvisible 1
8447 }
8448}
8449
8450proc searchmark {first last} {
8451 global ctext searchstring
8452
8453 set sel [$ctext tag ranges sel]
8454
8455 set mend $first.0
8456 while {1} {
8457 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8458 if {$match eq {}} break
8459 set mend "$match + $mlen c"
8460 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8461 $ctext tag add currentsearchhit $match $mend
8462 } else {
8463 $ctext tag add found $match $mend
8464 }
8465 }
8466}
8467
8468proc searchmarkvisible {doall} {
8469 global ctext smarktop smarkbot
8470
8471 set topline [lindex [split [$ctext index @0,0] .] 0]
8472 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8473 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8474 # no overlap with previous
8475 searchmark $topline $botline
8476 set smarktop $topline
8477 set smarkbot $botline
8478 } else {
8479 if {$topline < $smarktop} {
8480 searchmark $topline [expr {$smarktop-1}]
8481 set smarktop $topline
8482 }
8483 if {$botline > $smarkbot} {
8484 searchmark [expr {$smarkbot+1}] $botline
8485 set smarkbot $botline
8486 }
8487 }
8488}
8489
8490proc suppress_highlighting_file_for_current_scrollpos {} {
8491 global ctext suppress_highlighting_file_for_this_scrollpos
8492
8493 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8494}
8495
8496proc scrolltext {f0 f1} {
8497 global searchstring cmitmode ctext
8498 global suppress_highlighting_file_for_this_scrollpos
8499
8500 set topidx [$ctext index @0,0]
8501 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8502 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8503 highlightfile_for_scrollpos $topidx
8504 }
8505
8506 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8507
8508 .bleft.bottom.sb set $f0 $f1
8509 if {$searchstring ne {}} {
8510 searchmarkvisible 0
8511 }
8512}
8513
8514proc setcoords {} {
8515 global linespc charspc canvx0 canvy0
8516 global xspc1 xspc2 lthickness
8517
8518 set linespc [font metrics mainfont -linespace]
8519 set charspc [font measure mainfont "m"]
8520 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8521 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8522 set lthickness [expr {int($linespc / 9) + 1}]
8523 set xspc1(0) $linespc
8524 set xspc2 $linespc
8525}
8526
8527proc redisplay {} {
8528 global canv
8529 global selectedline
8530
8531 set ymax [lindex [$canv cget -scrollregion] 3]
8532 if {$ymax eq {} || $ymax == 0} return
8533 set span [$canv yview]
8534 clear_display
8535 setcanvscroll
8536 allcanvs yview moveto [lindex $span 0]
8537 drawvisible
8538 if {$selectedline ne {}} {
8539 selectline $selectedline 0
8540 allcanvs yview moveto [lindex $span 0]
8541 }
8542}
8543
8544proc parsefont {f n} {
8545 global fontattr
8546
8547 set fontattr($f,family) [lindex $n 0]
8548 set s [lindex $n 1]
8549 if {$s eq {} || $s == 0} {
8550 set s 10
8551 } elseif {$s < 0} {
8552 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8553 }
8554 set fontattr($f,size) $s
8555 set fontattr($f,weight) normal
8556 set fontattr($f,slant) roman
8557 foreach style [lrange $n 2 end] {
8558 switch -- $style {
8559 "normal" -
8560 "bold" {set fontattr($f,weight) $style}
8561 "roman" -
8562 "italic" {set fontattr($f,slant) $style}
8563 }
8564 }
8565}
8566
8567proc fontflags {f {isbold 0}} {
8568 global fontattr
8569
8570 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8571 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8572 -slant $fontattr($f,slant)]
8573}
8574
8575proc fontname {f} {
8576 global fontattr
8577
8578 set n [list $fontattr($f,family) $fontattr($f,size)]
8579 if {$fontattr($f,weight) eq "bold"} {
8580 lappend n "bold"
8581 }
8582 if {$fontattr($f,slant) eq "italic"} {
8583 lappend n "italic"
8584 }
8585 return $n
8586}
8587
8588proc incrfont {inc} {
8589 global mainfont textfont ctext canv cflist showrefstop
8590 global stopped entries fontattr
8591
8592 unmarkmatches
8593 set s $fontattr(mainfont,size)
8594 incr s $inc
8595 if {$s < 1} {
8596 set s 1
8597 }
8598 set fontattr(mainfont,size) $s
8599 font config mainfont -size $s
8600 font config mainfontbold -size $s
8601 set mainfont [fontname mainfont]
8602 set s $fontattr(textfont,size)
8603 incr s $inc
8604 if {$s < 1} {
8605 set s 1
8606 }
8607 set fontattr(textfont,size) $s
8608 font config textfont -size $s
8609 font config textfontbold -size $s
8610 set textfont [fontname textfont]
8611 setcoords
8612 settabs
8613 redisplay
8614}
8615
8616proc clearsha1 {} {
8617 global sha1entry sha1string
8618 if {[string length $sha1string] == 40} {
8619 $sha1entry delete 0 end
8620 }
8621}
8622
8623proc sha1change {n1 n2 op} {
8624 global sha1string currentid sha1but
8625 if {$sha1string == {}
8626 || ([info exists currentid] && $sha1string == $currentid)} {
8627 set state disabled
8628 } else {
8629 set state normal
8630 }
8631 if {[$sha1but cget -state] == $state} return
8632 if {$state == "normal"} {
8633 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8634 } else {
8635 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8636 }
8637}
8638
8639proc gotocommit {} {
8640 global sha1string tagids headids curview varcid
8641
8642 if {$sha1string == {}
8643 || ([info exists currentid] && $sha1string == $currentid)} return
8644 if {[info exists tagids($sha1string)]} {
8645 set id $tagids($sha1string)
8646 } elseif {[info exists headids($sha1string)]} {
8647 set id $headids($sha1string)
8648 } else {
8649 set id [string tolower $sha1string]
8650 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8651 set matches [longid $id]
8652 if {$matches ne {}} {
8653 if {[llength $matches] > 1} {
8654 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8655 return
8656 }
8657 set id [lindex $matches 0]
8658 }
8659 } else {
8660 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8661 error_popup [mc "Revision %s is not known" $sha1string]
8662 return
8663 }
8664 }
8665 }
8666 if {[commitinview $id $curview]} {
8667 selectline [rowofcommit $id] 1
8668 return
8669 }
8670 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8671 set msg [mc "SHA1 id %s is not known" $sha1string]
8672 } else {
8673 set msg [mc "Revision %s is not in the current view" $sha1string]
8674 }
8675 error_popup $msg
8676}
8677
8678proc lineenter {x y id} {
8679 global hoverx hovery hoverid hovertimer
8680 global commitinfo canv
8681
8682 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8683 set hoverx $x
8684 set hovery $y
8685 set hoverid $id
8686 if {[info exists hovertimer]} {
8687 after cancel $hovertimer
8688 }
8689 set hovertimer [after 500 linehover]
8690 $canv delete hover
8691}
8692
8693proc linemotion {x y id} {
8694 global hoverx hovery hoverid hovertimer
8695
8696 if {[info exists hoverid] && $id == $hoverid} {
8697 set hoverx $x
8698 set hovery $y
8699 if {[info exists hovertimer]} {
8700 after cancel $hovertimer
8701 }
8702 set hovertimer [after 500 linehover]
8703 }
8704}
8705
8706proc lineleave {id} {
8707 global hoverid hovertimer canv
8708
8709 if {[info exists hoverid] && $id == $hoverid} {
8710 $canv delete hover
8711 if {[info exists hovertimer]} {
8712 after cancel $hovertimer
8713 unset hovertimer
8714 }
8715 unset hoverid
8716 }
8717}
8718
8719proc linehover {} {
8720 global hoverx hovery hoverid hovertimer
8721 global canv linespc lthickness
8722 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8723
8724 global commitinfo
8725
8726 set text [lindex $commitinfo($hoverid) 0]
8727 set ymax [lindex [$canv cget -scrollregion] 3]
8728 if {$ymax == {}} return
8729 set yfrac [lindex [$canv yview] 0]
8730 set x [expr {$hoverx + 2 * $linespc}]
8731 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8732 set x0 [expr {$x - 2 * $lthickness}]
8733 set y0 [expr {$y - 2 * $lthickness}]
8734 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8735 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8736 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8737 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8738 -width 1 -tags hover]
8739 $canv raise $t
8740 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8741 -font mainfont -fill $linehoverfgcolor]
8742 $canv raise $t
8743}
8744
8745proc clickisonarrow {id y} {
8746 global lthickness
8747
8748 set ranges [rowranges $id]
8749 set thresh [expr {2 * $lthickness + 6}]
8750 set n [expr {[llength $ranges] - 1}]
8751 for {set i 1} {$i < $n} {incr i} {
8752 set row [lindex $ranges $i]
8753 if {abs([yc $row] - $y) < $thresh} {
8754 return $i
8755 }
8756 }
8757 return {}
8758}
8759
8760proc arrowjump {id n y} {
8761 global canv
8762
8763 # 1 <-> 2, 3 <-> 4, etc...
8764 set n [expr {(($n - 1) ^ 1) + 1}]
8765 set row [lindex [rowranges $id] $n]
8766 set yt [yc $row]
8767 set ymax [lindex [$canv cget -scrollregion] 3]
8768 if {$ymax eq {} || $ymax <= 0} return
8769 set view [$canv yview]
8770 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8771 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8772 if {$yfrac < 0} {
8773 set yfrac 0
8774 }
8775 allcanvs yview moveto $yfrac
8776}
8777
8778proc lineclick {x y id isnew} {
8779 global ctext commitinfo children canv thickerline curview
8780
8781 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8782 unmarkmatches
8783 unselectline
8784 normalline
8785 $canv delete hover
8786 # draw this line thicker than normal
8787 set thickerline $id
8788 drawlines $id
8789 if {$isnew} {
8790 set ymax [lindex [$canv cget -scrollregion] 3]
8791 if {$ymax eq {}} return
8792 set yfrac [lindex [$canv yview] 0]
8793 set y [expr {$y + $yfrac * $ymax}]
8794 }
8795 set dirn [clickisonarrow $id $y]
8796 if {$dirn ne {}} {
8797 arrowjump $id $dirn $y
8798 return
8799 }
8800
8801 if {$isnew} {
8802 addtohistory [list lineclick $x $y $id 0] savectextpos
8803 }
8804 # fill the details pane with info about this line
8805 $ctext conf -state normal
8806 clear_ctext
8807 settabs 0
8808 $ctext insert end "[mc "Parent"]:\t"
8809 $ctext insert end $id link0
8810 setlink $id link0
8811 set info $commitinfo($id)
8812 $ctext insert end "\n\t[lindex $info 0]\n"
8813 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8814 set date [formatdate [lindex $info 2]]
8815 $ctext insert end "\t[mc "Date"]:\t$date\n"
8816 set kids $children($curview,$id)
8817 if {$kids ne {}} {
8818 $ctext insert end "\n[mc "Children"]:"
8819 set i 0
8820 foreach child $kids {
8821 incr i
8822 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8823 set info $commitinfo($child)
8824 $ctext insert end "\n\t"
8825 $ctext insert end $child link$i
8826 setlink $child link$i
8827 $ctext insert end "\n\t[lindex $info 0]"
8828 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8829 set date [formatdate [lindex $info 2]]
8830 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8831 }
8832 }
8833 maybe_scroll_ctext 1
8834 $ctext conf -state disabled
8835 init_flist {}
8836}
8837
8838proc normalline {} {
8839 global thickerline
8840 if {[info exists thickerline]} {
8841 set id $thickerline
8842 unset thickerline
8843 drawlines $id
8844 }
8845}
8846
8847proc selbyid {id {isnew 1}} {
8848 global curview
8849 if {[commitinview $id $curview]} {
8850 selectline [rowofcommit $id] $isnew
8851 }
8852}
8853
8854proc mstime {} {
8855 global startmstime
8856 if {![info exists startmstime]} {
8857 set startmstime [clock clicks -milliseconds]
8858 }
8859 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8860}
8861
8862proc rowmenu {x y id} {
8863 global rowctxmenu selectedline rowmenuid curview
8864 global nullid nullid2 fakerowmenu mainhead markedid
8865
8866 stopfinding
8867 set rowmenuid $id
8868 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8869 set state disabled
8870 } else {
8871 set state normal
8872 }
8873 if {[info exists markedid] && $markedid ne $id} {
8874 set mstate normal
8875 } else {
8876 set mstate disabled
8877 }
8878 if {$id ne $nullid && $id ne $nullid2} {
8879 set menu $rowctxmenu
8880 if {$mainhead ne {}} {
8881 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8882 } else {
8883 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8884 }
8885 $menu entryconfigure 9 -state $mstate
8886 $menu entryconfigure 10 -state $mstate
8887 $menu entryconfigure 11 -state $mstate
8888 } else {
8889 set menu $fakerowmenu
8890 }
8891 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8892 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8893 $menu entryconfigure [mca "Make patch"] -state $state
8894 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8895 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8896 tk_popup $menu $x $y
8897}
8898
8899proc markhere {} {
8900 global rowmenuid markedid canv
8901
8902 set markedid $rowmenuid
8903 make_idmark $markedid
8904}
8905
8906proc gotomark {} {
8907 global markedid
8908
8909 if {[info exists markedid]} {
8910 selbyid $markedid
8911 }
8912}
8913
8914proc replace_by_kids {l r} {
8915 global curview children
8916
8917 set id [commitonrow $r]
8918 set l [lreplace $l 0 0]
8919 foreach kid $children($curview,$id) {
8920 lappend l [rowofcommit $kid]
8921 }
8922 return [lsort -integer -decreasing -unique $l]
8923}
8924
8925proc find_common_desc {} {
8926 global markedid rowmenuid curview children
8927
8928 if {![info exists markedid]} return
8929 if {![commitinview $markedid $curview] ||
8930 ![commitinview $rowmenuid $curview]} return
8931 #set t1 [clock clicks -milliseconds]
8932 set l1 [list [rowofcommit $markedid]]
8933 set l2 [list [rowofcommit $rowmenuid]]
8934 while 1 {
8935 set r1 [lindex $l1 0]
8936 set r2 [lindex $l2 0]
8937 if {$r1 eq {} || $r2 eq {}} break
8938 if {$r1 == $r2} {
8939 selectline $r1 1
8940 break
8941 }
8942 if {$r1 > $r2} {
8943 set l1 [replace_by_kids $l1 $r1]
8944 } else {
8945 set l2 [replace_by_kids $l2 $r2]
8946 }
8947 }
8948 #set t2 [clock clicks -milliseconds]
8949 #puts "took [expr {$t2-$t1}]ms"
8950}
8951
8952proc compare_commits {} {
8953 global markedid rowmenuid curview children
8954
8955 if {![info exists markedid]} return
8956 if {![commitinview $markedid $curview]} return
8957 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8958 do_cmp_commits $markedid $rowmenuid
8959}
8960
8961proc getpatchid {id} {
8962 global patchids
8963
8964 if {![info exists patchids($id)]} {
8965 set cmd [diffcmd [list $id] {-p --root}]
8966 # trim off the initial "|"
8967 set cmd [lrange $cmd 1 end]
8968 if {[catch {
8969 set x [eval exec $cmd | git patch-id]
8970 set patchids($id) [lindex $x 0]
8971 }]} {
8972 set patchids($id) "error"
8973 }
8974 }
8975 return $patchids($id)
8976}
8977
8978proc do_cmp_commits {a b} {
8979 global ctext curview parents children patchids commitinfo
8980
8981 $ctext conf -state normal
8982 clear_ctext
8983 init_flist {}
8984 for {set i 0} {$i < 100} {incr i} {
8985 set skipa 0
8986 set skipb 0
8987 if {[llength $parents($curview,$a)] > 1} {
8988 appendshortlink $a [mc "Skipping merge commit "] "\n"
8989 set skipa 1
8990 } else {
8991 set patcha [getpatchid $a]
8992 }
8993 if {[llength $parents($curview,$b)] > 1} {
8994 appendshortlink $b [mc "Skipping merge commit "] "\n"
8995 set skipb 1
8996 } else {
8997 set patchb [getpatchid $b]
8998 }
8999 if {!$skipa && !$skipb} {
9000 set heada [lindex $commitinfo($a) 0]
9001 set headb [lindex $commitinfo($b) 0]
9002 if {$patcha eq "error"} {
9003 appendshortlink $a [mc "Error getting patch ID for "] \
9004 [mc " - stopping\n"]
9005 break
9006 }
9007 if {$patchb eq "error"} {
9008 appendshortlink $b [mc "Error getting patch ID for "] \
9009 [mc " - stopping\n"]
9010 break
9011 }
9012 if {$patcha eq $patchb} {
9013 if {$heada eq $headb} {
9014 appendshortlink $a [mc "Commit "]
9015 appendshortlink $b " == " " $heada\n"
9016 } else {
9017 appendshortlink $a [mc "Commit "] " $heada\n"
9018 appendshortlink $b [mc " is the same patch as\n "] \
9019 " $headb\n"
9020 }
9021 set skipa 1
9022 set skipb 1
9023 } else {
9024 $ctext insert end "\n"
9025 appendshortlink $a [mc "Commit "] " $heada\n"
9026 appendshortlink $b [mc " differs from\n "] \
9027 " $headb\n"
9028 $ctext insert end [mc "Diff of commits:\n\n"]
9029 $ctext conf -state disabled
9030 update
9031 diffcommits $a $b
9032 return
9033 }
9034 }
9035 if {$skipa} {
9036 set kids [real_children $curview,$a]
9037 if {[llength $kids] != 1} {
9038 $ctext insert end "\n"
9039 appendshortlink $a [mc "Commit "] \
9040 [mc " has %s children - stopping\n" [llength $kids]]
9041 break
9042 }
9043 set a [lindex $kids 0]
9044 }
9045 if {$skipb} {
9046 set kids [real_children $curview,$b]
9047 if {[llength $kids] != 1} {
9048 appendshortlink $b [mc "Commit "] \
9049 [mc " has %s children - stopping\n" [llength $kids]]
9050 break
9051 }
9052 set b [lindex $kids 0]
9053 }
9054 }
9055 $ctext conf -state disabled
9056}
9057
9058proc diffcommits {a b} {
9059 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9060
9061 set tmpdir [gitknewtmpdir]
9062 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9063 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9064 if {[catch {
9065 exec git diff-tree -p --pretty $a >$fna
9066 exec git diff-tree -p --pretty $b >$fnb
9067 } err]} {
9068 error_popup [mc "Error writing commit to file: %s" $err]
9069 return
9070 }
9071 if {[catch {
9072 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9073 } err]} {
9074 error_popup [mc "Error diffing commits: %s" $err]
9075 return
9076 }
9077 set diffids [list commits $a $b]
9078 set blobdifffd($diffids) $fd
9079 set diffinhdr 0
9080 set currdiffsubmod ""
9081 filerun $fd [list getblobdiffline $fd $diffids]
9082}
9083
9084proc diffvssel {dirn} {
9085 global rowmenuid selectedline
9086
9087 if {$selectedline eq {}} return
9088 if {$dirn} {
9089 set oldid [commitonrow $selectedline]
9090 set newid $rowmenuid
9091 } else {
9092 set oldid $rowmenuid
9093 set newid [commitonrow $selectedline]
9094 }
9095 addtohistory [list doseldiff $oldid $newid] savectextpos
9096 doseldiff $oldid $newid
9097}
9098
9099proc diffvsmark {dirn} {
9100 global rowmenuid markedid
9101
9102 if {![info exists markedid]} return
9103 if {$dirn} {
9104 set oldid $markedid
9105 set newid $rowmenuid
9106 } else {
9107 set oldid $rowmenuid
9108 set newid $markedid
9109 }
9110 addtohistory [list doseldiff $oldid $newid] savectextpos
9111 doseldiff $oldid $newid
9112}
9113
9114proc doseldiff {oldid newid} {
9115 global ctext
9116 global commitinfo
9117
9118 $ctext conf -state normal
9119 clear_ctext
9120 init_flist [mc "Top"]
9121 $ctext insert end "[mc "From"] "
9122 $ctext insert end $oldid link0
9123 setlink $oldid link0
9124 $ctext insert end "\n "
9125 $ctext insert end [lindex $commitinfo($oldid) 0]
9126 $ctext insert end "\n\n[mc "To"] "
9127 $ctext insert end $newid link1
9128 setlink $newid link1
9129 $ctext insert end "\n "
9130 $ctext insert end [lindex $commitinfo($newid) 0]
9131 $ctext insert end "\n"
9132 $ctext conf -state disabled
9133 $ctext tag remove found 1.0 end
9134 startdiff [list $oldid $newid]
9135}
9136
9137proc mkpatch {} {
9138 global rowmenuid currentid commitinfo patchtop patchnum NS
9139
9140 if {![info exists currentid]} return
9141 set oldid $currentid
9142 set oldhead [lindex $commitinfo($oldid) 0]
9143 set newid $rowmenuid
9144 set newhead [lindex $commitinfo($newid) 0]
9145 set top .patch
9146 set patchtop $top
9147 catch {destroy $top}
9148 ttk_toplevel $top
9149 make_transient $top .
9150 ${NS}::label $top.title -text [mc "Generate patch"]
9151 grid $top.title - -pady 10
9152 ${NS}::label $top.from -text [mc "From:"]
9153 ${NS}::entry $top.fromsha1 -width 40
9154 $top.fromsha1 insert 0 $oldid
9155 $top.fromsha1 conf -state readonly
9156 grid $top.from $top.fromsha1 -sticky w
9157 ${NS}::entry $top.fromhead -width 60
9158 $top.fromhead insert 0 $oldhead
9159 $top.fromhead conf -state readonly
9160 grid x $top.fromhead -sticky w
9161 ${NS}::label $top.to -text [mc "To:"]
9162 ${NS}::entry $top.tosha1 -width 40
9163 $top.tosha1 insert 0 $newid
9164 $top.tosha1 conf -state readonly
9165 grid $top.to $top.tosha1 -sticky w
9166 ${NS}::entry $top.tohead -width 60
9167 $top.tohead insert 0 $newhead
9168 $top.tohead conf -state readonly
9169 grid x $top.tohead -sticky w
9170 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9171 grid $top.rev x -pady 10 -padx 5
9172 ${NS}::label $top.flab -text [mc "Output file:"]
9173 ${NS}::entry $top.fname -width 60
9174 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9175 incr patchnum
9176 grid $top.flab $top.fname -sticky w
9177 ${NS}::frame $top.buts
9178 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9179 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9180 bind $top <Key-Return> mkpatchgo
9181 bind $top <Key-Escape> mkpatchcan
9182 grid $top.buts.gen $top.buts.can
9183 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9184 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9185 grid $top.buts - -pady 10 -sticky ew
9186 focus $top.fname
9187}
9188
9189proc mkpatchrev {} {
9190 global patchtop
9191
9192 set oldid [$patchtop.fromsha1 get]
9193 set oldhead [$patchtop.fromhead get]
9194 set newid [$patchtop.tosha1 get]
9195 set newhead [$patchtop.tohead get]
9196 foreach e [list fromsha1 fromhead tosha1 tohead] \
9197 v [list $newid $newhead $oldid $oldhead] {
9198 $patchtop.$e conf -state normal
9199 $patchtop.$e delete 0 end
9200 $patchtop.$e insert 0 $v
9201 $patchtop.$e conf -state readonly
9202 }
9203}
9204
9205proc mkpatchgo {} {
9206 global patchtop nullid nullid2
9207
9208 set oldid [$patchtop.fromsha1 get]
9209 set newid [$patchtop.tosha1 get]
9210 set fname [$patchtop.fname get]
9211 set cmd [diffcmd [list $oldid $newid] -p]
9212 # trim off the initial "|"
9213 set cmd [lrange $cmd 1 end]
9214 lappend cmd >$fname &
9215 if {[catch {eval exec $cmd} err]} {
9216 error_popup "[mc "Error creating patch:"] $err" $patchtop
9217 }
9218 catch {destroy $patchtop}
9219 unset patchtop
9220}
9221
9222proc mkpatchcan {} {
9223 global patchtop
9224
9225 catch {destroy $patchtop}
9226 unset patchtop
9227}
9228
9229proc mktag {} {
9230 global rowmenuid mktagtop commitinfo NS
9231
9232 set top .maketag
9233 set mktagtop $top
9234 catch {destroy $top}
9235 ttk_toplevel $top
9236 make_transient $top .
9237 ${NS}::label $top.title -text [mc "Create tag"]
9238 grid $top.title - -pady 10
9239 ${NS}::label $top.id -text [mc "ID:"]
9240 ${NS}::entry $top.sha1 -width 40
9241 $top.sha1 insert 0 $rowmenuid
9242 $top.sha1 conf -state readonly
9243 grid $top.id $top.sha1 -sticky w
9244 ${NS}::entry $top.head -width 60
9245 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9246 $top.head conf -state readonly
9247 grid x $top.head -sticky w
9248 ${NS}::label $top.tlab -text [mc "Tag name:"]
9249 ${NS}::entry $top.tag -width 60
9250 grid $top.tlab $top.tag -sticky w
9251 ${NS}::label $top.op -text [mc "Tag message is optional"]
9252 grid $top.op -columnspan 2 -sticky we
9253 ${NS}::label $top.mlab -text [mc "Tag message:"]
9254 ${NS}::entry $top.msg -width 60
9255 grid $top.mlab $top.msg -sticky w
9256 ${NS}::frame $top.buts
9257 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9258 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9259 bind $top <Key-Return> mktaggo
9260 bind $top <Key-Escape> mktagcan
9261 grid $top.buts.gen $top.buts.can
9262 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9263 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9264 grid $top.buts - -pady 10 -sticky ew
9265 focus $top.tag
9266}
9267
9268proc domktag {} {
9269 global mktagtop env tagids idtags
9270
9271 set id [$mktagtop.sha1 get]
9272 set tag [$mktagtop.tag get]
9273 set msg [$mktagtop.msg get]
9274 if {$tag == {}} {
9275 error_popup [mc "No tag name specified"] $mktagtop
9276 return 0
9277 }
9278 if {[info exists tagids($tag)]} {
9279 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9280 return 0
9281 }
9282 if {[catch {
9283 if {$msg != {}} {
9284 exec git tag -a -m $msg $tag $id
9285 } else {
9286 exec git tag $tag $id
9287 }
9288 } err]} {
9289 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9290 return 0
9291 }
9292
9293 set tagids($tag) $id
9294 lappend idtags($id) $tag
9295 redrawtags $id
9296 addedtag $id
9297 dispneartags 0
9298 run refill_reflist
9299 return 1
9300}
9301
9302proc redrawtags {id} {
9303 global canv linehtag idpos currentid curview cmitlisted markedid
9304 global canvxmax iddrawn circleitem mainheadid circlecolors
9305 global mainheadcirclecolor
9306
9307 if {![commitinview $id $curview]} return
9308 if {![info exists iddrawn($id)]} return
9309 set row [rowofcommit $id]
9310 if {$id eq $mainheadid} {
9311 set ofill $mainheadcirclecolor
9312 } else {
9313 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9314 }
9315 $canv itemconf $circleitem($row) -fill $ofill
9316 $canv delete tag.$id
9317 set xt [eval drawtags $id $idpos($id)]
9318 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9319 set text [$canv itemcget $linehtag($id) -text]
9320 set font [$canv itemcget $linehtag($id) -font]
9321 set xr [expr {$xt + [font measure $font $text]}]
9322 if {$xr > $canvxmax} {
9323 set canvxmax $xr
9324 setcanvscroll
9325 }
9326 if {[info exists currentid] && $currentid == $id} {
9327 make_secsel $id
9328 }
9329 if {[info exists markedid] && $markedid eq $id} {
9330 make_idmark $id
9331 }
9332}
9333
9334proc mktagcan {} {
9335 global mktagtop
9336
9337 catch {destroy $mktagtop}
9338 unset mktagtop
9339}
9340
9341proc mktaggo {} {
9342 if {![domktag]} return
9343 mktagcan
9344}
9345
9346proc writecommit {} {
9347 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9348
9349 set top .writecommit
9350 set wrcomtop $top
9351 catch {destroy $top}
9352 ttk_toplevel $top
9353 make_transient $top .
9354 ${NS}::label $top.title -text [mc "Write commit to file"]
9355 grid $top.title - -pady 10
9356 ${NS}::label $top.id -text [mc "ID:"]
9357 ${NS}::entry $top.sha1 -width 40
9358 $top.sha1 insert 0 $rowmenuid
9359 $top.sha1 conf -state readonly
9360 grid $top.id $top.sha1 -sticky w
9361 ${NS}::entry $top.head -width 60
9362 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9363 $top.head conf -state readonly
9364 grid x $top.head -sticky w
9365 ${NS}::label $top.clab -text [mc "Command:"]
9366 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9367 grid $top.clab $top.cmd -sticky w -pady 10
9368 ${NS}::label $top.flab -text [mc "Output file:"]
9369 ${NS}::entry $top.fname -width 60
9370 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9371 grid $top.flab $top.fname -sticky w
9372 ${NS}::frame $top.buts
9373 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9374 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9375 bind $top <Key-Return> wrcomgo
9376 bind $top <Key-Escape> wrcomcan
9377 grid $top.buts.gen $top.buts.can
9378 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9379 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9380 grid $top.buts - -pady 10 -sticky ew
9381 focus $top.fname
9382}
9383
9384proc wrcomgo {} {
9385 global wrcomtop
9386
9387 set id [$wrcomtop.sha1 get]
9388 set cmd "echo $id | [$wrcomtop.cmd get]"
9389 set fname [$wrcomtop.fname get]
9390 if {[catch {exec sh -c $cmd >$fname &} err]} {
9391 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9392 }
9393 catch {destroy $wrcomtop}
9394 unset wrcomtop
9395}
9396
9397proc wrcomcan {} {
9398 global wrcomtop
9399
9400 catch {destroy $wrcomtop}
9401 unset wrcomtop
9402}
9403
9404proc mkbranch {} {
9405 global rowmenuid mkbrtop NS
9406
9407 set top .makebranch
9408 catch {destroy $top}
9409 ttk_toplevel $top
9410 make_transient $top .
9411 ${NS}::label $top.title -text [mc "Create new branch"]
9412 grid $top.title - -pady 10
9413 ${NS}::label $top.id -text [mc "ID:"]
9414 ${NS}::entry $top.sha1 -width 40
9415 $top.sha1 insert 0 $rowmenuid
9416 $top.sha1 conf -state readonly
9417 grid $top.id $top.sha1 -sticky w
9418 ${NS}::label $top.nlab -text [mc "Name:"]
9419 ${NS}::entry $top.name -width 40
9420 grid $top.nlab $top.name -sticky w
9421 ${NS}::frame $top.buts
9422 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9423 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9424 bind $top <Key-Return> [list mkbrgo $top]
9425 bind $top <Key-Escape> "catch {destroy $top}"
9426 grid $top.buts.go $top.buts.can
9427 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9428 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9429 grid $top.buts - -pady 10 -sticky ew
9430 focus $top.name
9431}
9432
9433proc mkbrgo {top} {
9434 global headids idheads
9435
9436 set name [$top.name get]
9437 set id [$top.sha1 get]
9438 set cmdargs {}
9439 set old_id {}
9440 if {$name eq {}} {
9441 error_popup [mc "Please specify a name for the new branch"] $top
9442 return
9443 }
9444 if {[info exists headids($name)]} {
9445 if {![confirm_popup [mc \
9446 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9447 return
9448 }
9449 set old_id $headids($name)
9450 lappend cmdargs -f
9451 }
9452 catch {destroy $top}
9453 lappend cmdargs $name $id
9454 nowbusy newbranch
9455 update
9456 if {[catch {
9457 eval exec git branch $cmdargs
9458 } err]} {
9459 notbusy newbranch
9460 error_popup $err
9461 } else {
9462 notbusy newbranch
9463 if {$old_id ne {}} {
9464 movehead $id $name
9465 movedhead $id $name
9466 redrawtags $old_id
9467 redrawtags $id
9468 } else {
9469 set headids($name) $id
9470 lappend idheads($id) $name
9471 addedhead $id $name
9472 redrawtags $id
9473 }
9474 dispneartags 0
9475 run refill_reflist
9476 }
9477}
9478
9479proc exec_citool {tool_args {baseid {}}} {
9480 global commitinfo env
9481
9482 set save_env [array get env GIT_AUTHOR_*]
9483
9484 if {$baseid ne {}} {
9485 if {![info exists commitinfo($baseid)]} {
9486 getcommit $baseid
9487 }
9488 set author [lindex $commitinfo($baseid) 1]
9489 set date [lindex $commitinfo($baseid) 2]
9490 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9491 $author author name email]
9492 && $date ne {}} {
9493 set env(GIT_AUTHOR_NAME) $name
9494 set env(GIT_AUTHOR_EMAIL) $email
9495 set env(GIT_AUTHOR_DATE) $date
9496 }
9497 }
9498
9499 eval exec git citool $tool_args &
9500
9501 array unset env GIT_AUTHOR_*
9502 array set env $save_env
9503}
9504
9505proc cherrypick {} {
9506 global rowmenuid curview
9507 global mainhead mainheadid
9508 global gitdir
9509
9510 set oldhead [exec git rev-parse HEAD]
9511 set dheads [descheads $rowmenuid]
9512 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9513 set ok [confirm_popup [mc "Commit %s is already\
9514 included in branch %s -- really re-apply it?" \
9515 [string range $rowmenuid 0 7] $mainhead]]
9516 if {!$ok} return
9517 }
9518 nowbusy cherrypick [mc "Cherry-picking"]
9519 update
9520 # Unfortunately git-cherry-pick writes stuff to stderr even when
9521 # no error occurs, and exec takes that as an indication of error...
9522 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9523 notbusy cherrypick
9524 if {[regexp -line \
9525 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9526 $err msg fname]} {
9527 error_popup [mc "Cherry-pick failed because of local changes\
9528 to file '%s'.\nPlease commit, reset or stash\
9529 your changes and try again." $fname]
9530 } elseif {[regexp -line \
9531 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9532 $err]} {
9533 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9534 conflict.\nDo you wish to run git citool to\
9535 resolve it?"]]} {
9536 # Force citool to read MERGE_MSG
9537 file delete [file join $gitdir "GITGUI_MSG"]
9538 exec_citool {} $rowmenuid
9539 }
9540 } else {
9541 error_popup $err
9542 }
9543 run updatecommits
9544 return
9545 }
9546 set newhead [exec git rev-parse HEAD]
9547 if {$newhead eq $oldhead} {
9548 notbusy cherrypick
9549 error_popup [mc "No changes committed"]
9550 return
9551 }
9552 addnewchild $newhead $oldhead
9553 if {[commitinview $oldhead $curview]} {
9554 # XXX this isn't right if we have a path limit...
9555 insertrow $newhead $oldhead $curview
9556 if {$mainhead ne {}} {
9557 movehead $newhead $mainhead
9558 movedhead $newhead $mainhead
9559 }
9560 set mainheadid $newhead
9561 redrawtags $oldhead
9562 redrawtags $newhead
9563 selbyid $newhead
9564 }
9565 notbusy cherrypick
9566}
9567
9568proc revert {} {
9569 global rowmenuid curview
9570 global mainhead mainheadid
9571 global gitdir
9572
9573 set oldhead [exec git rev-parse HEAD]
9574 set dheads [descheads $rowmenuid]
9575 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9576 set ok [confirm_popup [mc "Commit %s is not\
9577 included in branch %s -- really revert it?" \
9578 [string range $rowmenuid 0 7] $mainhead]]
9579 if {!$ok} return
9580 }
9581 nowbusy revert [mc "Reverting"]
9582 update
9583
9584 if [catch {exec git revert --no-edit $rowmenuid} err] {
9585 notbusy revert
9586 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9587 $err match files] {
9588 regsub {\n( |\t)+} $files "\n" files
9589 error_popup [mc "Revert failed because of local changes to\
9590 the following files:%s Please commit, reset or stash \
9591 your changes and try again." $files]
9592 } elseif [regexp {error: could not revert} $err] {
9593 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9594 Do you wish to run git citool to resolve it?"]] {
9595 # Force citool to read MERGE_MSG
9596 file delete [file join $gitdir "GITGUI_MSG"]
9597 exec_citool {} $rowmenuid
9598 }
9599 } else { error_popup $err }
9600 run updatecommits
9601 return
9602 }
9603
9604 set newhead [exec git rev-parse HEAD]
9605 if { $newhead eq $oldhead } {
9606 notbusy revert
9607 error_popup [mc "No changes committed"]
9608 return
9609 }
9610
9611 addnewchild $newhead $oldhead
9612
9613 if [commitinview $oldhead $curview] {
9614 # XXX this isn't right if we have a path limit...
9615 insertrow $newhead $oldhead $curview
9616 if {$mainhead ne {}} {
9617 movehead $newhead $mainhead
9618 movedhead $newhead $mainhead
9619 }
9620 set mainheadid $newhead
9621 redrawtags $oldhead
9622 redrawtags $newhead
9623 selbyid $newhead
9624 }
9625
9626 notbusy revert
9627}
9628
9629proc resethead {} {
9630 global mainhead rowmenuid confirm_ok resettype NS
9631
9632 set confirm_ok 0
9633 set w ".confirmreset"
9634 ttk_toplevel $w
9635 make_transient $w .
9636 wm title $w [mc "Confirm reset"]
9637 ${NS}::label $w.m -text \
9638 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9639 pack $w.m -side top -fill x -padx 20 -pady 20
9640 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9641 set resettype mixed
9642 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9643 -text [mc "Soft: Leave working tree and index untouched"]
9644 grid $w.f.soft -sticky w
9645 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9646 -text [mc "Mixed: Leave working tree untouched, reset index"]
9647 grid $w.f.mixed -sticky w
9648 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9649 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9650 grid $w.f.hard -sticky w
9651 pack $w.f -side top -fill x -padx 4
9652 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9653 pack $w.ok -side left -fill x -padx 20 -pady 20
9654 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9655 bind $w <Key-Escape> [list destroy $w]
9656 pack $w.cancel -side right -fill x -padx 20 -pady 20
9657 bind $w <Visibility> "grab $w; focus $w"
9658 tkwait window $w
9659 if {!$confirm_ok} return
9660 if {[catch {set fd [open \
9661 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9662 error_popup $err
9663 } else {
9664 dohidelocalchanges
9665 filerun $fd [list readresetstat $fd]
9666 nowbusy reset [mc "Resetting"]
9667 selbyid $rowmenuid
9668 }
9669}
9670
9671proc readresetstat {fd} {
9672 global mainhead mainheadid showlocalchanges rprogcoord
9673
9674 if {[gets $fd line] >= 0} {
9675 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9676 set rprogcoord [expr {1.0 * $m / $n}]
9677 adjustprogress
9678 }
9679 return 1
9680 }
9681 set rprogcoord 0
9682 adjustprogress
9683 notbusy reset
9684 if {[catch {close $fd} err]} {
9685 error_popup $err
9686 }
9687 set oldhead $mainheadid
9688 set newhead [exec git rev-parse HEAD]
9689 if {$newhead ne $oldhead} {
9690 movehead $newhead $mainhead
9691 movedhead $newhead $mainhead
9692 set mainheadid $newhead
9693 redrawtags $oldhead
9694 redrawtags $newhead
9695 }
9696 if {$showlocalchanges} {
9697 doshowlocalchanges
9698 }
9699 return 0
9700}
9701
9702# context menu for a head
9703proc headmenu {x y id head} {
9704 global headmenuid headmenuhead headctxmenu mainhead
9705
9706 stopfinding
9707 set headmenuid $id
9708 set headmenuhead $head
9709 set state normal
9710 if {[string match "remotes/*" $head]} {
9711 set state disabled
9712 }
9713 if {$head eq $mainhead} {
9714 set state disabled
9715 }
9716 $headctxmenu entryconfigure 0 -state $state
9717 $headctxmenu entryconfigure 1 -state $state
9718 tk_popup $headctxmenu $x $y
9719}
9720
9721proc cobranch {} {
9722 global headmenuid headmenuhead headids
9723 global showlocalchanges
9724
9725 # check the tree is clean first??
9726 nowbusy checkout [mc "Checking out"]
9727 update
9728 dohidelocalchanges
9729 if {[catch {
9730 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9731 } err]} {
9732 notbusy checkout
9733 error_popup $err
9734 if {$showlocalchanges} {
9735 dodiffindex
9736 }
9737 } else {
9738 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9739 }
9740}
9741
9742proc readcheckoutstat {fd newhead newheadid} {
9743 global mainhead mainheadid headids showlocalchanges progresscoords
9744 global viewmainheadid curview
9745
9746 if {[gets $fd line] >= 0} {
9747 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9748 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9749 adjustprogress
9750 }
9751 return 1
9752 }
9753 set progresscoords {0 0}
9754 adjustprogress
9755 notbusy checkout
9756 if {[catch {close $fd} err]} {
9757 error_popup $err
9758 }
9759 set oldmainid $mainheadid
9760 set mainhead $newhead
9761 set mainheadid $newheadid
9762 set viewmainheadid($curview) $newheadid
9763 redrawtags $oldmainid
9764 redrawtags $newheadid
9765 selbyid $newheadid
9766 if {$showlocalchanges} {
9767 dodiffindex
9768 }
9769}
9770
9771proc rmbranch {} {
9772 global headmenuid headmenuhead mainhead
9773 global idheads
9774
9775 set head $headmenuhead
9776 set id $headmenuid
9777 # this check shouldn't be needed any more...
9778 if {$head eq $mainhead} {
9779 error_popup [mc "Cannot delete the currently checked-out branch"]
9780 return
9781 }
9782 set dheads [descheads $id]
9783 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9784 # the stuff on this branch isn't on any other branch
9785 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9786 branch.\nReally delete branch %s?" $head $head]]} return
9787 }
9788 nowbusy rmbranch
9789 update
9790 if {[catch {exec git branch -D $head} err]} {
9791 notbusy rmbranch
9792 error_popup $err
9793 return
9794 }
9795 removehead $id $head
9796 removedhead $id $head
9797 redrawtags $id
9798 notbusy rmbranch
9799 dispneartags 0
9800 run refill_reflist
9801}
9802
9803# Display a list of tags and heads
9804proc showrefs {} {
9805 global showrefstop bgcolor fgcolor selectbgcolor NS
9806 global bglist fglist reflistfilter reflist maincursor
9807
9808 set top .showrefs
9809 set showrefstop $top
9810 if {[winfo exists $top]} {
9811 raise $top
9812 refill_reflist
9813 return
9814 }
9815 ttk_toplevel $top
9816 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9817 make_transient $top .
9818 text $top.list -background $bgcolor -foreground $fgcolor \
9819 -selectbackground $selectbgcolor -font mainfont \
9820 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9821 -width 30 -height 20 -cursor $maincursor \
9822 -spacing1 1 -spacing3 1 -state disabled
9823 $top.list tag configure highlight -background $selectbgcolor
9824 if {![lsearch -exact $bglist $top.list]} {
9825 lappend bglist $top.list
9826 lappend fglist $top.list
9827 }
9828 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9829 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9830 grid $top.list $top.ysb -sticky nsew
9831 grid $top.xsb x -sticky ew
9832 ${NS}::frame $top.f
9833 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9834 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9835 set reflistfilter "*"
9836 trace add variable reflistfilter write reflistfilter_change
9837 pack $top.f.e -side right -fill x -expand 1
9838 pack $top.f.l -side left
9839 grid $top.f - -sticky ew -pady 2
9840 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9841 bind $top <Key-Escape> [list destroy $top]
9842 grid $top.close -
9843 grid columnconfigure $top 0 -weight 1
9844 grid rowconfigure $top 0 -weight 1
9845 bind $top.list <1> {break}
9846 bind $top.list <B1-Motion> {break}
9847 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9848 set reflist {}
9849 refill_reflist
9850}
9851
9852proc sel_reflist {w x y} {
9853 global showrefstop reflist headids tagids otherrefids
9854
9855 if {![winfo exists $showrefstop]} return
9856 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9857 set ref [lindex $reflist [expr {$l-1}]]
9858 set n [lindex $ref 0]
9859 switch -- [lindex $ref 1] {
9860 "H" {selbyid $headids($n)}
9861 "T" {selbyid $tagids($n)}
9862 "o" {selbyid $otherrefids($n)}
9863 }
9864 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9865}
9866
9867proc unsel_reflist {} {
9868 global showrefstop
9869
9870 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9871 $showrefstop.list tag remove highlight 0.0 end
9872}
9873
9874proc reflistfilter_change {n1 n2 op} {
9875 global reflistfilter
9876
9877 after cancel refill_reflist
9878 after 200 refill_reflist
9879}
9880
9881proc refill_reflist {} {
9882 global reflist reflistfilter showrefstop headids tagids otherrefids
9883 global curview
9884
9885 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9886 set refs {}
9887 foreach n [array names headids] {
9888 if {[string match $reflistfilter $n]} {
9889 if {[commitinview $headids($n) $curview]} {
9890 lappend refs [list $n H]
9891 } else {
9892 interestedin $headids($n) {run refill_reflist}
9893 }
9894 }
9895 }
9896 foreach n [array names tagids] {
9897 if {[string match $reflistfilter $n]} {
9898 if {[commitinview $tagids($n) $curview]} {
9899 lappend refs [list $n T]
9900 } else {
9901 interestedin $tagids($n) {run refill_reflist}
9902 }
9903 }
9904 }
9905 foreach n [array names otherrefids] {
9906 if {[string match $reflistfilter $n]} {
9907 if {[commitinview $otherrefids($n) $curview]} {
9908 lappend refs [list $n o]
9909 } else {
9910 interestedin $otherrefids($n) {run refill_reflist}
9911 }
9912 }
9913 }
9914 set refs [lsort -index 0 $refs]
9915 if {$refs eq $reflist} return
9916
9917 # Update the contents of $showrefstop.list according to the
9918 # differences between $reflist (old) and $refs (new)
9919 $showrefstop.list conf -state normal
9920 $showrefstop.list insert end "\n"
9921 set i 0
9922 set j 0
9923 while {$i < [llength $reflist] || $j < [llength $refs]} {
9924 if {$i < [llength $reflist]} {
9925 if {$j < [llength $refs]} {
9926 set cmp [string compare [lindex $reflist $i 0] \
9927 [lindex $refs $j 0]]
9928 if {$cmp == 0} {
9929 set cmp [string compare [lindex $reflist $i 1] \
9930 [lindex $refs $j 1]]
9931 }
9932 } else {
9933 set cmp -1
9934 }
9935 } else {
9936 set cmp 1
9937 }
9938 switch -- $cmp {
9939 -1 {
9940 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9941 incr i
9942 }
9943 0 {
9944 incr i
9945 incr j
9946 }
9947 1 {
9948 set l [expr {$j + 1}]
9949 $showrefstop.list image create $l.0 -align baseline \
9950 -image reficon-[lindex $refs $j 1] -padx 2
9951 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9952 incr j
9953 }
9954 }
9955 }
9956 set reflist $refs
9957 # delete last newline
9958 $showrefstop.list delete end-2c end-1c
9959 $showrefstop.list conf -state disabled
9960}
9961
9962# Stuff for finding nearby tags
9963proc getallcommits {} {
9964 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9965 global idheads idtags idotherrefs allparents tagobjid
9966 global gitdir
9967
9968 if {![info exists allcommits]} {
9969 set nextarc 0
9970 set allcommits 0
9971 set seeds {}
9972 set allcwait 0
9973 set cachedarcs 0
9974 set allccache [file join $gitdir "gitk.cache"]
9975 if {![catch {
9976 set f [open $allccache r]
9977 set allcwait 1
9978 getcache $f
9979 }]} return
9980 }
9981
9982 if {$allcwait} {
9983 return
9984 }
9985 set cmd [list | git rev-list --parents]
9986 set allcupdate [expr {$seeds ne {}}]
9987 if {!$allcupdate} {
9988 set ids "--all"
9989 } else {
9990 set refs [concat [array names idheads] [array names idtags] \
9991 [array names idotherrefs]]
9992 set ids {}
9993 set tagobjs {}
9994 foreach name [array names tagobjid] {
9995 lappend tagobjs $tagobjid($name)
9996 }
9997 foreach id [lsort -unique $refs] {
9998 if {![info exists allparents($id)] &&
9999 [lsearch -exact $tagobjs $id] < 0} {
10000 lappend ids $id
10001 }
10002 }
10003 if {$ids ne {}} {
10004 foreach id $seeds {
10005 lappend ids "^$id"
10006 }
10007 }
10008 }
10009 if {$ids ne {}} {
10010 set fd [open [concat $cmd $ids] r]
10011 fconfigure $fd -blocking 0
10012 incr allcommits
10013 nowbusy allcommits
10014 filerun $fd [list getallclines $fd]
10015 } else {
10016 dispneartags 0
10017 }
10018}
10019
10020# Since most commits have 1 parent and 1 child, we group strings of
10021# such commits into "arcs" joining branch/merge points (BMPs), which
10022# are commits that either don't have 1 parent or don't have 1 child.
10023#
10024# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10025# arcout(id) - outgoing arcs for BMP
10026# arcids(a) - list of IDs on arc including end but not start
10027# arcstart(a) - BMP ID at start of arc
10028# arcend(a) - BMP ID at end of arc
10029# growing(a) - arc a is still growing
10030# arctags(a) - IDs out of arcids (excluding end) that have tags
10031# archeads(a) - IDs out of arcids (excluding end) that have heads
10032# The start of an arc is at the descendent end, so "incoming" means
10033# coming from descendents, and "outgoing" means going towards ancestors.
10034
10035proc getallclines {fd} {
10036 global allparents allchildren idtags idheads nextarc
10037 global arcnos arcids arctags arcout arcend arcstart archeads growing
10038 global seeds allcommits cachedarcs allcupdate
10039
10040 set nid 0
10041 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10042 set id [lindex $line 0]
10043 if {[info exists allparents($id)]} {
10044 # seen it already
10045 continue
10046 }
10047 set cachedarcs 0
10048 set olds [lrange $line 1 end]
10049 set allparents($id) $olds
10050 if {![info exists allchildren($id)]} {
10051 set allchildren($id) {}
10052 set arcnos($id) {}
10053 lappend seeds $id
10054 } else {
10055 set a $arcnos($id)
10056 if {[llength $olds] == 1 && [llength $a] == 1} {
10057 lappend arcids($a) $id
10058 if {[info exists idtags($id)]} {
10059 lappend arctags($a) $id
10060 }
10061 if {[info exists idheads($id)]} {
10062 lappend archeads($a) $id
10063 }
10064 if {[info exists allparents($olds)]} {
10065 # seen parent already
10066 if {![info exists arcout($olds)]} {
10067 splitarc $olds
10068 }
10069 lappend arcids($a) $olds
10070 set arcend($a) $olds
10071 unset growing($a)
10072 }
10073 lappend allchildren($olds) $id
10074 lappend arcnos($olds) $a
10075 continue
10076 }
10077 }
10078 foreach a $arcnos($id) {
10079 lappend arcids($a) $id
10080 set arcend($a) $id
10081 unset growing($a)
10082 }
10083
10084 set ao {}
10085 foreach p $olds {
10086 lappend allchildren($p) $id
10087 set a [incr nextarc]
10088 set arcstart($a) $id
10089 set archeads($a) {}
10090 set arctags($a) {}
10091 set archeads($a) {}
10092 set arcids($a) {}
10093 lappend ao $a
10094 set growing($a) 1
10095 if {[info exists allparents($p)]} {
10096 # seen it already, may need to make a new branch
10097 if {![info exists arcout($p)]} {
10098 splitarc $p
10099 }
10100 lappend arcids($a) $p
10101 set arcend($a) $p
10102 unset growing($a)
10103 }
10104 lappend arcnos($p) $a
10105 }
10106 set arcout($id) $ao
10107 }
10108 if {$nid > 0} {
10109 global cached_dheads cached_dtags cached_atags
10110 unset -nocomplain cached_dheads
10111 unset -nocomplain cached_dtags
10112 unset -nocomplain cached_atags
10113 }
10114 if {![eof $fd]} {
10115 return [expr {$nid >= 1000? 2: 1}]
10116 }
10117 set cacheok 1
10118 if {[catch {
10119 fconfigure $fd -blocking 1
10120 close $fd
10121 } err]} {
10122 # got an error reading the list of commits
10123 # if we were updating, try rereading the whole thing again
10124 if {$allcupdate} {
10125 incr allcommits -1
10126 dropcache $err
10127 return
10128 }
10129 error_popup "[mc "Error reading commit topology information;\
10130 branch and preceding/following tag information\
10131 will be incomplete."]\n($err)"
10132 set cacheok 0
10133 }
10134 if {[incr allcommits -1] == 0} {
10135 notbusy allcommits
10136 if {$cacheok} {
10137 run savecache
10138 }
10139 }
10140 dispneartags 0
10141 return 0
10142}
10143
10144proc recalcarc {a} {
10145 global arctags archeads arcids idtags idheads
10146
10147 set at {}
10148 set ah {}
10149 foreach id [lrange $arcids($a) 0 end-1] {
10150 if {[info exists idtags($id)]} {
10151 lappend at $id
10152 }
10153 if {[info exists idheads($id)]} {
10154 lappend ah $id
10155 }
10156 }
10157 set arctags($a) $at
10158 set archeads($a) $ah
10159}
10160
10161proc splitarc {p} {
10162 global arcnos arcids nextarc arctags archeads idtags idheads
10163 global arcstart arcend arcout allparents growing
10164
10165 set a $arcnos($p)
10166 if {[llength $a] != 1} {
10167 puts "oops splitarc called but [llength $a] arcs already"
10168 return
10169 }
10170 set a [lindex $a 0]
10171 set i [lsearch -exact $arcids($a) $p]
10172 if {$i < 0} {
10173 puts "oops splitarc $p not in arc $a"
10174 return
10175 }
10176 set na [incr nextarc]
10177 if {[info exists arcend($a)]} {
10178 set arcend($na) $arcend($a)
10179 } else {
10180 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10181 set j [lsearch -exact $arcnos($l) $a]
10182 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10183 }
10184 set tail [lrange $arcids($a) [expr {$i+1}] end]
10185 set arcids($a) [lrange $arcids($a) 0 $i]
10186 set arcend($a) $p
10187 set arcstart($na) $p
10188 set arcout($p) $na
10189 set arcids($na) $tail
10190 if {[info exists growing($a)]} {
10191 set growing($na) 1
10192 unset growing($a)
10193 }
10194
10195 foreach id $tail {
10196 if {[llength $arcnos($id)] == 1} {
10197 set arcnos($id) $na
10198 } else {
10199 set j [lsearch -exact $arcnos($id) $a]
10200 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10201 }
10202 }
10203
10204 # reconstruct tags and heads lists
10205 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10206 recalcarc $a
10207 recalcarc $na
10208 } else {
10209 set arctags($na) {}
10210 set archeads($na) {}
10211 }
10212}
10213
10214# Update things for a new commit added that is a child of one
10215# existing commit. Used when cherry-picking.
10216proc addnewchild {id p} {
10217 global allparents allchildren idtags nextarc
10218 global arcnos arcids arctags arcout arcend arcstart archeads growing
10219 global seeds allcommits
10220
10221 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10222 set allparents($id) [list $p]
10223 set allchildren($id) {}
10224 set arcnos($id) {}
10225 lappend seeds $id
10226 lappend allchildren($p) $id
10227 set a [incr nextarc]
10228 set arcstart($a) $id
10229 set archeads($a) {}
10230 set arctags($a) {}
10231 set arcids($a) [list $p]
10232 set arcend($a) $p
10233 if {![info exists arcout($p)]} {
10234 splitarc $p
10235 }
10236 lappend arcnos($p) $a
10237 set arcout($id) [list $a]
10238}
10239
10240# This implements a cache for the topology information.
10241# The cache saves, for each arc, the start and end of the arc,
10242# the ids on the arc, and the outgoing arcs from the end.
10243proc readcache {f} {
10244 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10245 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10246 global allcwait
10247
10248 set a $nextarc
10249 set lim $cachedarcs
10250 if {$lim - $a > 500} {
10251 set lim [expr {$a + 500}]
10252 }
10253 if {[catch {
10254 if {$a == $lim} {
10255 # finish reading the cache and setting up arctags, etc.
10256 set line [gets $f]
10257 if {$line ne "1"} {error "bad final version"}
10258 close $f
10259 foreach id [array names idtags] {
10260 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10261 [llength $allparents($id)] == 1} {
10262 set a [lindex $arcnos($id) 0]
10263 if {$arctags($a) eq {}} {
10264 recalcarc $a
10265 }
10266 }
10267 }
10268 foreach id [array names idheads] {
10269 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10270 [llength $allparents($id)] == 1} {
10271 set a [lindex $arcnos($id) 0]
10272 if {$archeads($a) eq {}} {
10273 recalcarc $a
10274 }
10275 }
10276 }
10277 foreach id [lsort -unique $possible_seeds] {
10278 if {$arcnos($id) eq {}} {
10279 lappend seeds $id
10280 }
10281 }
10282 set allcwait 0
10283 } else {
10284 while {[incr a] <= $lim} {
10285 set line [gets $f]
10286 if {[llength $line] != 3} {error "bad line"}
10287 set s [lindex $line 0]
10288 set arcstart($a) $s
10289 lappend arcout($s) $a
10290 if {![info exists arcnos($s)]} {
10291 lappend possible_seeds $s
10292 set arcnos($s) {}
10293 }
10294 set e [lindex $line 1]
10295 if {$e eq {}} {
10296 set growing($a) 1
10297 } else {
10298 set arcend($a) $e
10299 if {![info exists arcout($e)]} {
10300 set arcout($e) {}
10301 }
10302 }
10303 set arcids($a) [lindex $line 2]
10304 foreach id $arcids($a) {
10305 lappend allparents($s) $id
10306 set s $id
10307 lappend arcnos($id) $a
10308 }
10309 if {![info exists allparents($s)]} {
10310 set allparents($s) {}
10311 }
10312 set arctags($a) {}
10313 set archeads($a) {}
10314 }
10315 set nextarc [expr {$a - 1}]
10316 }
10317 } err]} {
10318 dropcache $err
10319 return 0
10320 }
10321 if {!$allcwait} {
10322 getallcommits
10323 }
10324 return $allcwait
10325}
10326
10327proc getcache {f} {
10328 global nextarc cachedarcs possible_seeds
10329
10330 if {[catch {
10331 set line [gets $f]
10332 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10333 # make sure it's an integer
10334 set cachedarcs [expr {int([lindex $line 1])}]
10335 if {$cachedarcs < 0} {error "bad number of arcs"}
10336 set nextarc 0
10337 set possible_seeds {}
10338 run readcache $f
10339 } err]} {
10340 dropcache $err
10341 }
10342 return 0
10343}
10344
10345proc dropcache {err} {
10346 global allcwait nextarc cachedarcs seeds
10347
10348 #puts "dropping cache ($err)"
10349 foreach v {arcnos arcout arcids arcstart arcend growing \
10350 arctags archeads allparents allchildren} {
10351 global $v
10352 unset -nocomplain $v
10353 }
10354 set allcwait 0
10355 set nextarc 0
10356 set cachedarcs 0
10357 set seeds {}
10358 getallcommits
10359}
10360
10361proc writecache {f} {
10362 global cachearc cachedarcs allccache
10363 global arcstart arcend arcnos arcids arcout
10364
10365 set a $cachearc
10366 set lim $cachedarcs
10367 if {$lim - $a > 1000} {
10368 set lim [expr {$a + 1000}]
10369 }
10370 if {[catch {
10371 while {[incr a] <= $lim} {
10372 if {[info exists arcend($a)]} {
10373 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10374 } else {
10375 puts $f [list $arcstart($a) {} $arcids($a)]
10376 }
10377 }
10378 } err]} {
10379 catch {close $f}
10380 catch {file delete $allccache}
10381 #puts "writing cache failed ($err)"
10382 return 0
10383 }
10384 set cachearc [expr {$a - 1}]
10385 if {$a > $cachedarcs} {
10386 puts $f "1"
10387 close $f
10388 return 0
10389 }
10390 return 1
10391}
10392
10393proc savecache {} {
10394 global nextarc cachedarcs cachearc allccache
10395
10396 if {$nextarc == $cachedarcs} return
10397 set cachearc 0
10398 set cachedarcs $nextarc
10399 catch {
10400 set f [open $allccache w]
10401 puts $f [list 1 $cachedarcs]
10402 run writecache $f
10403 }
10404}
10405
10406# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10407# or 0 if neither is true.
10408proc anc_or_desc {a b} {
10409 global arcout arcstart arcend arcnos cached_isanc
10410
10411 if {$arcnos($a) eq $arcnos($b)} {
10412 # Both are on the same arc(s); either both are the same BMP,
10413 # or if one is not a BMP, the other is also not a BMP or is
10414 # the BMP at end of the arc (and it only has 1 incoming arc).
10415 # Or both can be BMPs with no incoming arcs.
10416 if {$a eq $b || $arcnos($a) eq {}} {
10417 return 0
10418 }
10419 # assert {[llength $arcnos($a)] == 1}
10420 set arc [lindex $arcnos($a) 0]
10421 set i [lsearch -exact $arcids($arc) $a]
10422 set j [lsearch -exact $arcids($arc) $b]
10423 if {$i < 0 || $i > $j} {
10424 return 1
10425 } else {
10426 return -1
10427 }
10428 }
10429
10430 if {![info exists arcout($a)]} {
10431 set arc [lindex $arcnos($a) 0]
10432 if {[info exists arcend($arc)]} {
10433 set aend $arcend($arc)
10434 } else {
10435 set aend {}
10436 }
10437 set a $arcstart($arc)
10438 } else {
10439 set aend $a
10440 }
10441 if {![info exists arcout($b)]} {
10442 set arc [lindex $arcnos($b) 0]
10443 if {[info exists arcend($arc)]} {
10444 set bend $arcend($arc)
10445 } else {
10446 set bend {}
10447 }
10448 set b $arcstart($arc)
10449 } else {
10450 set bend $b
10451 }
10452 if {$a eq $bend} {
10453 return 1
10454 }
10455 if {$b eq $aend} {
10456 return -1
10457 }
10458 if {[info exists cached_isanc($a,$bend)]} {
10459 if {$cached_isanc($a,$bend)} {
10460 return 1
10461 }
10462 }
10463 if {[info exists cached_isanc($b,$aend)]} {
10464 if {$cached_isanc($b,$aend)} {
10465 return -1
10466 }
10467 if {[info exists cached_isanc($a,$bend)]} {
10468 return 0
10469 }
10470 }
10471
10472 set todo [list $a $b]
10473 set anc($a) a
10474 set anc($b) b
10475 for {set i 0} {$i < [llength $todo]} {incr i} {
10476 set x [lindex $todo $i]
10477 if {$anc($x) eq {}} {
10478 continue
10479 }
10480 foreach arc $arcnos($x) {
10481 set xd $arcstart($arc)
10482 if {$xd eq $bend} {
10483 set cached_isanc($a,$bend) 1
10484 set cached_isanc($b,$aend) 0
10485 return 1
10486 } elseif {$xd eq $aend} {
10487 set cached_isanc($b,$aend) 1
10488 set cached_isanc($a,$bend) 0
10489 return -1
10490 }
10491 if {![info exists anc($xd)]} {
10492 set anc($xd) $anc($x)
10493 lappend todo $xd
10494 } elseif {$anc($xd) ne $anc($x)} {
10495 set anc($xd) {}
10496 }
10497 }
10498 }
10499 set cached_isanc($a,$bend) 0
10500 set cached_isanc($b,$aend) 0
10501 return 0
10502}
10503
10504# This identifies whether $desc has an ancestor that is
10505# a growing tip of the graph and which is not an ancestor of $anc
10506# and returns 0 if so and 1 if not.
10507# If we subsequently discover a tag on such a growing tip, and that
10508# turns out to be a descendent of $anc (which it could, since we
10509# don't necessarily see children before parents), then $desc
10510# isn't a good choice to display as a descendent tag of
10511# $anc (since it is the descendent of another tag which is
10512# a descendent of $anc). Similarly, $anc isn't a good choice to
10513# display as a ancestor tag of $desc.
10514#
10515proc is_certain {desc anc} {
10516 global arcnos arcout arcstart arcend growing problems
10517
10518 set certain {}
10519 if {[llength $arcnos($anc)] == 1} {
10520 # tags on the same arc are certain
10521 if {$arcnos($desc) eq $arcnos($anc)} {
10522 return 1
10523 }
10524 if {![info exists arcout($anc)]} {
10525 # if $anc is partway along an arc, use the start of the arc instead
10526 set a [lindex $arcnos($anc) 0]
10527 set anc $arcstart($a)
10528 }
10529 }
10530 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10531 set x $desc
10532 } else {
10533 set a [lindex $arcnos($desc) 0]
10534 set x $arcend($a)
10535 }
10536 if {$x == $anc} {
10537 return 1
10538 }
10539 set anclist [list $x]
10540 set dl($x) 1
10541 set nnh 1
10542 set ngrowanc 0
10543 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10544 set x [lindex $anclist $i]
10545 if {$dl($x)} {
10546 incr nnh -1
10547 }
10548 set done($x) 1
10549 foreach a $arcout($x) {
10550 if {[info exists growing($a)]} {
10551 if {![info exists growanc($x)] && $dl($x)} {
10552 set growanc($x) 1
10553 incr ngrowanc
10554 }
10555 } else {
10556 set y $arcend($a)
10557 if {[info exists dl($y)]} {
10558 if {$dl($y)} {
10559 if {!$dl($x)} {
10560 set dl($y) 0
10561 if {![info exists done($y)]} {
10562 incr nnh -1
10563 }
10564 if {[info exists growanc($x)]} {
10565 incr ngrowanc -1
10566 }
10567 set xl [list $y]
10568 for {set k 0} {$k < [llength $xl]} {incr k} {
10569 set z [lindex $xl $k]
10570 foreach c $arcout($z) {
10571 if {[info exists arcend($c)]} {
10572 set v $arcend($c)
10573 if {[info exists dl($v)] && $dl($v)} {
10574 set dl($v) 0
10575 if {![info exists done($v)]} {
10576 incr nnh -1
10577 }
10578 if {[info exists growanc($v)]} {
10579 incr ngrowanc -1
10580 }
10581 lappend xl $v
10582 }
10583 }
10584 }
10585 }
10586 }
10587 }
10588 } elseif {$y eq $anc || !$dl($x)} {
10589 set dl($y) 0
10590 lappend anclist $y
10591 } else {
10592 set dl($y) 1
10593 lappend anclist $y
10594 incr nnh
10595 }
10596 }
10597 }
10598 }
10599 foreach x [array names growanc] {
10600 if {$dl($x)} {
10601 return 0
10602 }
10603 return 0
10604 }
10605 return 1
10606}
10607
10608proc validate_arctags {a} {
10609 global arctags idtags
10610
10611 set i -1
10612 set na $arctags($a)
10613 foreach id $arctags($a) {
10614 incr i
10615 if {![info exists idtags($id)]} {
10616 set na [lreplace $na $i $i]
10617 incr i -1
10618 }
10619 }
10620 set arctags($a) $na
10621}
10622
10623proc validate_archeads {a} {
10624 global archeads idheads
10625
10626 set i -1
10627 set na $archeads($a)
10628 foreach id $archeads($a) {
10629 incr i
10630 if {![info exists idheads($id)]} {
10631 set na [lreplace $na $i $i]
10632 incr i -1
10633 }
10634 }
10635 set archeads($a) $na
10636}
10637
10638# Return the list of IDs that have tags that are descendents of id,
10639# ignoring IDs that are descendents of IDs already reported.
10640proc desctags {id} {
10641 global arcnos arcstart arcids arctags idtags allparents
10642 global growing cached_dtags
10643
10644 if {![info exists allparents($id)]} {
10645 return {}
10646 }
10647 set t1 [clock clicks -milliseconds]
10648 set argid $id
10649 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10650 # part-way along an arc; check that arc first
10651 set a [lindex $arcnos($id) 0]
10652 if {$arctags($a) ne {}} {
10653 validate_arctags $a
10654 set i [lsearch -exact $arcids($a) $id]
10655 set tid {}
10656 foreach t $arctags($a) {
10657 set j [lsearch -exact $arcids($a) $t]
10658 if {$j >= $i} break
10659 set tid $t
10660 }
10661 if {$tid ne {}} {
10662 return $tid
10663 }
10664 }
10665 set id $arcstart($a)
10666 if {[info exists idtags($id)]} {
10667 return $id
10668 }
10669 }
10670 if {[info exists cached_dtags($id)]} {
10671 return $cached_dtags($id)
10672 }
10673
10674 set origid $id
10675 set todo [list $id]
10676 set queued($id) 1
10677 set nc 1
10678 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10679 set id [lindex $todo $i]
10680 set done($id) 1
10681 set ta [info exists hastaggedancestor($id)]
10682 if {!$ta} {
10683 incr nc -1
10684 }
10685 # ignore tags on starting node
10686 if {!$ta && $i > 0} {
10687 if {[info exists idtags($id)]} {
10688 set tagloc($id) $id
10689 set ta 1
10690 } elseif {[info exists cached_dtags($id)]} {
10691 set tagloc($id) $cached_dtags($id)
10692 set ta 1
10693 }
10694 }
10695 foreach a $arcnos($id) {
10696 set d $arcstart($a)
10697 if {!$ta && $arctags($a) ne {}} {
10698 validate_arctags $a
10699 if {$arctags($a) ne {}} {
10700 lappend tagloc($id) [lindex $arctags($a) end]
10701 }
10702 }
10703 if {$ta || $arctags($a) ne {}} {
10704 set tomark [list $d]
10705 for {set j 0} {$j < [llength $tomark]} {incr j} {
10706 set dd [lindex $tomark $j]
10707 if {![info exists hastaggedancestor($dd)]} {
10708 if {[info exists done($dd)]} {
10709 foreach b $arcnos($dd) {
10710 lappend tomark $arcstart($b)
10711 }
10712 if {[info exists tagloc($dd)]} {
10713 unset tagloc($dd)
10714 }
10715 } elseif {[info exists queued($dd)]} {
10716 incr nc -1
10717 }
10718 set hastaggedancestor($dd) 1
10719 }
10720 }
10721 }
10722 if {![info exists queued($d)]} {
10723 lappend todo $d
10724 set queued($d) 1
10725 if {![info exists hastaggedancestor($d)]} {
10726 incr nc
10727 }
10728 }
10729 }
10730 }
10731 set tags {}
10732 foreach id [array names tagloc] {
10733 if {![info exists hastaggedancestor($id)]} {
10734 foreach t $tagloc($id) {
10735 if {[lsearch -exact $tags $t] < 0} {
10736 lappend tags $t
10737 }
10738 }
10739 }
10740 }
10741 set t2 [clock clicks -milliseconds]
10742 set loopix $i
10743
10744 # remove tags that are descendents of other tags
10745 for {set i 0} {$i < [llength $tags]} {incr i} {
10746 set a [lindex $tags $i]
10747 for {set j 0} {$j < $i} {incr j} {
10748 set b [lindex $tags $j]
10749 set r [anc_or_desc $a $b]
10750 if {$r == 1} {
10751 set tags [lreplace $tags $j $j]
10752 incr j -1
10753 incr i -1
10754 } elseif {$r == -1} {
10755 set tags [lreplace $tags $i $i]
10756 incr i -1
10757 break
10758 }
10759 }
10760 }
10761
10762 if {[array names growing] ne {}} {
10763 # graph isn't finished, need to check if any tag could get
10764 # eclipsed by another tag coming later. Simply ignore any
10765 # tags that could later get eclipsed.
10766 set ctags {}
10767 foreach t $tags {
10768 if {[is_certain $t $origid]} {
10769 lappend ctags $t
10770 }
10771 }
10772 if {$tags eq $ctags} {
10773 set cached_dtags($origid) $tags
10774 } else {
10775 set tags $ctags
10776 }
10777 } else {
10778 set cached_dtags($origid) $tags
10779 }
10780 set t3 [clock clicks -milliseconds]
10781 if {0 && $t3 - $t1 >= 100} {
10782 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10783 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10784 }
10785 return $tags
10786}
10787
10788proc anctags {id} {
10789 global arcnos arcids arcout arcend arctags idtags allparents
10790 global growing cached_atags
10791
10792 if {![info exists allparents($id)]} {
10793 return {}
10794 }
10795 set t1 [clock clicks -milliseconds]
10796 set argid $id
10797 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10798 # part-way along an arc; check that arc first
10799 set a [lindex $arcnos($id) 0]
10800 if {$arctags($a) ne {}} {
10801 validate_arctags $a
10802 set i [lsearch -exact $arcids($a) $id]
10803 foreach t $arctags($a) {
10804 set j [lsearch -exact $arcids($a) $t]
10805 if {$j > $i} {
10806 return $t
10807 }
10808 }
10809 }
10810 if {![info exists arcend($a)]} {
10811 return {}
10812 }
10813 set id $arcend($a)
10814 if {[info exists idtags($id)]} {
10815 return $id
10816 }
10817 }
10818 if {[info exists cached_atags($id)]} {
10819 return $cached_atags($id)
10820 }
10821
10822 set origid $id
10823 set todo [list $id]
10824 set queued($id) 1
10825 set taglist {}
10826 set nc 1
10827 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10828 set id [lindex $todo $i]
10829 set done($id) 1
10830 set td [info exists hastaggeddescendent($id)]
10831 if {!$td} {
10832 incr nc -1
10833 }
10834 # ignore tags on starting node
10835 if {!$td && $i > 0} {
10836 if {[info exists idtags($id)]} {
10837 set tagloc($id) $id
10838 set td 1
10839 } elseif {[info exists cached_atags($id)]} {
10840 set tagloc($id) $cached_atags($id)
10841 set td 1
10842 }
10843 }
10844 foreach a $arcout($id) {
10845 if {!$td && $arctags($a) ne {}} {
10846 validate_arctags $a
10847 if {$arctags($a) ne {}} {
10848 lappend tagloc($id) [lindex $arctags($a) 0]
10849 }
10850 }
10851 if {![info exists arcend($a)]} continue
10852 set d $arcend($a)
10853 if {$td || $arctags($a) ne {}} {
10854 set tomark [list $d]
10855 for {set j 0} {$j < [llength $tomark]} {incr j} {
10856 set dd [lindex $tomark $j]
10857 if {![info exists hastaggeddescendent($dd)]} {
10858 if {[info exists done($dd)]} {
10859 foreach b $arcout($dd) {
10860 if {[info exists arcend($b)]} {
10861 lappend tomark $arcend($b)
10862 }
10863 }
10864 if {[info exists tagloc($dd)]} {
10865 unset tagloc($dd)
10866 }
10867 } elseif {[info exists queued($dd)]} {
10868 incr nc -1
10869 }
10870 set hastaggeddescendent($dd) 1
10871 }
10872 }
10873 }
10874 if {![info exists queued($d)]} {
10875 lappend todo $d
10876 set queued($d) 1
10877 if {![info exists hastaggeddescendent($d)]} {
10878 incr nc
10879 }
10880 }
10881 }
10882 }
10883 set t2 [clock clicks -milliseconds]
10884 set loopix $i
10885 set tags {}
10886 foreach id [array names tagloc] {
10887 if {![info exists hastaggeddescendent($id)]} {
10888 foreach t $tagloc($id) {
10889 if {[lsearch -exact $tags $t] < 0} {
10890 lappend tags $t
10891 }
10892 }
10893 }
10894 }
10895
10896 # remove tags that are ancestors of other tags
10897 for {set i 0} {$i < [llength $tags]} {incr i} {
10898 set a [lindex $tags $i]
10899 for {set j 0} {$j < $i} {incr j} {
10900 set b [lindex $tags $j]
10901 set r [anc_or_desc $a $b]
10902 if {$r == -1} {
10903 set tags [lreplace $tags $j $j]
10904 incr j -1
10905 incr i -1
10906 } elseif {$r == 1} {
10907 set tags [lreplace $tags $i $i]
10908 incr i -1
10909 break
10910 }
10911 }
10912 }
10913
10914 if {[array names growing] ne {}} {
10915 # graph isn't finished, need to check if any tag could get
10916 # eclipsed by another tag coming later. Simply ignore any
10917 # tags that could later get eclipsed.
10918 set ctags {}
10919 foreach t $tags {
10920 if {[is_certain $origid $t]} {
10921 lappend ctags $t
10922 }
10923 }
10924 if {$tags eq $ctags} {
10925 set cached_atags($origid) $tags
10926 } else {
10927 set tags $ctags
10928 }
10929 } else {
10930 set cached_atags($origid) $tags
10931 }
10932 set t3 [clock clicks -milliseconds]
10933 if {0 && $t3 - $t1 >= 100} {
10934 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10935 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10936 }
10937 return $tags
10938}
10939
10940# Return the list of IDs that have heads that are descendents of id,
10941# including id itself if it has a head.
10942proc descheads {id} {
10943 global arcnos arcstart arcids archeads idheads cached_dheads
10944 global allparents arcout
10945
10946 if {![info exists allparents($id)]} {
10947 return {}
10948 }
10949 set aret {}
10950 if {![info exists arcout($id)]} {
10951 # part-way along an arc; check it first
10952 set a [lindex $arcnos($id) 0]
10953 if {$archeads($a) ne {}} {
10954 validate_archeads $a
10955 set i [lsearch -exact $arcids($a) $id]
10956 foreach t $archeads($a) {
10957 set j [lsearch -exact $arcids($a) $t]
10958 if {$j > $i} break
10959 lappend aret $t
10960 }
10961 }
10962 set id $arcstart($a)
10963 }
10964 set origid $id
10965 set todo [list $id]
10966 set seen($id) 1
10967 set ret {}
10968 for {set i 0} {$i < [llength $todo]} {incr i} {
10969 set id [lindex $todo $i]
10970 if {[info exists cached_dheads($id)]} {
10971 set ret [concat $ret $cached_dheads($id)]
10972 } else {
10973 if {[info exists idheads($id)]} {
10974 lappend ret $id
10975 }
10976 foreach a $arcnos($id) {
10977 if {$archeads($a) ne {}} {
10978 validate_archeads $a
10979 if {$archeads($a) ne {}} {
10980 set ret [concat $ret $archeads($a)]
10981 }
10982 }
10983 set d $arcstart($a)
10984 if {![info exists seen($d)]} {
10985 lappend todo $d
10986 set seen($d) 1
10987 }
10988 }
10989 }
10990 }
10991 set ret [lsort -unique $ret]
10992 set cached_dheads($origid) $ret
10993 return [concat $ret $aret]
10994}
10995
10996proc addedtag {id} {
10997 global arcnos arcout cached_dtags cached_atags
10998
10999 if {![info exists arcnos($id)]} return
11000 if {![info exists arcout($id)]} {
11001 recalcarc [lindex $arcnos($id) 0]
11002 }
11003 unset -nocomplain cached_dtags
11004 unset -nocomplain cached_atags
11005}
11006
11007proc addedhead {hid head} {
11008 global arcnos arcout cached_dheads
11009
11010 if {![info exists arcnos($hid)]} return
11011 if {![info exists arcout($hid)]} {
11012 recalcarc [lindex $arcnos($hid) 0]
11013 }
11014 unset -nocomplain cached_dheads
11015}
11016
11017proc removedhead {hid head} {
11018 global cached_dheads
11019
11020 unset -nocomplain cached_dheads
11021}
11022
11023proc movedhead {hid head} {
11024 global arcnos arcout cached_dheads
11025
11026 if {![info exists arcnos($hid)]} return
11027 if {![info exists arcout($hid)]} {
11028 recalcarc [lindex $arcnos($hid) 0]
11029 }
11030 unset -nocomplain cached_dheads
11031}
11032
11033proc changedrefs {} {
11034 global cached_dheads cached_dtags cached_atags cached_tagcontent
11035 global arctags archeads arcnos arcout idheads idtags
11036
11037 foreach id [concat [array names idheads] [array names idtags]] {
11038 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11039 set a [lindex $arcnos($id) 0]
11040 if {![info exists donearc($a)]} {
11041 recalcarc $a
11042 set donearc($a) 1
11043 }
11044 }
11045 }
11046 unset -nocomplain cached_tagcontent
11047 unset -nocomplain cached_dtags
11048 unset -nocomplain cached_atags
11049 unset -nocomplain cached_dheads
11050}
11051
11052proc rereadrefs {} {
11053 global idtags idheads idotherrefs mainheadid
11054
11055 set refids [concat [array names idtags] \
11056 [array names idheads] [array names idotherrefs]]
11057 foreach id $refids {
11058 if {![info exists ref($id)]} {
11059 set ref($id) [listrefs $id]
11060 }
11061 }
11062 set oldmainhead $mainheadid
11063 readrefs
11064 changedrefs
11065 set refids [lsort -unique [concat $refids [array names idtags] \
11066 [array names idheads] [array names idotherrefs]]]
11067 foreach id $refids {
11068 set v [listrefs $id]
11069 if {![info exists ref($id)] || $ref($id) != $v} {
11070 redrawtags $id
11071 }
11072 }
11073 if {$oldmainhead ne $mainheadid} {
11074 redrawtags $oldmainhead
11075 redrawtags $mainheadid
11076 }
11077 run refill_reflist
11078}
11079
11080proc listrefs {id} {
11081 global idtags idheads idotherrefs
11082
11083 set x {}
11084 if {[info exists idtags($id)]} {
11085 set x $idtags($id)
11086 }
11087 set y {}
11088 if {[info exists idheads($id)]} {
11089 set y $idheads($id)
11090 }
11091 set z {}
11092 if {[info exists idotherrefs($id)]} {
11093 set z $idotherrefs($id)
11094 }
11095 return [list $x $y $z]
11096}
11097
11098proc add_tag_ctext {tag} {
11099 global ctext cached_tagcontent tagids
11100
11101 if {![info exists cached_tagcontent($tag)]} {
11102 catch {
11103 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11104 }
11105 }
11106 $ctext insert end "[mc "Tag"]: $tag\n" bold
11107 if {[info exists cached_tagcontent($tag)]} {
11108 set text $cached_tagcontent($tag)
11109 } else {
11110 set text "[mc "Id"]: $tagids($tag)"
11111 }
11112 appendwithlinks $text {}
11113}
11114
11115proc showtag {tag isnew} {
11116 global ctext cached_tagcontent tagids linknum tagobjid
11117
11118 if {$isnew} {
11119 addtohistory [list showtag $tag 0] savectextpos
11120 }
11121 $ctext conf -state normal
11122 clear_ctext
11123 settabs 0
11124 set linknum 0
11125 add_tag_ctext $tag
11126 maybe_scroll_ctext 1
11127 $ctext conf -state disabled
11128 init_flist {}
11129}
11130
11131proc showtags {id isnew} {
11132 global idtags ctext linknum
11133
11134 if {$isnew} {
11135 addtohistory [list showtags $id 0] savectextpos
11136 }
11137 $ctext conf -state normal
11138 clear_ctext
11139 settabs 0
11140 set linknum 0
11141 set sep {}
11142 foreach tag $idtags($id) {
11143 $ctext insert end $sep
11144 add_tag_ctext $tag
11145 set sep "\n\n"
11146 }
11147 maybe_scroll_ctext 1
11148 $ctext conf -state disabled
11149 init_flist {}
11150}
11151
11152proc doquit {} {
11153 global stopped
11154 global gitktmpdir
11155
11156 set stopped 100
11157 savestuff .
11158 destroy .
11159
11160 if {[info exists gitktmpdir]} {
11161 catch {file delete -force $gitktmpdir}
11162 }
11163}
11164
11165proc mkfontdisp {font top which} {
11166 global fontattr fontpref $font NS use_ttk
11167
11168 set fontpref($font) [set $font]
11169 ${NS}::button $top.${font}but -text $which \
11170 -command [list choosefont $font $which]
11171 ${NS}::label $top.$font -relief flat -font $font \
11172 -text $fontattr($font,family) -justify left
11173 grid x $top.${font}but $top.$font -sticky w
11174}
11175
11176proc choosefont {font which} {
11177 global fontparam fontlist fonttop fontattr
11178 global prefstop NS
11179
11180 set fontparam(which) $which
11181 set fontparam(font) $font
11182 set fontparam(family) [font actual $font -family]
11183 set fontparam(size) $fontattr($font,size)
11184 set fontparam(weight) $fontattr($font,weight)
11185 set fontparam(slant) $fontattr($font,slant)
11186 set top .gitkfont
11187 set fonttop $top
11188 if {![winfo exists $top]} {
11189 font create sample
11190 eval font config sample [font actual $font]
11191 ttk_toplevel $top
11192 make_transient $top $prefstop
11193 wm title $top [mc "Gitk font chooser"]
11194 ${NS}::label $top.l -textvariable fontparam(which)
11195 pack $top.l -side top
11196 set fontlist [lsort [font families]]
11197 ${NS}::frame $top.f
11198 listbox $top.f.fam -listvariable fontlist \
11199 -yscrollcommand [list $top.f.sb set]
11200 bind $top.f.fam <<ListboxSelect>> selfontfam
11201 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11202 pack $top.f.sb -side right -fill y
11203 pack $top.f.fam -side left -fill both -expand 1
11204 pack $top.f -side top -fill both -expand 1
11205 ${NS}::frame $top.g
11206 spinbox $top.g.size -from 4 -to 40 -width 4 \
11207 -textvariable fontparam(size) \
11208 -validatecommand {string is integer -strict %s}
11209 checkbutton $top.g.bold -padx 5 \
11210 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11211 -variable fontparam(weight) -onvalue bold -offvalue normal
11212 checkbutton $top.g.ital -padx 5 \
11213 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11214 -variable fontparam(slant) -onvalue italic -offvalue roman
11215 pack $top.g.size $top.g.bold $top.g.ital -side left
11216 pack $top.g -side top
11217 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11218 -background white
11219 $top.c create text 100 25 -anchor center -text $which -font sample \
11220 -fill black -tags text
11221 bind $top.c <Configure> [list centertext $top.c]
11222 pack $top.c -side top -fill x
11223 ${NS}::frame $top.buts
11224 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11225 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11226 bind $top <Key-Return> fontok
11227 bind $top <Key-Escape> fontcan
11228 grid $top.buts.ok $top.buts.can
11229 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11230 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11231 pack $top.buts -side bottom -fill x
11232 trace add variable fontparam write chg_fontparam
11233 } else {
11234 raise $top
11235 $top.c itemconf text -text $which
11236 }
11237 set i [lsearch -exact $fontlist $fontparam(family)]
11238 if {$i >= 0} {
11239 $top.f.fam selection set $i
11240 $top.f.fam see $i
11241 }
11242}
11243
11244proc centertext {w} {
11245 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11246}
11247
11248proc fontok {} {
11249 global fontparam fontpref prefstop
11250
11251 set f $fontparam(font)
11252 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11253 if {$fontparam(weight) eq "bold"} {
11254 lappend fontpref($f) "bold"
11255 }
11256 if {$fontparam(slant) eq "italic"} {
11257 lappend fontpref($f) "italic"
11258 }
11259 set w $prefstop.notebook.fonts.$f
11260 $w conf -text $fontparam(family) -font $fontpref($f)
11261
11262 fontcan
11263}
11264
11265proc fontcan {} {
11266 global fonttop fontparam
11267
11268 if {[info exists fonttop]} {
11269 catch {destroy $fonttop}
11270 catch {font delete sample}
11271 unset fonttop
11272 unset fontparam
11273 }
11274}
11275
11276if {[package vsatisfies [package provide Tk] 8.6]} {
11277 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11278 # function to make use of it.
11279 proc choosefont {font which} {
11280 tk fontchooser configure -title $which -font $font \
11281 -command [list on_choosefont $font $which]
11282 tk fontchooser show
11283 }
11284 proc on_choosefont {font which newfont} {
11285 global fontparam
11286 puts stderr "$font $newfont"
11287 array set f [font actual $newfont]
11288 set fontparam(which) $which
11289 set fontparam(font) $font
11290 set fontparam(family) $f(-family)
11291 set fontparam(size) $f(-size)
11292 set fontparam(weight) $f(-weight)
11293 set fontparam(slant) $f(-slant)
11294 fontok
11295 }
11296}
11297
11298proc selfontfam {} {
11299 global fonttop fontparam
11300
11301 set i [$fonttop.f.fam curselection]
11302 if {$i ne {}} {
11303 set fontparam(family) [$fonttop.f.fam get $i]
11304 }
11305}
11306
11307proc chg_fontparam {v sub op} {
11308 global fontparam
11309
11310 font config sample -$sub $fontparam($sub)
11311}
11312
11313# Create a property sheet tab page
11314proc create_prefs_page {w} {
11315 global NS
11316 set parent [join [lrange [split $w .] 0 end-1] .]
11317 if {[winfo class $parent] eq "TNotebook"} {
11318 ${NS}::frame $w
11319 } else {
11320 ${NS}::labelframe $w
11321 }
11322}
11323
11324proc prefspage_general {notebook} {
11325 global NS maxwidth maxgraphpct showneartags showlocalchanges
11326 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11327 global hideremotes want_ttk have_ttk maxrefs
11328
11329 set page [create_prefs_page $notebook.general]
11330
11331 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11332 grid $page.ldisp - -sticky w -pady 10
11333 ${NS}::label $page.spacer -text " "
11334 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11335 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11336 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11337 #xgettext:no-tcl-format
11338 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11339 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11340 grid x $page.maxpctl $page.maxpct -sticky w
11341 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11342 -variable showlocalchanges
11343 grid x $page.showlocal -sticky w
11344 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11345 -variable autoselect
11346 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11347 grid x $page.autoselect $page.autosellen -sticky w
11348 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11349 -variable hideremotes
11350 grid x $page.hideremotes -sticky w
11351
11352 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11353 grid $page.ddisp - -sticky w -pady 10
11354 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11355 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11356 grid x $page.tabstopl $page.tabstop -sticky w
11357 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11358 -variable showneartags
11359 grid x $page.ntag -sticky w
11360 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11361 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11362 grid x $page.maxrefsl $page.maxrefs -sticky w
11363 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11364 -variable limitdiffs
11365 grid x $page.ldiff -sticky w
11366 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11367 -variable perfile_attrs
11368 grid x $page.lattr -sticky w
11369
11370 ${NS}::entry $page.extdifft -textvariable extdifftool
11371 ${NS}::frame $page.extdifff
11372 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11373 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11374 pack $page.extdifff.l $page.extdifff.b -side left
11375 pack configure $page.extdifff.l -padx 10
11376 grid x $page.extdifff $page.extdifft -sticky ew
11377
11378 ${NS}::label $page.lgen -text [mc "General options"]
11379 grid $page.lgen - -sticky w -pady 10
11380 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11381 -text [mc "Use themed widgets"]
11382 if {$have_ttk} {
11383 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11384 } else {
11385 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11386 }
11387 grid x $page.want_ttk $page.ttk_note -sticky w
11388 return $page
11389}
11390
11391proc prefspage_colors {notebook} {
11392 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11393
11394 set page [create_prefs_page $notebook.colors]
11395
11396 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11397 grid $page.cdisp - -sticky w -pady 10
11398 label $page.ui -padx 40 -relief sunk -background $uicolor
11399 ${NS}::button $page.uibut -text [mc "Interface"] \
11400 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11401 grid x $page.uibut $page.ui -sticky w
11402 label $page.bg -padx 40 -relief sunk -background $bgcolor
11403 ${NS}::button $page.bgbut -text [mc "Background"] \
11404 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11405 grid x $page.bgbut $page.bg -sticky w
11406 label $page.fg -padx 40 -relief sunk -background $fgcolor
11407 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11408 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11409 grid x $page.fgbut $page.fg -sticky w
11410 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11411 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11412 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11413 [list $ctext tag conf d0 -foreground]]
11414 grid x $page.diffoldbut $page.diffold -sticky w
11415 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11416 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11417 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11418 [list $ctext tag conf dresult -foreground]]
11419 grid x $page.diffnewbut $page.diffnew -sticky w
11420 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11421 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11422 -command [list choosecolor diffcolors 2 $page.hunksep \
11423 [mc "diff hunk header"] \
11424 [list $ctext tag conf hunksep -foreground]]
11425 grid x $page.hunksepbut $page.hunksep -sticky w
11426 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11427 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11428 -command [list choosecolor markbgcolor {} $page.markbgsep \
11429 [mc "marked line background"] \
11430 [list $ctext tag conf omark -background]]
11431 grid x $page.markbgbut $page.markbgsep -sticky w
11432 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11433 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11434 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11435 grid x $page.selbgbut $page.selbgsep -sticky w
11436 return $page
11437}
11438
11439proc prefspage_fonts {notebook} {
11440 global NS
11441 set page [create_prefs_page $notebook.fonts]
11442 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11443 grid $page.cfont - -sticky w -pady 10
11444 mkfontdisp mainfont $page [mc "Main font"]
11445 mkfontdisp textfont $page [mc "Diff display font"]
11446 mkfontdisp uifont $page [mc "User interface font"]
11447 return $page
11448}
11449
11450proc doprefs {} {
11451 global maxwidth maxgraphpct use_ttk NS
11452 global oldprefs prefstop showneartags showlocalchanges
11453 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11454 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11455 global hideremotes want_ttk have_ttk
11456
11457 set top .gitkprefs
11458 set prefstop $top
11459 if {[winfo exists $top]} {
11460 raise $top
11461 return
11462 }
11463 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11464 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11465 set oldprefs($v) [set $v]
11466 }
11467 ttk_toplevel $top
11468 wm title $top [mc "Gitk preferences"]
11469 make_transient $top .
11470
11471 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11472 set notebook [ttk::notebook $top.notebook]
11473 } else {
11474 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11475 }
11476
11477 lappend pages [prefspage_general $notebook] [mc "General"]
11478 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11479 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11480 set col 0
11481 foreach {page title} $pages {
11482 if {$use_notebook} {
11483 $notebook add $page -text $title
11484 } else {
11485 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11486 -text $title -command [list raise $page]]
11487 $page configure -text $title
11488 grid $btn -row 0 -column [incr col] -sticky w
11489 grid $page -row 1 -column 0 -sticky news -columnspan 100
11490 }
11491 }
11492
11493 if {!$use_notebook} {
11494 grid columnconfigure $notebook 0 -weight 1
11495 grid rowconfigure $notebook 1 -weight 1
11496 raise [lindex $pages 0]
11497 }
11498
11499 grid $notebook -sticky news -padx 2 -pady 2
11500 grid rowconfigure $top 0 -weight 1
11501 grid columnconfigure $top 0 -weight 1
11502
11503 ${NS}::frame $top.buts
11504 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11505 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11506 bind $top <Key-Return> prefsok
11507 bind $top <Key-Escape> prefscan
11508 grid $top.buts.ok $top.buts.can
11509 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11510 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11511 grid $top.buts - - -pady 10 -sticky ew
11512 grid columnconfigure $top 2 -weight 1
11513 bind $top <Visibility> [list focus $top.buts.ok]
11514}
11515
11516proc choose_extdiff {} {
11517 global extdifftool
11518
11519 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11520 if {$prog ne {}} {
11521 set extdifftool $prog
11522 }
11523}
11524
11525proc choosecolor {v vi w x cmd} {
11526 global $v
11527
11528 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11529 -title [mc "Gitk: choose color for %s" $x]]
11530 if {$c eq {}} return
11531 $w conf -background $c
11532 lset $v $vi $c
11533 eval $cmd $c
11534}
11535
11536proc setselbg {c} {
11537 global bglist cflist
11538 foreach w $bglist {
11539 if {[winfo exists $w]} {
11540 $w configure -selectbackground $c
11541 }
11542 }
11543 $cflist tag configure highlight \
11544 -background [$cflist cget -selectbackground]
11545 allcanvs itemconf secsel -fill $c
11546}
11547
11548# This sets the background color and the color scheme for the whole UI.
11549# For some reason, tk_setPalette chooses a nasty dark red for selectColor
11550# if we don't specify one ourselves, which makes the checkbuttons and
11551# radiobuttons look bad. This chooses white for selectColor if the
11552# background color is light, or black if it is dark.
11553proc setui {c} {
11554 if {[tk windowingsystem] eq "win32"} { return }
11555 set bg [winfo rgb . $c]
11556 set selc black
11557 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11558 set selc white
11559 }
11560 tk_setPalette background $c selectColor $selc
11561}
11562
11563proc setbg {c} {
11564 global bglist
11565
11566 foreach w $bglist {
11567 if {[winfo exists $w]} {
11568 $w conf -background $c
11569 }
11570 }
11571}
11572
11573proc setfg {c} {
11574 global fglist canv
11575
11576 foreach w $fglist {
11577 if {[winfo exists $w]} {
11578 $w conf -foreground $c
11579 }
11580 }
11581 allcanvs itemconf text -fill $c
11582 $canv itemconf circle -outline $c
11583 $canv itemconf markid -outline $c
11584}
11585
11586proc prefscan {} {
11587 global oldprefs prefstop
11588
11589 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11590 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11591 global $v
11592 set $v $oldprefs($v)
11593 }
11594 catch {destroy $prefstop}
11595 unset prefstop
11596 fontcan
11597}
11598
11599proc prefsok {} {
11600 global maxwidth maxgraphpct
11601 global oldprefs prefstop showneartags showlocalchanges
11602 global fontpref mainfont textfont uifont
11603 global limitdiffs treediffs perfile_attrs
11604 global hideremotes
11605
11606 catch {destroy $prefstop}
11607 unset prefstop
11608 fontcan
11609 set fontchanged 0
11610 if {$mainfont ne $fontpref(mainfont)} {
11611 set mainfont $fontpref(mainfont)
11612 parsefont mainfont $mainfont
11613 eval font configure mainfont [fontflags mainfont]
11614 eval font configure mainfontbold [fontflags mainfont 1]
11615 setcoords
11616 set fontchanged 1
11617 }
11618 if {$textfont ne $fontpref(textfont)} {
11619 set textfont $fontpref(textfont)
11620 parsefont textfont $textfont
11621 eval font configure textfont [fontflags textfont]
11622 eval font configure textfontbold [fontflags textfont 1]
11623 }
11624 if {$uifont ne $fontpref(uifont)} {
11625 set uifont $fontpref(uifont)
11626 parsefont uifont $uifont
11627 eval font configure uifont [fontflags uifont]
11628 }
11629 settabs
11630 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11631 if {$showlocalchanges} {
11632 doshowlocalchanges
11633 } else {
11634 dohidelocalchanges
11635 }
11636 }
11637 if {$limitdiffs != $oldprefs(limitdiffs) ||
11638 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11639 # treediffs elements are limited by path;
11640 # won't have encodings cached if perfile_attrs was just turned on
11641 unset -nocomplain treediffs
11642 }
11643 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11644 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11645 redisplay
11646 } elseif {$showneartags != $oldprefs(showneartags) ||
11647 $limitdiffs != $oldprefs(limitdiffs)} {
11648 reselectline
11649 }
11650 if {$hideremotes != $oldprefs(hideremotes)} {
11651 rereadrefs
11652 }
11653}
11654
11655proc formatdate {d} {
11656 global datetimeformat
11657 if {$d ne {}} {
11658 # If $datetimeformat includes a timezone, display in the
11659 # timezone of the argument. Otherwise, display in local time.
11660 if {[string match {*%[zZ]*} $datetimeformat]} {
11661 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11662 # Tcl < 8.5 does not support -timezone. Emulate it by
11663 # setting TZ (e.g. TZ=<-0430>+04:30).
11664 global env
11665 if {[info exists env(TZ)]} {
11666 set savedTZ $env(TZ)
11667 }
11668 set zone [lindex $d 1]
11669 set sign [string map {+ - - +} [string index $zone 0]]
11670 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11671 set d [clock format [lindex $d 0] -format $datetimeformat]
11672 if {[info exists savedTZ]} {
11673 set env(TZ) $savedTZ
11674 } else {
11675 unset env(TZ)
11676 }
11677 }
11678 } else {
11679 set d [clock format [lindex $d 0] -format $datetimeformat]
11680 }
11681 }
11682 return $d
11683}
11684
11685# This list of encoding names and aliases is distilled from
11686# http://www.iana.org/assignments/character-sets.
11687# Not all of them are supported by Tcl.
11688set encoding_aliases {
11689 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11690 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11691 { ISO-10646-UTF-1 csISO10646UTF1 }
11692 { ISO_646.basic:1983 ref csISO646basic1983 }
11693 { INVARIANT csINVARIANT }
11694 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11695 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11696 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11697 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11698 { NATS-DANO iso-ir-9-1 csNATSDANO }
11699 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11700 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11701 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11702 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11703 { ISO-2022-KR csISO2022KR }
11704 { EUC-KR csEUCKR }
11705 { ISO-2022-JP csISO2022JP }
11706 { ISO-2022-JP-2 csISO2022JP2 }
11707 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11708 csISO13JISC6220jp }
11709 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11710 { IT iso-ir-15 ISO646-IT csISO15Italian }
11711 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11712 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11713 { greek7-old iso-ir-18 csISO18Greek7Old }
11714 { latin-greek iso-ir-19 csISO19LatinGreek }
11715 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11716 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11717 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11718 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11719 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11720 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11721 { INIS iso-ir-49 csISO49INIS }
11722 { INIS-8 iso-ir-50 csISO50INIS8 }
11723 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11724 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11725 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11726 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11727 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11728 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11729 csISO60Norwegian1 }
11730 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11731 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11732 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11733 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11734 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11735 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11736 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11737 { greek7 iso-ir-88 csISO88Greek7 }
11738 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11739 { iso-ir-90 csISO90 }
11740 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11741 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11742 csISO92JISC62991984b }
11743 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11744 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11745 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11746 csISO95JIS62291984handadd }
11747 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11748 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11749 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11750 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11751 CP819 csISOLatin1 }
11752 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11753 { T.61-7bit iso-ir-102 csISO102T617bit }
11754 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11755 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11756 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11757 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11758 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11759 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11760 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11761 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11762 arabic csISOLatinArabic }
11763 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11764 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11765 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11766 greek greek8 csISOLatinGreek }
11767 { T.101-G2 iso-ir-128 csISO128T101G2 }
11768 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11769 csISOLatinHebrew }
11770 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11771 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11772 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11773 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11774 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11775 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11776 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11777 csISOLatinCyrillic }
11778 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11779 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11780 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11781 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11782 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11783 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11784 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11785 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11786 { ISO_10367-box iso-ir-155 csISO10367Box }
11787 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11788 { latin-lap lap iso-ir-158 csISO158Lap }
11789 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11790 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11791 { us-dk csUSDK }
11792 { dk-us csDKUS }
11793 { JIS_X0201 X0201 csHalfWidthKatakana }
11794 { KSC5636 ISO646-KR csKSC5636 }
11795 { ISO-10646-UCS-2 csUnicode }
11796 { ISO-10646-UCS-4 csUCS4 }
11797 { DEC-MCS dec csDECMCS }
11798 { hp-roman8 roman8 r8 csHPRoman8 }
11799 { macintosh mac csMacintosh }
11800 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11801 csIBM037 }
11802 { IBM038 EBCDIC-INT cp038 csIBM038 }
11803 { IBM273 CP273 csIBM273 }
11804 { IBM274 EBCDIC-BE CP274 csIBM274 }
11805 { IBM275 EBCDIC-BR cp275 csIBM275 }
11806 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11807 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11808 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11809 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11810 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11811 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11812 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11813 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11814 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11815 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11816 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11817 { IBM437 cp437 437 csPC8CodePage437 }
11818 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11819 { IBM775 cp775 csPC775Baltic }
11820 { IBM850 cp850 850 csPC850Multilingual }
11821 { IBM851 cp851 851 csIBM851 }
11822 { IBM852 cp852 852 csPCp852 }
11823 { IBM855 cp855 855 csIBM855 }
11824 { IBM857 cp857 857 csIBM857 }
11825 { IBM860 cp860 860 csIBM860 }
11826 { IBM861 cp861 861 cp-is csIBM861 }
11827 { IBM862 cp862 862 csPC862LatinHebrew }
11828 { IBM863 cp863 863 csIBM863 }
11829 { IBM864 cp864 csIBM864 }
11830 { IBM865 cp865 865 csIBM865 }
11831 { IBM866 cp866 866 csIBM866 }
11832 { IBM868 CP868 cp-ar csIBM868 }
11833 { IBM869 cp869 869 cp-gr csIBM869 }
11834 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11835 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11836 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11837 { IBM891 cp891 csIBM891 }
11838 { IBM903 cp903 csIBM903 }
11839 { IBM904 cp904 904 csIBBM904 }
11840 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11841 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11842 { IBM1026 CP1026 csIBM1026 }
11843 { EBCDIC-AT-DE csIBMEBCDICATDE }
11844 { EBCDIC-AT-DE-A csEBCDICATDEA }
11845 { EBCDIC-CA-FR csEBCDICCAFR }
11846 { EBCDIC-DK-NO csEBCDICDKNO }
11847 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11848 { EBCDIC-FI-SE csEBCDICFISE }
11849 { EBCDIC-FI-SE-A csEBCDICFISEA }
11850 { EBCDIC-FR csEBCDICFR }
11851 { EBCDIC-IT csEBCDICIT }
11852 { EBCDIC-PT csEBCDICPT }
11853 { EBCDIC-ES csEBCDICES }
11854 { EBCDIC-ES-A csEBCDICESA }
11855 { EBCDIC-ES-S csEBCDICESS }
11856 { EBCDIC-UK csEBCDICUK }
11857 { EBCDIC-US csEBCDICUS }
11858 { UNKNOWN-8BIT csUnknown8BiT }
11859 { MNEMONIC csMnemonic }
11860 { MNEM csMnem }
11861 { VISCII csVISCII }
11862 { VIQR csVIQR }
11863 { KOI8-R csKOI8R }
11864 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11865 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11866 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11867 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11868 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11869 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11870 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11871 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11872 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11873 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11874 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11875 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11876 { IBM1047 IBM-1047 }
11877 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11878 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11879 { UNICODE-1-1 csUnicode11 }
11880 { CESU-8 csCESU-8 }
11881 { BOCU-1 csBOCU-1 }
11882 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11883 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11884 l8 }
11885 { ISO-8859-15 ISO_8859-15 Latin-9 }
11886 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11887 { GBK CP936 MS936 windows-936 }
11888 { JIS_Encoding csJISEncoding }
11889 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11890 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11891 EUC-JP }
11892 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11893 { ISO-10646-UCS-Basic csUnicodeASCII }
11894 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11895 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11896 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11897 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11898 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11899 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11900 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11901 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11902 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11903 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11904 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11905 { Ventura-US csVenturaUS }
11906 { Ventura-International csVenturaInternational }
11907 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11908 { PC8-Turkish csPC8Turkish }
11909 { IBM-Symbols csIBMSymbols }
11910 { IBM-Thai csIBMThai }
11911 { HP-Legal csHPLegal }
11912 { HP-Pi-font csHPPiFont }
11913 { HP-Math8 csHPMath8 }
11914 { Adobe-Symbol-Encoding csHPPSMath }
11915 { HP-DeskTop csHPDesktop }
11916 { Ventura-Math csVenturaMath }
11917 { Microsoft-Publishing csMicrosoftPublishing }
11918 { Windows-31J csWindows31J }
11919 { GB2312 csGB2312 }
11920 { Big5 csBig5 }
11921}
11922
11923proc tcl_encoding {enc} {
11924 global encoding_aliases tcl_encoding_cache
11925 if {[info exists tcl_encoding_cache($enc)]} {
11926 return $tcl_encoding_cache($enc)
11927 }
11928 set names [encoding names]
11929 set lcnames [string tolower $names]
11930 set enc [string tolower $enc]
11931 set i [lsearch -exact $lcnames $enc]
11932 if {$i < 0} {
11933 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11934 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11935 set i [lsearch -exact $lcnames $encx]
11936 }
11937 }
11938 if {$i < 0} {
11939 foreach l $encoding_aliases {
11940 set ll [string tolower $l]
11941 if {[lsearch -exact $ll $enc] < 0} continue
11942 # look through the aliases for one that tcl knows about
11943 foreach e $ll {
11944 set i [lsearch -exact $lcnames $e]
11945 if {$i < 0} {
11946 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11947 set i [lsearch -exact $lcnames $ex]
11948 }
11949 }
11950 if {$i >= 0} break
11951 }
11952 break
11953 }
11954 }
11955 set tclenc {}
11956 if {$i >= 0} {
11957 set tclenc [lindex $names $i]
11958 }
11959 set tcl_encoding_cache($enc) $tclenc
11960 return $tclenc
11961}
11962
11963proc gitattr {path attr default} {
11964 global path_attr_cache
11965 if {[info exists path_attr_cache($attr,$path)]} {
11966 set r $path_attr_cache($attr,$path)
11967 } else {
11968 set r "unspecified"
11969 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11970 regexp "(.*): $attr: (.*)" $line m f r
11971 }
11972 set path_attr_cache($attr,$path) $r
11973 }
11974 if {$r eq "unspecified"} {
11975 return $default
11976 }
11977 return $r
11978}
11979
11980proc cache_gitattr {attr pathlist} {
11981 global path_attr_cache
11982 set newlist {}
11983 foreach path $pathlist {
11984 if {![info exists path_attr_cache($attr,$path)]} {
11985 lappend newlist $path
11986 }
11987 }
11988 set lim 1000
11989 if {[tk windowingsystem] == "win32"} {
11990 # windows has a 32k limit on the arguments to a command...
11991 set lim 30
11992 }
11993 while {$newlist ne {}} {
11994 set head [lrange $newlist 0 [expr {$lim - 1}]]
11995 set newlist [lrange $newlist $lim end]
11996 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11997 foreach row [split $rlist "\n"] {
11998 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11999 if {[string index $path 0] eq "\""} {
12000 set path [encoding convertfrom [lindex $path 0]]
12001 }
12002 set path_attr_cache($attr,$path) $value
12003 }
12004 }
12005 }
12006 }
12007}
12008
12009proc get_path_encoding {path} {
12010 global gui_encoding perfile_attrs
12011 set tcl_enc $gui_encoding
12012 if {$path ne {} && $perfile_attrs} {
12013 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12014 if {$enc2 ne {}} {
12015 set tcl_enc $enc2
12016 }
12017 }
12018 return $tcl_enc
12019}
12020
12021## For msgcat loading, first locate the installation location.
12022if { [info exists ::env(GITK_MSGSDIR)] } {
12023 ## Msgsdir was manually set in the environment.
12024 set gitk_msgsdir $::env(GITK_MSGSDIR)
12025} else {
12026 ## Let's guess the prefix from argv0.
12027 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12028 set gitk_libdir [file join $gitk_prefix share gitk lib]
12029 set gitk_msgsdir [file join $gitk_libdir msgs]
12030 unset gitk_prefix
12031}
12032
12033## Internationalization (i18n) through msgcat and gettext. See
12034## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12035package require msgcat
12036namespace import ::msgcat::mc
12037## And eventually load the actual message catalog
12038::msgcat::mcload $gitk_msgsdir
12039
12040# First check that Tcl/Tk is recent enough
12041if {[catch {package require Tk 8.4} err]} {
12042 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12043 Gitk requires at least Tcl/Tk 8.4."]
12044 exit 1
12045}
12046
12047# on OSX bring the current Wish process window to front
12048if {[tk windowingsystem] eq "aqua"} {
12049 exec osascript -e [format {
12050 tell application "System Events"
12051 set frontmost of processes whose unix id is %d to true
12052 end tell
12053 } [pid] ]
12054}
12055
12056# Unset GIT_TRACE var if set
12057if { [info exists ::env(GIT_TRACE)] } {
12058 unset ::env(GIT_TRACE)
12059}
12060
12061# defaults...
12062set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12063
12064set gitencoding {}
12065catch {
12066 set gitencoding [exec git config --get i18n.commitencoding]
12067}
12068catch {
12069 set gitencoding [exec git config --get i18n.logoutputencoding]
12070}
12071if {$gitencoding == ""} {
12072 set gitencoding "utf-8"
12073}
12074set tclencoding [tcl_encoding $gitencoding]
12075if {$tclencoding == {}} {
12076 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12077}
12078
12079set gui_encoding [encoding system]
12080catch {
12081 set enc [exec git config --get gui.encoding]
12082 if {$enc ne {}} {
12083 set tclenc [tcl_encoding $enc]
12084 if {$tclenc ne {}} {
12085 set gui_encoding $tclenc
12086 } else {
12087 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12088 }
12089 }
12090}
12091
12092set log_showroot true
12093catch {
12094 set log_showroot [exec git config --bool --get log.showroot]
12095}
12096
12097if {[tk windowingsystem] eq "aqua"} {
12098 set mainfont {{Lucida Grande} 9}
12099 set textfont {Monaco 9}
12100 set uifont {{Lucida Grande} 9 bold}
12101} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12102 # fontconfig!
12103 set mainfont {sans 9}
12104 set textfont {monospace 9}
12105 set uifont {sans 9 bold}
12106} else {
12107 set mainfont {Helvetica 9}
12108 set textfont {Courier 9}
12109 set uifont {Helvetica 9 bold}
12110}
12111set tabstop 8
12112set findmergefiles 0
12113set maxgraphpct 50
12114set maxwidth 16
12115set revlistorder 0
12116set fastdate 0
12117set uparrowlen 5
12118set downarrowlen 5
12119set mingaplen 100
12120set cmitmode "patch"
12121set wrapcomment "none"
12122set showneartags 1
12123set hideremotes 0
12124set maxrefs 20
12125set visiblerefs {"master"}
12126set maxlinelen 200
12127set showlocalchanges 1
12128set limitdiffs 1
12129set datetimeformat "%Y-%m-%d %H:%M:%S"
12130set autoselect 1
12131set autosellen 40
12132set perfile_attrs 0
12133set want_ttk 1
12134
12135if {[tk windowingsystem] eq "aqua"} {
12136 set extdifftool "opendiff"
12137} else {
12138 set extdifftool "meld"
12139}
12140
12141set colors {green red blue magenta darkgrey brown orange}
12142if {[tk windowingsystem] eq "win32"} {
12143 set uicolor SystemButtonFace
12144 set uifgcolor SystemButtonText
12145 set uifgdisabledcolor SystemDisabledText
12146 set bgcolor SystemWindow
12147 set fgcolor SystemWindowText
12148 set selectbgcolor SystemHighlight
12149} else {
12150 set uicolor grey85
12151 set uifgcolor black
12152 set uifgdisabledcolor "#999"
12153 set bgcolor white
12154 set fgcolor black
12155 set selectbgcolor gray85
12156}
12157set diffcolors {red "#00a000" blue}
12158set diffcontext 3
12159set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12160set ignorespace 0
12161set worddiff ""
12162set markbgcolor "#e0e0ff"
12163
12164set headbgcolor green
12165set headfgcolor black
12166set headoutlinecolor black
12167set remotebgcolor #ffddaa
12168set tagbgcolor yellow
12169set tagfgcolor black
12170set tagoutlinecolor black
12171set reflinecolor black
12172set filesepbgcolor #aaaaaa
12173set filesepfgcolor black
12174set linehoverbgcolor #ffff80
12175set linehoverfgcolor black
12176set linehoveroutlinecolor black
12177set mainheadcirclecolor yellow
12178set workingfilescirclecolor red
12179set indexcirclecolor green
12180set circlecolors {white blue gray blue blue}
12181set linkfgcolor blue
12182set circleoutlinecolor $fgcolor
12183set foundbgcolor yellow
12184set currentsearchhitbgcolor orange
12185
12186# button for popping up context menus
12187if {[tk windowingsystem] eq "aqua"} {
12188 set ctxbut <Button-2>
12189} else {
12190 set ctxbut <Button-3>
12191}
12192
12193catch {
12194 # follow the XDG base directory specification by default. See
12195 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12196 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12197 # XDG_CONFIG_HOME environment variable is set
12198 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12199 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12200 } else {
12201 # default XDG_CONFIG_HOME
12202 set config_file "~/.config/git/gitk"
12203 set config_file_tmp "~/.config/git/gitk-tmp"
12204 }
12205 if {![file exists $config_file]} {
12206 # for backward compatibility use the old config file if it exists
12207 if {[file exists "~/.gitk"]} {
12208 set config_file "~/.gitk"
12209 set config_file_tmp "~/.gitk-tmp"
12210 } elseif {![file exists [file dirname $config_file]]} {
12211 file mkdir [file dirname $config_file]
12212 }
12213 }
12214 source $config_file
12215}
12216config_check_tmp_exists 50
12217
12218set config_variables {
12219 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12220 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12221 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12222 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12223 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12224 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12225 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12226 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12227 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12228 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12229}
12230foreach var $config_variables {
12231 config_init_trace $var
12232 trace add variable $var write config_variable_change_cb
12233}
12234
12235parsefont mainfont $mainfont
12236eval font create mainfont [fontflags mainfont]
12237eval font create mainfontbold [fontflags mainfont 1]
12238
12239parsefont textfont $textfont
12240eval font create textfont [fontflags textfont]
12241eval font create textfontbold [fontflags textfont 1]
12242
12243parsefont uifont $uifont
12244eval font create uifont [fontflags uifont]
12245
12246setui $uicolor
12247
12248setoptions
12249
12250# check that we can find a .git directory somewhere...
12251if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12252 show_error {} . [mc "Cannot find a git repository here."]
12253 exit 1
12254}
12255
12256set selecthead {}
12257set selectheadid {}
12258
12259set revtreeargs {}
12260set cmdline_files {}
12261set i 0
12262set revtreeargscmd {}
12263foreach arg $argv {
12264 switch -glob -- $arg {
12265 "" { }
12266 "--" {
12267 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12268 break
12269 }
12270 "--select-commit=*" {
12271 set selecthead [string range $arg 16 end]
12272 }
12273 "--argscmd=*" {
12274 set revtreeargscmd [string range $arg 10 end]
12275 }
12276 default {
12277 lappend revtreeargs $arg
12278 }
12279 }
12280 incr i
12281}
12282
12283if {$selecthead eq "HEAD"} {
12284 set selecthead {}
12285}
12286
12287if {$i >= [llength $argv] && $revtreeargs ne {}} {
12288 # no -- on command line, but some arguments (other than --argscmd)
12289 if {[catch {
12290 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12291 set cmdline_files [split $f "\n"]
12292 set n [llength $cmdline_files]
12293 set revtreeargs [lrange $revtreeargs 0 end-$n]
12294 # Unfortunately git rev-parse doesn't produce an error when
12295 # something is both a revision and a filename. To be consistent
12296 # with git log and git rev-list, check revtreeargs for filenames.
12297 foreach arg $revtreeargs {
12298 if {[file exists $arg]} {
12299 show_error {} . [mc "Ambiguous argument '%s': both revision\
12300 and filename" $arg]
12301 exit 1
12302 }
12303 }
12304 } err]} {
12305 # unfortunately we get both stdout and stderr in $err,
12306 # so look for "fatal:".
12307 set i [string first "fatal:" $err]
12308 if {$i > 0} {
12309 set err [string range $err [expr {$i + 6}] end]
12310 }
12311 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12312 exit 1
12313 }
12314}
12315
12316set nullid "0000000000000000000000000000000000000000"
12317set nullid2 "0000000000000000000000000000000000000001"
12318set nullfile "/dev/null"
12319
12320set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12321if {![info exists have_ttk]} {
12322 set have_ttk [llength [info commands ::ttk::style]]
12323}
12324set use_ttk [expr {$have_ttk && $want_ttk}]
12325set NS [expr {$use_ttk ? "ttk" : ""}]
12326
12327regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12328
12329set show_notes {}
12330if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12331 set show_notes "--show-notes"
12332}
12333
12334set appname "gitk"
12335
12336set runq {}
12337set history {}
12338set historyindex 0
12339set fh_serial 0
12340set nhl_names {}
12341set highlight_paths {}
12342set findpattern {}
12343set searchdirn -forwards
12344set boldids {}
12345set boldnameids {}
12346set diffelide {0 0}
12347set markingmatches 0
12348set linkentercount 0
12349set need_redisplay 0
12350set nrows_drawn 0
12351set firsttabstop 0
12352
12353set nextviewnum 1
12354set curview 0
12355set selectedview 0
12356set selectedhlview [mc "None"]
12357set highlight_related [mc "None"]
12358set highlight_files {}
12359set viewfiles(0) {}
12360set viewperm(0) 0
12361set viewchanged(0) 0
12362set viewargs(0) {}
12363set viewargscmd(0) {}
12364
12365set selectedline {}
12366set numcommits 0
12367set loginstance 0
12368set cmdlineok 0
12369set stopped 0
12370set stuffsaved 0
12371set patchnum 0
12372set lserial 0
12373set hasworktree [hasworktree]
12374set cdup {}
12375if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12376 set cdup [exec git rev-parse --show-cdup]
12377}
12378set worktree [exec git rev-parse --show-toplevel]
12379setcoords
12380makewindow
12381catch {
12382 image create photo gitlogo -width 16 -height 16
12383
12384 image create photo gitlogominus -width 4 -height 2
12385 gitlogominus put #C00000 -to 0 0 4 2
12386 gitlogo copy gitlogominus -to 1 5
12387 gitlogo copy gitlogominus -to 6 5
12388 gitlogo copy gitlogominus -to 11 5
12389 image delete gitlogominus
12390
12391 image create photo gitlogoplus -width 4 -height 4
12392 gitlogoplus put #008000 -to 1 0 3 4
12393 gitlogoplus put #008000 -to 0 1 4 3
12394 gitlogo copy gitlogoplus -to 1 9
12395 gitlogo copy gitlogoplus -to 6 9
12396 gitlogo copy gitlogoplus -to 11 9
12397 image delete gitlogoplus
12398
12399 image create photo gitlogo32 -width 32 -height 32
12400 gitlogo32 copy gitlogo -zoom 2 2
12401
12402 wm iconphoto . -default gitlogo gitlogo32
12403}
12404# wait for the window to become visible
12405tkwait visibility .
12406wm title . "[reponame] - $appname"
12407update
12408readrefs
12409
12410if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12411 # create a view for the files/dirs specified on the command line
12412 set curview 1
12413 set selectedview 1
12414 set nextviewnum 2
12415 set viewname(1) [mc "Command line"]
12416 set viewfiles(1) $cmdline_files
12417 set viewargs(1) $revtreeargs
12418 set viewargscmd(1) $revtreeargscmd
12419 set viewperm(1) 0
12420 set viewchanged(1) 0
12421 set vdatemode(1) 0
12422 addviewmenu 1
12423 .bar.view entryconf [mca "Edit view..."] -state normal
12424 .bar.view entryconf [mca "Delete view"] -state normal
12425}
12426
12427if {[info exists permviews]} {
12428 foreach v $permviews {
12429 set n $nextviewnum
12430 incr nextviewnum
12431 set viewname($n) [lindex $v 0]
12432 set viewfiles($n) [lindex $v 1]
12433 set viewargs($n) [lindex $v 2]
12434 set viewargscmd($n) [lindex $v 3]
12435 set viewperm($n) 1
12436 set viewchanged($n) 0
12437 addviewmenu $n
12438 }
12439}
12440
12441if {[tk windowingsystem] eq "win32"} {
12442 focus -force .
12443}
12444
12445getcommits {}
12446
12447# Local variables:
12448# mode: tcl
12449# indent-tabs-mode: t
12450# tab-width: 8
12451# End: