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