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