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