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