1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
5# Copyright © 2005-2014 Paul Mackerras. All rights reserved.
6# This program is free software; it may be used, copied, modified
7# and distributed under the terms of the GNU General Public Licence,
8# either version 2, or (at your option) any later version.
9
10package require Tk
11
12proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
15}
16
17proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
22 }
23 return [file tail $n]
24}
25
26proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
30 }
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
40 }
41 }
42 }
43 return $_gitworktree
44}
45
46# A simple scheduler for compute-intensive stuff.
47# The aim is to make sure that event handlers for GUI actions can
48# run at least every 50-100 ms. Unfortunately fileevent handlers are
49# run before X event handlers, so reading from a fast source can
50# make the GUI completely unresponsive.
51proc run args {
52 global isonrunq runq currunq
53
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
58 }
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
61}
62
63proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
65}
66
67proc filereadable {fd script} {
68 global runq currunq
69
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
73 }
74 lappend runq [list $fd $script]
75}
76
77proc nukefile {fd} {
78 global runq
79
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
85 }
86 }
87}
88
89proc dorunq {} {
90 global isonrunq runq currunq
91
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
110 }
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
113 }
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
116 }
117 if {$runq ne {}} {
118 after idle dorunq
119 }
120}
121
122proc reg_instance {fd} {
123 global commfd leftover loginstance
124
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
129}
130
131proc unmerged_files {files} {
132 global nr_unmerged
133
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
142 }
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
151 }
152 }
153 catch {close $fd}
154 return $mlist
155}
156
157proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
161
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
179 }
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
187 }
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
197 }
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
207 }
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
213 }
214 }
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
218 }
219 }
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
226 }
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
237 }
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
245 }
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
252 }
253 "--not" - "--all" {
254 lappend revargs $arg
255 }
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
260 }
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
263 }
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
272 }
273 lappend glflags $arg
274 }
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
279 }
280 lappend revargs $arg
281 }
282 }
283 }
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
290}
291
292proc parseviewrevs {view revs} {
293 global vposids vnegids
294
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
299 }
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
315 }
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
318 }
319 break
320 }
321 lappend badrev $line
322 }
323 }
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
326 }
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
339 }
340 }
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
347 }
348 lappend pos $id
349 }
350 incr sdm -1
351 }
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
355}
356
357# Start off a git log process and arrange to read its output
358proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
367
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
374
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
382 }
383 set args [concat $args [split $str "\n"]]
384 }
385 set vcanopt($view) [parseviewargs $view $args]
386
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
398 }
399 return 0
400 }
401 }
402 set vfilelimit($view) $files
403
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
408 }
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
412 }
413
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
420 }
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
427 }
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
430 }
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
434 }
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
440}
441
442proc stop_instance {inst} {
443 global commfd leftover
444
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
448
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
453 }
454 }
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
459}
460
461proc stop_backends {} {
462 global commfd
463
464 foreach inst [array names commfd] {
465 stop_instance $inst
466 }
467}
468
469proc stop_rev_list {view} {
470 global viewinstances
471
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
474 }
475 set viewinstances($view) {}
476}
477
478proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
480
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
487 }
488}
489
490proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
492
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
500 }
501}
502
503proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
511
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
518 }
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
523 }
524 }
525 if {$showlocalchanges} {
526 doshowlocalchanges
527 }
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
534 }
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
549 }
550 } else {
551 lappend $newrevs $rev
552 }
553 }
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
557 }
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
561 }
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
568 }
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
571 }
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
577 }
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
585 }
586}
587
588proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
592
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
596 }
597
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
600 }
601 resetvarcs $curview
602 set selectedline {}
603 unset -nocomplain currentid
604 unset -nocomplain thickerline
605 unset -nocomplain treediffs
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
610 }
611 clear_display
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
618}
619
620# This makes a string representation of a positive integer which
621# sorts as a string in numerical order
622proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
629 }
630 return [format "z%.8x" $n]
631}
632
633# Procedures used in reordering commits from git log (without
634# --topo-order) into the order for display.
635
636proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
639
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
652}
653
654proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
657
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
662 }
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
665 }
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
669 }
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
672 }
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
675 }
676 unset -nocomplain ordertok
677}
678
679# returns a list of the commits with no children
680proc seeds {v} {
681 global vdownptr vleftptr varcstart
682
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
688 }
689 return $ret
690}
691
692proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
696
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
702 }
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
706 }
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
709 }
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
715 }
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
724 }
725 }
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
730 }
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
737 }
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
741 }
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
748 }
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
754 }
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
763}
764
765proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
768
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
785 }
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
795 }
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
798 }
799}
800
801proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
804
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
817 }
818 }
819 }
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
827 }
828 }
829 set a $b
830 }
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
837 }
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
843 }
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
852 }
853 }
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
858 }
859 if {$tok eq $oldtok} {
860 continue
861 }
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
868 }
869 }
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
875 }
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
878 }
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
885 }
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
888 }
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
891 }
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
900 }
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
905 }
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
912 }
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
916 }
917 lset vlastins($v) $ka $a
918 }
919 }
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
924 }
925 }
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
928}
929
930# Fix up the graph after we have found out that in view $v,
931# $p (a commit that we have already seen) is actually the parent
932# of the last commit in arc $a.
933proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
935
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
940 }
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
946 }
947}
948
949proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
953
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
964 }
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
970 }
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
979 }
980 }
981 }
982}
983
984proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
987
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
994 }
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1007 }
1008 }
1009 setcanvscroll
1010 drawvisible
1011}
1012
1013proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1017
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1022 }
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1029 }
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1039 }
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1044 }
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1047 }
1048 setcanvscroll
1049 drawvisible
1050}
1051
1052proc real_children {vp} {
1053 global children nullid nullid2
1054
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1059 }
1060 }
1061 return $kids
1062}
1063
1064proc first_real_child {vp} {
1065 global children nullid nullid2
1066
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1070 }
1071 }
1072 return {}
1073}
1074
1075proc last_real_child {vp} {
1076 global children nullid nullid2
1077
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1083 }
1084 }
1085 return {}
1086}
1087
1088proc vtokcmp {v a b} {
1089 global varctok varcid
1090
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1093}
1094
1095# This assumes that if lim is not given, the caller has checked that
1096# arc a's token is less than $vtokmod($v)
1097proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1099
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1106 }
1107 }
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1114 }
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1119 }
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1121 }
1122 set vrowmod($v) $r
1123 undolayout $r
1124 }
1125}
1126
1127proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1132
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1138 }
1139 unset -nocomplain cached_commitrow
1140 }
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1147 }
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1162 }
1163 set row [lindex $varcrow($v) $a]
1164 }
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1176 }
1177 if {$a == 0} break
1178 }
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1185 }
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1191 }
1192}
1193
1194# Test whether view $v contains commit $id
1195proc commitinview {id v} {
1196 global varcid
1197
1198 return [info exists varcid($v,$id)]
1199}
1200
1201# Return the row number for commit $id in the current view
1202proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1205
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1210 }
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1214 }
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1217 }
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1222 }
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1226}
1227
1228# Returns 1 if a is on an earlier row than b, otherwise 0
1229proc comes_before {a b} {
1230 global varcid varctok curview
1231
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1236 }
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1240 }
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1242}
1243
1244proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1247 }
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1259 }
1260 }
1261 return $lo
1262}
1263
1264# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1269
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1272 }
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1288 }
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1292 }
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1299 }
1300 }
1301 incr r $al
1302 }
1303}
1304
1305proc commitonrow {row} {
1306 global displayorder
1307
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1312 }
1313 return $id
1314}
1315
1316proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1319
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1336 }
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1340 }
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1344 }
1345 }
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1349 }
1350 }
1351}
1352
1353# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354# Assumes we already have an arc for $rwid.
1355proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1357
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1363 }
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1369 }
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1376 }
1377}
1378
1379# Mechanism for registering a command to be executed when we come
1380# across a particular commit. To handle the case when only the
1381# prefix of the commit is known, the commitinterest array is now
1382# indexed by the first 4 characters of the ID. Each element is a
1383# list of id, cmd pairs.
1384proc interestedin {id cmd} {
1385 global commitinterest
1386
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1388}
1389
1390proc check_interest {id scripts} {
1391 global commitinterest
1392
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1401 }
1402 }
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1407 }
1408 }
1409 return $scripts
1410}
1411
1412proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1418
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1423 }
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1427 }
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1434 }
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1441 }
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq [mc "Command line"]} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1449 }
1450 } else {
1451 set err "Error reading commits$fv: $err"
1452 }
1453 error_popup $err
1454 }
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1461 }
1462 if {$view == $curview} {
1463 run chewcommits
1464 }
1465 return 0
1466 }
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1475 }
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1482 }
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1495 }
1496 set ids [string range $ids 1 end]
1497 }
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1503 }
1504 }
1505 }
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1510 }
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1513 }
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1516
1517 lappend vshortids($view,[string range $id 0 3]) $id
1518
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1534 }
1535 }
1536 }
1537
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1542 }
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1547 }
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1559 }
1560 }
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1564 }
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1567 }
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1572 }
1573
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 unset -nocomplain ordertok
1583 }
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1586 }
1587 }
1588 incr i
1589 }
1590
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1593 }
1594 if {$gotsome} {
1595 global numcommits hlview
1596
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1600 }
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1604 }
1605 foreach s $scripts {
1606 eval $s
1607 }
1608 }
1609 return 2
1610}
1611
1612proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1615
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1620
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1624
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1630 }
1631 }
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1638 }
1639 notbusy layout
1640 }
1641 return 0
1642}
1643
1644proc do_readcommit {id} {
1645 global tclencoding
1646
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1653 }
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1658
1659 return $contents
1660}
1661
1662proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1665}
1666
1667proc parsecommit {id contents listed} {
1668 global commitinfo
1669
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1681 }
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1693 }
1694 }
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1701 }
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1706 }
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1715 }
1716 set comment $newcomment
1717 }
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1727 }
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1730}
1731
1732proc getcommit {id} {
1733 global commitdata commitinfo
1734
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1741 }
1742 }
1743 return 1
1744}
1745
1746# Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747# and are present in the current view.
1748# This is fairly slow...
1749proc longid {prefix} {
1750 global varcid curview vshortids
1751
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1761 }
1762 }
1763 }
1764 }
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1769 }
1770 }
1771 return $ids
1772}
1773
1774proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1779
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 unset -nocomplain $v
1782 }
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1794 }
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1807 }
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1813 }
1814 }
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1823 }
1824 }
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1829 }
1830 }
1831}
1832
1833# skip over fake commits
1834proc first_real_row {} {
1835 global nullid nullid2 numcommits
1836
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1841 }
1842 }
1843 return $row
1844}
1845
1846# update things for a head moved to a child of its previous location
1847proc movehead {id name} {
1848 global headids idheads
1849
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1853}
1854
1855# update things when a head has been removed
1856proc removehead {id name} {
1857 global headids idheads
1858
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1865 }
1866 }
1867 unset headids($name)
1868}
1869
1870proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1875 }
1876 return $w
1877}
1878
1879proc make_transient {window origin} {
1880 global have_tk85
1881
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1887
1888 wm transient $window $origin
1889
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1894 }
1895}
1896
1897proc show_error {w top msg} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1910}
1911
1912proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1921 }
1922}
1923
1924proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1943}
1944
1945proc setoptions {} {
1946 global use_ttk
1947
1948 if {[tk windowingsystem] ne "win32"} {
1949 option add *Panedwindow.showHandle 1 startupFile
1950 option add *Panedwindow.sashRelief raised startupFile
1951 if {[tk windowingsystem] ne "aqua"} {
1952 option add *Menu.font uifont startupFile
1953 }
1954 } else {
1955 option add *Menu.TearOff 0 startupFile
1956 }
1957 option add *Button.font uifont startupFile
1958 option add *Checkbutton.font uifont startupFile
1959 option add *Radiobutton.font uifont startupFile
1960 option add *Menubutton.font uifont startupFile
1961 option add *Label.font uifont startupFile
1962 option add *Message.font uifont startupFile
1963 option add *Entry.font textfont startupFile
1964 option add *Text.font textfont startupFile
1965 option add *Labelframe.font uifont startupFile
1966 option add *Spinbox.font textfont startupFile
1967 option add *Listbox.font mainfont startupFile
1968}
1969
1970proc setttkstyle {} {
1971 eval font configure TkDefaultFont [fontflags mainfont]
1972 eval font configure TkTextFont [fontflags textfont]
1973 eval font configure TkHeadingFont [fontflags mainfont]
1974 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1975 eval font configure TkTooltipFont [fontflags uifont]
1976 eval font configure TkFixedFont [fontflags textfont]
1977 eval font configure TkIconFont [fontflags uifont]
1978 eval font configure TkMenuFont [fontflags uifont]
1979 eval font configure TkSmallCaptionFont [fontflags uifont]
1980}
1981
1982# Make a menu and submenus.
1983# m is the window name for the menu, items is the list of menu items to add.
1984# Each item is a list {mc label type description options...}
1985# mc is ignored; it's so we can put mc there to alert xgettext
1986# label is the string that appears in the menu
1987# type is cascade, command or radiobutton (should add checkbutton)
1988# description depends on type; it's the sublist for cascade, the
1989# command to invoke for command, or {variable value} for radiobutton
1990proc makemenu {m items} {
1991 menu $m
1992 if {[tk windowingsystem] eq {aqua}} {
1993 set Meta1 Cmd
1994 } else {
1995 set Meta1 Ctrl
1996 }
1997 foreach i $items {
1998 set name [mc [lindex $i 1]]
1999 set type [lindex $i 2]
2000 set thing [lindex $i 3]
2001 set params [list $type]
2002 if {$name ne {}} {
2003 set u [string first "&" [string map {&& x} $name]]
2004 lappend params -label [string map {&& & & {}} $name]
2005 if {$u >= 0} {
2006 lappend params -underline $u
2007 }
2008 }
2009 switch -- $type {
2010 "cascade" {
2011 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2012 lappend params -menu $m.$submenu
2013 }
2014 "command" {
2015 lappend params -command $thing
2016 }
2017 "radiobutton" {
2018 lappend params -variable [lindex $thing 0] \
2019 -value [lindex $thing 1]
2020 }
2021 }
2022 set tail [lrange $i 4 end]
2023 regsub -all {\yMeta1\y} $tail $Meta1 tail
2024 eval $m add $params $tail
2025 if {$type eq "cascade"} {
2026 makemenu $m.$submenu $thing
2027 }
2028 }
2029}
2030
2031# translate string and remove ampersands
2032proc mca {str} {
2033 return [string map {&& & & {}} [mc $str]]
2034}
2035
2036proc cleardropsel {w} {
2037 $w selection clear
2038}
2039proc makedroplist {w varname args} {
2040 global use_ttk
2041 if {$use_ttk} {
2042 set width 0
2043 foreach label $args {
2044 set cx [string length $label]
2045 if {$cx > $width} {set width $cx}
2046 }
2047 set gm [ttk::combobox $w -width $width -state readonly\
2048 -textvariable $varname -values $args \
2049 -exportselection false]
2050 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2051 } else {
2052 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2053 }
2054 return $gm
2055}
2056
2057proc makewindow {} {
2058 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2059 global tabstop
2060 global findtype findtypemenu findloc findstring fstring geometry
2061 global entries sha1entry sha1string sha1but
2062 global diffcontextstring diffcontext
2063 global ignorespace
2064 global maincursor textcursor curtextcursor
2065 global rowctxmenu fakerowmenu mergemax wrapcomment
2066 global highlight_files gdttype
2067 global searchstring sstring
2068 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2069 global uifgcolor uifgdisabledcolor
2070 global filesepbgcolor filesepfgcolor
2071 global mergecolors foundbgcolor currentsearchhitbgcolor
2072 global headctxmenu progresscanv progressitem progresscoords statusw
2073 global fprogitem fprogcoord lastprogupdate progupdatepending
2074 global rprogitem rprogcoord rownumsel numcommits
2075 global have_tk85 use_ttk NS
2076 global git_version
2077 global worddiff
2078
2079 # The "mc" arguments here are purely so that xgettext
2080 # sees the following string as needing to be translated
2081 set file {
2082 mc "&File" cascade {
2083 {mc "&Update" command updatecommits -accelerator F5}
2084 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2085 {mc "Reread re&ferences" command rereadrefs}
2086 {mc "&List references" command showrefs -accelerator F2}
2087 {xx "" separator}
2088 {mc "Start git &gui" command {exec git gui &}}
2089 {xx "" separator}
2090 {mc "&Quit" command doquit -accelerator Meta1-Q}
2091 }}
2092 set edit {
2093 mc "&Edit" cascade {
2094 {mc "&Preferences" command doprefs}
2095 }}
2096 set view {
2097 mc "&View" cascade {
2098 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2099 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2100 {mc "&Delete view" command delview -state disabled}
2101 {xx "" separator}
2102 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2103 }}
2104 if {[tk windowingsystem] ne "aqua"} {
2105 set help {
2106 mc "&Help" cascade {
2107 {mc "&About gitk" command about}
2108 {mc "&Key bindings" command keys}
2109 }}
2110 set bar [list $file $edit $view $help]
2111 } else {
2112 proc ::tk::mac::ShowPreferences {} {doprefs}
2113 proc ::tk::mac::Quit {} {doquit}
2114 lset file end [lreplace [lindex $file end] end-1 end]
2115 set apple {
2116 xx "&Apple" cascade {
2117 {mc "&About gitk" command about}
2118 {xx "" separator}
2119 }}
2120 set help {
2121 mc "&Help" cascade {
2122 {mc "&Key bindings" command keys}
2123 }}
2124 set bar [list $apple $file $view $help]
2125 }
2126 makemenu .bar $bar
2127 . configure -menu .bar
2128
2129 if {$use_ttk} {
2130 # cover the non-themed toplevel with a themed frame.
2131 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2132 }
2133
2134 # the gui has upper and lower half, parts of a paned window.
2135 ${NS}::panedwindow .ctop -orient vertical
2136
2137 # possibly use assumed geometry
2138 if {![info exists geometry(pwsash0)]} {
2139 set geometry(topheight) [expr {15 * $linespc}]
2140 set geometry(topwidth) [expr {80 * $charspc}]
2141 set geometry(botheight) [expr {15 * $linespc}]
2142 set geometry(botwidth) [expr {50 * $charspc}]
2143 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2144 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2145 }
2146
2147 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2148 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2149 ${NS}::frame .tf.histframe
2150 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2151 if {!$use_ttk} {
2152 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2153 }
2154
2155 # create three canvases
2156 set cscroll .tf.histframe.csb
2157 set canv .tf.histframe.pwclist.canv
2158 canvas $canv \
2159 -selectbackground $selectbgcolor \
2160 -background $bgcolor -bd 0 \
2161 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2162 .tf.histframe.pwclist add $canv
2163 set canv2 .tf.histframe.pwclist.canv2
2164 canvas $canv2 \
2165 -selectbackground $selectbgcolor \
2166 -background $bgcolor -bd 0 -yscrollincr $linespc
2167 .tf.histframe.pwclist add $canv2
2168 set canv3 .tf.histframe.pwclist.canv3
2169 canvas $canv3 \
2170 -selectbackground $selectbgcolor \
2171 -background $bgcolor -bd 0 -yscrollincr $linespc
2172 .tf.histframe.pwclist add $canv3
2173 if {$use_ttk} {
2174 bind .tf.histframe.pwclist <Map> {
2175 bind %W <Map> {}
2176 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2177 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2178 }
2179 } else {
2180 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2181 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2182 }
2183
2184 # a scroll bar to rule them
2185 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2186 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2187 pack $cscroll -side right -fill y
2188 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2189 lappend bglist $canv $canv2 $canv3
2190 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2191
2192 # we have two button bars at bottom of top frame. Bar 1
2193 ${NS}::frame .tf.bar
2194 ${NS}::frame .tf.lbar -height 15
2195
2196 set sha1entry .tf.bar.sha1
2197 set entries $sha1entry
2198 set sha1but .tf.bar.sha1label
2199 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2200 -command gotocommit -width 8
2201 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2202 pack .tf.bar.sha1label -side left
2203 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2204 trace add variable sha1string write sha1change
2205 pack $sha1entry -side left -pady 2
2206
2207 set bm_left_data {
2208 #define left_width 16
2209 #define left_height 16
2210 static unsigned char left_bits[] = {
2211 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2212 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2213 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2214 }
2215 set bm_right_data {
2216 #define right_width 16
2217 #define right_height 16
2218 static unsigned char right_bits[] = {
2219 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2220 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2221 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2222 }
2223 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2224 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2225 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2226 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2227
2228 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2229 if {$use_ttk} {
2230 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2231 } else {
2232 .tf.bar.leftbut configure -image bm-left
2233 }
2234 pack .tf.bar.leftbut -side left -fill y
2235 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2236 if {$use_ttk} {
2237 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2238 } else {
2239 .tf.bar.rightbut configure -image bm-right
2240 }
2241 pack .tf.bar.rightbut -side left -fill y
2242
2243 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2244 set rownumsel {}
2245 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2246 -relief sunken -anchor e
2247 ${NS}::label .tf.bar.rowlabel2 -text "/"
2248 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2249 -relief sunken -anchor e
2250 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2251 -side left
2252 if {!$use_ttk} {
2253 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2254 }
2255 global selectedline
2256 trace add variable selectedline write selectedline_change
2257
2258 # Status label and progress bar
2259 set statusw .tf.bar.status
2260 ${NS}::label $statusw -width 15 -relief sunken
2261 pack $statusw -side left -padx 5
2262 if {$use_ttk} {
2263 set progresscanv [ttk::progressbar .tf.bar.progress]
2264 } else {
2265 set h [expr {[font metrics uifont -linespace] + 2}]
2266 set progresscanv .tf.bar.progress
2267 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2268 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2269 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2270 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2271 }
2272 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2273 set progresscoords {0 0}
2274 set fprogcoord 0
2275 set rprogcoord 0
2276 bind $progresscanv <Configure> adjustprogress
2277 set lastprogupdate [clock clicks -milliseconds]
2278 set progupdatepending 0
2279
2280 # build up the bottom bar of upper window
2281 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2282
2283 set bm_down_data {
2284 #define down_width 16
2285 #define down_height 16
2286 static unsigned char down_bits[] = {
2287 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2290 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2291 }
2292 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2293 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2294 .tf.lbar.fnext configure -image bm-down
2295
2296 set bm_up_data {
2297 #define up_width 16
2298 #define up_height 16
2299 static unsigned char up_bits[] = {
2300 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2301 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2302 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2303 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2304 }
2305 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2306 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2307 .tf.lbar.fprev configure -image bm-up
2308
2309 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2310
2311 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2312 -side left -fill y
2313 set gdttype [mc "containing:"]
2314 set gm [makedroplist .tf.lbar.gdttype gdttype \
2315 [mc "containing:"] \
2316 [mc "touching paths:"] \
2317 [mc "adding/removing string:"] \
2318 [mc "changing lines matching:"]]
2319 trace add variable gdttype write gdttype_change
2320 pack .tf.lbar.gdttype -side left -fill y
2321
2322 set findstring {}
2323 set fstring .tf.lbar.findstring
2324 lappend entries $fstring
2325 ${NS}::entry $fstring -width 30 -textvariable findstring
2326 trace add variable findstring write find_change
2327 set findtype [mc "Exact"]
2328 set findtypemenu [makedroplist .tf.lbar.findtype \
2329 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2330 trace add variable findtype write findcom_change
2331 set findloc [mc "All fields"]
2332 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2333 [mc "Comments"] [mc "Author"] [mc "Committer"]
2334 trace add variable findloc write find_change
2335 pack .tf.lbar.findloc -side right
2336 pack .tf.lbar.findtype -side right
2337 pack $fstring -side left -expand 1 -fill x
2338
2339 # Finish putting the upper half of the viewer together
2340 pack .tf.lbar -in .tf -side bottom -fill x
2341 pack .tf.bar -in .tf -side bottom -fill x
2342 pack .tf.histframe -fill both -side top -expand 1
2343 .ctop add .tf
2344 if {!$use_ttk} {
2345 .ctop paneconfigure .tf -height $geometry(topheight)
2346 .ctop paneconfigure .tf -width $geometry(topwidth)
2347 }
2348
2349 # now build up the bottom
2350 ${NS}::panedwindow .pwbottom -orient horizontal
2351
2352 # lower left, a text box over search bar, scroll bar to the right
2353 # if we know window height, then that will set the lower text height, otherwise
2354 # we set lower text height which will drive window height
2355 if {[info exists geometry(main)]} {
2356 ${NS}::frame .bleft -width $geometry(botwidth)
2357 } else {
2358 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2359 }
2360 ${NS}::frame .bleft.top
2361 ${NS}::frame .bleft.mid
2362 ${NS}::frame .bleft.bottom
2363
2364 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2365 pack .bleft.top.search -side left -padx 5
2366 set sstring .bleft.top.sstring
2367 set searchstring ""
2368 ${NS}::entry $sstring -width 20 -textvariable searchstring
2369 lappend entries $sstring
2370 trace add variable searchstring write incrsearch
2371 pack $sstring -side left -expand 1 -fill x
2372 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2373 -command changediffdisp -variable diffelide -value {0 0}
2374 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2375 -command changediffdisp -variable diffelide -value {0 1}
2376 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2377 -command changediffdisp -variable diffelide -value {1 0}
2378 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2379 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2380 spinbox .bleft.mid.diffcontext -width 5 \
2381 -from 0 -increment 1 -to 10000000 \
2382 -validate all -validatecommand "diffcontextvalidate %P" \
2383 -textvariable diffcontextstring
2384 .bleft.mid.diffcontext set $diffcontext
2385 trace add variable diffcontextstring write diffcontextchange
2386 lappend entries .bleft.mid.diffcontext
2387 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2388 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2389 -command changeignorespace -variable ignorespace
2390 pack .bleft.mid.ignspace -side left -padx 5
2391
2392 set worddiff [mc "Line diff"]
2393 if {[package vcompare $git_version "1.7.2"] >= 0} {
2394 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2395 [mc "Markup words"] [mc "Color words"]
2396 trace add variable worddiff write changeworddiff
2397 pack .bleft.mid.worddiff -side left -padx 5
2398 }
2399
2400 set ctext .bleft.bottom.ctext
2401 text $ctext -background $bgcolor -foreground $fgcolor \
2402 -state disabled -font textfont \
2403 -yscrollcommand scrolltext -wrap none \
2404 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2405 if {$have_tk85} {
2406 $ctext conf -tabstyle wordprocessor
2407 }
2408 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2409 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2410 pack .bleft.top -side top -fill x
2411 pack .bleft.mid -side top -fill x
2412 grid $ctext .bleft.bottom.sb -sticky nsew
2413 grid .bleft.bottom.sbhorizontal -sticky ew
2414 grid columnconfigure .bleft.bottom 0 -weight 1
2415 grid rowconfigure .bleft.bottom 0 -weight 1
2416 grid rowconfigure .bleft.bottom 1 -weight 0
2417 pack .bleft.bottom -side top -fill both -expand 1
2418 lappend bglist $ctext
2419 lappend fglist $ctext
2420
2421 $ctext tag conf comment -wrap $wrapcomment
2422 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2423 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2424 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2425 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2426 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2427 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2428 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2429 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2430 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2431 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2432 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2433 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2434 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2435 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2436 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2437 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2438 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2439 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2440 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2441 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2442 $ctext tag conf mmax -fore darkgrey
2443 set mergemax 16
2444 $ctext tag conf mresult -font textfontbold
2445 $ctext tag conf msep -font textfontbold
2446 $ctext tag conf found -back $foundbgcolor
2447 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2448 $ctext tag conf wwrap -wrap word -lmargin2 1c
2449 $ctext tag conf bold -font textfontbold
2450
2451 .pwbottom add .bleft
2452 if {!$use_ttk} {
2453 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2454 }
2455
2456 # lower right
2457 ${NS}::frame .bright
2458 ${NS}::frame .bright.mode
2459 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2460 -command reselectline -variable cmitmode -value "patch"
2461 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2462 -command reselectline -variable cmitmode -value "tree"
2463 grid .bright.mode.patch .bright.mode.tree -sticky ew
2464 pack .bright.mode -side top -fill x
2465 set cflist .bright.cfiles
2466 set indent [font measure mainfont "nn"]
2467 text $cflist \
2468 -selectbackground $selectbgcolor \
2469 -background $bgcolor -foreground $fgcolor \
2470 -font mainfont \
2471 -tabs [list $indent [expr {2 * $indent}]] \
2472 -yscrollcommand ".bright.sb set" \
2473 -cursor [. cget -cursor] \
2474 -spacing1 1 -spacing3 1
2475 lappend bglist $cflist
2476 lappend fglist $cflist
2477 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2478 pack .bright.sb -side right -fill y
2479 pack $cflist -side left -fill both -expand 1
2480 $cflist tag configure highlight \
2481 -background [$cflist cget -selectbackground]
2482 $cflist tag configure bold -font mainfontbold
2483
2484 .pwbottom add .bright
2485 .ctop add .pwbottom
2486
2487 # restore window width & height if known
2488 if {[info exists geometry(main)]} {
2489 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2490 if {$w > [winfo screenwidth .]} {
2491 set w [winfo screenwidth .]
2492 }
2493 if {$h > [winfo screenheight .]} {
2494 set h [winfo screenheight .]
2495 }
2496 wm geometry . "${w}x$h"
2497 }
2498 }
2499
2500 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2501 wm state . $geometry(state)
2502 }
2503
2504 if {[tk windowingsystem] eq {aqua}} {
2505 set M1B M1
2506 set ::BM "3"
2507 } else {
2508 set M1B Control
2509 set ::BM "2"
2510 }
2511
2512 if {$use_ttk} {
2513 bind .ctop <Map> {
2514 bind %W <Map> {}
2515 %W sashpos 0 $::geometry(topheight)
2516 }
2517 bind .pwbottom <Map> {
2518 bind %W <Map> {}
2519 %W sashpos 0 $::geometry(botwidth)
2520 }
2521 }
2522
2523 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2524 pack .ctop -fill both -expand 1
2525 bindall <1> {selcanvline %W %x %y}
2526 #bindall <B1-Motion> {selcanvline %W %x %y}
2527 if {[tk windowingsystem] == "win32"} {
2528 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2529 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2530 } else {
2531 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2532 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2533 bind $ctext <Button> {
2534 if {"%b" eq 6} {
2535 $ctext xview scroll -5 units
2536 } elseif {"%b" eq 7} {
2537 $ctext xview scroll 5 units
2538 }
2539 }
2540 if {[tk windowingsystem] eq "aqua"} {
2541 bindall <MouseWheel> {
2542 set delta [expr {- (%D)}]
2543 allcanvs yview scroll $delta units
2544 }
2545 bindall <Shift-MouseWheel> {
2546 set delta [expr {- (%D)}]
2547 $canv xview scroll $delta units
2548 }
2549 }
2550 }
2551 bindall <$::BM> "canvscan mark %W %x %y"
2552 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2553 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2554 bind . <$M1B-Key-w> doquit
2555 bindkey <Home> selfirstline
2556 bindkey <End> sellastline
2557 bind . <Key-Up> "selnextline -1"
2558 bind . <Key-Down> "selnextline 1"
2559 bind . <Shift-Key-Up> "dofind -1 0"
2560 bind . <Shift-Key-Down> "dofind 1 0"
2561 bindkey <Key-Right> "goforw"
2562 bindkey <Key-Left> "goback"
2563 bind . <Key-Prior> "selnextpage -1"
2564 bind . <Key-Next> "selnextpage 1"
2565 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2566 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2567 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2568 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2569 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2570 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2571 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2572 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2573 bindkey <Key-space> "$ctext yview scroll 1 pages"
2574 bindkey p "selnextline -1"
2575 bindkey n "selnextline 1"
2576 bindkey z "goback"
2577 bindkey x "goforw"
2578 bindkey k "selnextline -1"
2579 bindkey j "selnextline 1"
2580 bindkey h "goback"
2581 bindkey l "goforw"
2582 bindkey b prevfile
2583 bindkey d "$ctext yview scroll 18 units"
2584 bindkey u "$ctext yview scroll -18 units"
2585 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2586 bindkey / {focus $fstring}
2587 bindkey <Key-KP_Divide> {focus $fstring}
2588 bindkey <Key-Return> {dofind 1 1}
2589 bindkey ? {dofind -1 1}
2590 bindkey f nextfile
2591 bind . <F5> updatecommits
2592 bindmodfunctionkey Shift 5 reloadcommits
2593 bind . <F2> showrefs
2594 bindmodfunctionkey Shift 4 {newview 0}
2595 bind . <F4> edit_or_newview
2596 bind . <$M1B-q> doquit
2597 bind . <$M1B-f> {dofind 1 1}
2598 bind . <$M1B-g> {dofind 1 0}
2599 bind . <$M1B-r> dosearchback
2600 bind . <$M1B-s> dosearch
2601 bind . <$M1B-equal> {incrfont 1}
2602 bind . <$M1B-plus> {incrfont 1}
2603 bind . <$M1B-KP_Add> {incrfont 1}
2604 bind . <$M1B-minus> {incrfont -1}
2605 bind . <$M1B-KP_Subtract> {incrfont -1}
2606 wm protocol . WM_DELETE_WINDOW doquit
2607 bind . <Destroy> {stop_backends}
2608 bind . <Button-1> "click %W"
2609 bind $fstring <Key-Return> {dofind 1 1}
2610 bind $sha1entry <Key-Return> {gotocommit; break}
2611 bind $sha1entry <<PasteSelection>> clearsha1
2612 bind $sha1entry <<Paste>> clearsha1
2613 bind $cflist <1> {sel_flist %W %x %y; break}
2614 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2615 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2616 global ctxbut
2617 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2618 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2619 bind $ctext <Button-1> {focus %W}
2620 bind $ctext <<Selection>> rehighlight_search_results
2621 for {set i 1} {$i < 10} {incr i} {
2622 bind . <$M1B-Key-$i> [list go_to_parent $i]
2623 }
2624
2625 set maincursor [. cget -cursor]
2626 set textcursor [$ctext cget -cursor]
2627 set curtextcursor $textcursor
2628
2629 set rowctxmenu .rowctxmenu
2630 makemenu $rowctxmenu {
2631 {mc "Diff this -> selected" command {diffvssel 0}}
2632 {mc "Diff selected -> this" command {diffvssel 1}}
2633 {mc "Make patch" command mkpatch}
2634 {mc "Create tag" command mktag}
2635 {mc "Copy commit summary" command copysummary}
2636 {mc "Write commit to file" command writecommit}
2637 {mc "Create new branch" command mkbranch}
2638 {mc "Cherry-pick this commit" command cherrypick}
2639 {mc "Reset HEAD branch to here" command resethead}
2640 {mc "Mark this commit" command markhere}
2641 {mc "Return to mark" command gotomark}
2642 {mc "Find descendant of this and mark" command find_common_desc}
2643 {mc "Compare with marked commit" command compare_commits}
2644 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2645 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2646 {mc "Revert this commit" command revert}
2647 }
2648 $rowctxmenu configure -tearoff 0
2649
2650 set fakerowmenu .fakerowmenu
2651 makemenu $fakerowmenu {
2652 {mc "Diff this -> selected" command {diffvssel 0}}
2653 {mc "Diff selected -> this" command {diffvssel 1}}
2654 {mc "Make patch" command mkpatch}
2655 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2656 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2657 }
2658 $fakerowmenu configure -tearoff 0
2659
2660 set headctxmenu .headctxmenu
2661 makemenu $headctxmenu {
2662 {mc "Check out this branch" command cobranch}
2663 {mc "Remove this branch" command rmbranch}
2664 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2665 }
2666 $headctxmenu configure -tearoff 0
2667
2668 global flist_menu
2669 set flist_menu .flistctxmenu
2670 makemenu $flist_menu {
2671 {mc "Highlight this too" command {flist_hl 0}}
2672 {mc "Highlight this only" command {flist_hl 1}}
2673 {mc "External diff" command {external_diff}}
2674 {mc "Blame parent commit" command {external_blame 1}}
2675 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2676 }
2677 $flist_menu configure -tearoff 0
2678
2679 global diff_menu
2680 set diff_menu .diffctxmenu
2681 makemenu $diff_menu {
2682 {mc "Show origin of this line" command show_line_source}
2683 {mc "Run git gui blame on this line" command {external_blame_diff}}
2684 }
2685 $diff_menu configure -tearoff 0
2686}
2687
2688# Windows sends all mouse wheel events to the current focused window, not
2689# the one where the mouse hovers, so bind those events here and redirect
2690# to the correct window
2691proc windows_mousewheel_redirector {W X Y D} {
2692 global canv canv2 canv3
2693 set w [winfo containing -displayof $W $X $Y]
2694 if {$w ne ""} {
2695 set u [expr {$D < 0 ? 5 : -5}]
2696 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2697 allcanvs yview scroll $u units
2698 } else {
2699 catch {
2700 $w yview scroll $u units
2701 }
2702 }
2703 }
2704}
2705
2706# Update row number label when selectedline changes
2707proc selectedline_change {n1 n2 op} {
2708 global selectedline rownumsel
2709
2710 if {$selectedline eq {}} {
2711 set rownumsel {}
2712 } else {
2713 set rownumsel [expr {$selectedline + 1}]
2714 }
2715}
2716
2717# mouse-2 makes all windows scan vertically, but only the one
2718# the cursor is in scans horizontally
2719proc canvscan {op w x y} {
2720 global canv canv2 canv3
2721 foreach c [list $canv $canv2 $canv3] {
2722 if {$c == $w} {
2723 $c scan $op $x $y
2724 } else {
2725 $c scan $op 0 $y
2726 }
2727 }
2728}
2729
2730proc scrollcanv {cscroll f0 f1} {
2731 $cscroll set $f0 $f1
2732 drawvisible
2733 flushhighlights
2734}
2735
2736# when we make a key binding for the toplevel, make sure
2737# it doesn't get triggered when that key is pressed in the
2738# find string entry widget.
2739proc bindkey {ev script} {
2740 global entries
2741 bind . $ev $script
2742 set escript [bind Entry $ev]
2743 if {$escript == {}} {
2744 set escript [bind Entry <Key>]
2745 }
2746 foreach e $entries {
2747 bind $e $ev "$escript; break"
2748 }
2749}
2750
2751proc bindmodfunctionkey {mod n script} {
2752 bind . <$mod-F$n> $script
2753 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2754}
2755
2756# set the focus back to the toplevel for any click outside
2757# the entry widgets
2758proc click {w} {
2759 global ctext entries
2760 foreach e [concat $entries $ctext] {
2761 if {$w == $e} return
2762 }
2763 focus .
2764}
2765
2766# Adjust the progress bar for a change in requested extent or canvas size
2767proc adjustprogress {} {
2768 global progresscanv progressitem progresscoords
2769 global fprogitem fprogcoord lastprogupdate progupdatepending
2770 global rprogitem rprogcoord use_ttk
2771
2772 if {$use_ttk} {
2773 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2774 return
2775 }
2776
2777 set w [expr {[winfo width $progresscanv] - 4}]
2778 set x0 [expr {$w * [lindex $progresscoords 0]}]
2779 set x1 [expr {$w * [lindex $progresscoords 1]}]
2780 set h [winfo height $progresscanv]
2781 $progresscanv coords $progressitem $x0 0 $x1 $h
2782 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2783 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2784 set now [clock clicks -milliseconds]
2785 if {$now >= $lastprogupdate + 100} {
2786 set progupdatepending 0
2787 update
2788 } elseif {!$progupdatepending} {
2789 set progupdatepending 1
2790 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2791 }
2792}
2793
2794proc doprogupdate {} {
2795 global lastprogupdate progupdatepending
2796
2797 if {$progupdatepending} {
2798 set progupdatepending 0
2799 set lastprogupdate [clock clicks -milliseconds]
2800 update
2801 }
2802}
2803
2804proc config_check_tmp_exists {tries_left} {
2805 global config_file_tmp
2806
2807 if {[file exists $config_file_tmp]} {
2808 incr tries_left -1
2809 if {$tries_left > 0} {
2810 after 100 [list config_check_tmp_exists $tries_left]
2811 } else {
2812 error_popup "There appears to be a stale $config_file_tmp\
2813 file, which will prevent gitk from saving its configuration on exit.\
2814 Please remove it if it is not being used by any existing gitk process."
2815 }
2816 }
2817}
2818
2819proc config_init_trace {name} {
2820 global config_variable_changed config_variable_original
2821
2822 upvar #0 $name var
2823 set config_variable_changed($name) 0
2824 set config_variable_original($name) $var
2825}
2826
2827proc config_variable_change_cb {name name2 op} {
2828 global config_variable_changed config_variable_original
2829
2830 upvar #0 $name var
2831 if {$op eq "write" &&
2832 (![info exists config_variable_original($name)] ||
2833 $config_variable_original($name) ne $var)} {
2834 set config_variable_changed($name) 1
2835 }
2836}
2837
2838proc savestuff {w} {
2839 global stuffsaved
2840 global config_file config_file_tmp
2841 global config_variables config_variable_changed
2842 global viewchanged
2843
2844 upvar #0 viewname current_viewname
2845 upvar #0 viewfiles current_viewfiles
2846 upvar #0 viewargs current_viewargs
2847 upvar #0 viewargscmd current_viewargscmd
2848 upvar #0 viewperm current_viewperm
2849 upvar #0 nextviewnum current_nextviewnum
2850 upvar #0 use_ttk current_use_ttk
2851
2852 if {$stuffsaved} return
2853 if {![winfo viewable .]} return
2854 set remove_tmp 0
2855 if {[catch {
2856 set try_count 0
2857 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2858 if {[incr try_count] > 50} {
2859 error "Unable to write config file: $config_file_tmp exists"
2860 }
2861 after 100
2862 }
2863 set remove_tmp 1
2864 if {$::tcl_platform(platform) eq {windows}} {
2865 file attributes $config_file_tmp -hidden true
2866 }
2867 if {[file exists $config_file]} {
2868 source $config_file
2869 }
2870 foreach var_name $config_variables {
2871 upvar #0 $var_name var
2872 upvar 0 $var_name old_var
2873 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2874 puts $f [list set $var_name $old_var]
2875 } else {
2876 puts $f [list set $var_name $var]
2877 }
2878 }
2879
2880 puts $f "set geometry(main) [wm geometry .]"
2881 puts $f "set geometry(state) [wm state .]"
2882 puts $f "set geometry(topwidth) [winfo width .tf]"
2883 puts $f "set geometry(topheight) [winfo height .tf]"
2884 if {$current_use_ttk} {
2885 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2886 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2887 } else {
2888 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2889 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2890 }
2891 puts $f "set geometry(botwidth) [winfo width .bleft]"
2892 puts $f "set geometry(botheight) [winfo height .bleft]"
2893
2894 array set view_save {}
2895 array set views {}
2896 if {![info exists permviews]} { set permviews {} }
2897 foreach view $permviews {
2898 set view_save([lindex $view 0]) 1
2899 set views([lindex $view 0]) $view
2900 }
2901 puts -nonewline $f "set permviews {"
2902 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2903 if {$viewchanged($v)} {
2904 if {$current_viewperm($v)} {
2905 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2906 } else {
2907 set view_save($current_viewname($v)) 0
2908 }
2909 }
2910 }
2911 # write old and updated view to their places and append remaining to the end
2912 foreach view $permviews {
2913 set view_name [lindex $view 0]
2914 if {$view_save($view_name)} {
2915 puts $f "{$views($view_name)}"
2916 }
2917 unset views($view_name)
2918 }
2919 foreach view_name [array names views] {
2920 puts $f "{$views($view_name)}"
2921 }
2922 puts $f "}"
2923 close $f
2924 file rename -force $config_file_tmp $config_file
2925 set remove_tmp 0
2926 } err]} {
2927 puts "Error saving config: $err"
2928 }
2929 if {$remove_tmp} {
2930 file delete -force $config_file_tmp
2931 }
2932 set stuffsaved 1
2933}
2934
2935proc resizeclistpanes {win w} {
2936 global oldwidth use_ttk
2937 if {[info exists oldwidth($win)]} {
2938 if {$use_ttk} {
2939 set s0 [$win sashpos 0]
2940 set s1 [$win sashpos 1]
2941 } else {
2942 set s0 [$win sash coord 0]
2943 set s1 [$win sash coord 1]
2944 }
2945 if {$w < 60} {
2946 set sash0 [expr {int($w/2 - 2)}]
2947 set sash1 [expr {int($w*5/6 - 2)}]
2948 } else {
2949 set factor [expr {1.0 * $w / $oldwidth($win)}]
2950 set sash0 [expr {int($factor * [lindex $s0 0])}]
2951 set sash1 [expr {int($factor * [lindex $s1 0])}]
2952 if {$sash0 < 30} {
2953 set sash0 30
2954 }
2955 if {$sash1 < $sash0 + 20} {
2956 set sash1 [expr {$sash0 + 20}]
2957 }
2958 if {$sash1 > $w - 10} {
2959 set sash1 [expr {$w - 10}]
2960 if {$sash0 > $sash1 - 20} {
2961 set sash0 [expr {$sash1 - 20}]
2962 }
2963 }
2964 }
2965 if {$use_ttk} {
2966 $win sashpos 0 $sash0
2967 $win sashpos 1 $sash1
2968 } else {
2969 $win sash place 0 $sash0 [lindex $s0 1]
2970 $win sash place 1 $sash1 [lindex $s1 1]
2971 }
2972 }
2973 set oldwidth($win) $w
2974}
2975
2976proc resizecdetpanes {win w} {
2977 global oldwidth use_ttk
2978 if {[info exists oldwidth($win)]} {
2979 if {$use_ttk} {
2980 set s0 [$win sashpos 0]
2981 } else {
2982 set s0 [$win sash coord 0]
2983 }
2984 if {$w < 60} {
2985 set sash0 [expr {int($w*3/4 - 2)}]
2986 } else {
2987 set factor [expr {1.0 * $w / $oldwidth($win)}]
2988 set sash0 [expr {int($factor * [lindex $s0 0])}]
2989 if {$sash0 < 45} {
2990 set sash0 45
2991 }
2992 if {$sash0 > $w - 15} {
2993 set sash0 [expr {$w - 15}]
2994 }
2995 }
2996 if {$use_ttk} {
2997 $win sashpos 0 $sash0
2998 } else {
2999 $win sash place 0 $sash0 [lindex $s0 1]
3000 }
3001 }
3002 set oldwidth($win) $w
3003}
3004
3005proc allcanvs args {
3006 global canv canv2 canv3
3007 eval $canv $args
3008 eval $canv2 $args
3009 eval $canv3 $args
3010}
3011
3012proc bindall {event action} {
3013 global canv canv2 canv3
3014 bind $canv $event $action
3015 bind $canv2 $event $action
3016 bind $canv3 $event $action
3017}
3018
3019proc about {} {
3020 global uifont NS
3021 set w .about
3022 if {[winfo exists $w]} {
3023 raise $w
3024 return
3025 }
3026 ttk_toplevel $w
3027 wm title $w [mc "About gitk"]
3028 make_transient $w .
3029 message $w.m -text [mc "
3030Gitk - a commit viewer for git
3031
3032Copyright \u00a9 2005-2014 Paul Mackerras
3033
3034Use and redistribute under the terms of the GNU General Public License"] \
3035 -justify center -aspect 400 -border 2 -bg white -relief groove
3036 pack $w.m -side top -fill x -padx 2 -pady 2
3037 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3038 pack $w.ok -side bottom
3039 bind $w <Visibility> "focus $w.ok"
3040 bind $w <Key-Escape> "destroy $w"
3041 bind $w <Key-Return> "destroy $w"
3042 tk::PlaceWindow $w widget .
3043}
3044
3045proc keys {} {
3046 global NS
3047 set w .keys
3048 if {[winfo exists $w]} {
3049 raise $w
3050 return
3051 }
3052 if {[tk windowingsystem] eq {aqua}} {
3053 set M1T Cmd
3054 } else {
3055 set M1T Ctrl
3056 }
3057 ttk_toplevel $w
3058 wm title $w [mc "Gitk key bindings"]
3059 make_transient $w .
3060 message $w.m -text "
3061[mc "Gitk key bindings:"]
3062
3063[mc "<%s-Q> Quit" $M1T]
3064[mc "<%s-W> Close window" $M1T]
3065[mc "<Home> Move to first commit"]
3066[mc "<End> Move to last commit"]
3067[mc "<Up>, p, k Move up one commit"]
3068[mc "<Down>, n, j Move down one commit"]
3069[mc "<Left>, z, h Go back in history list"]
3070[mc "<Right>, x, l Go forward in history list"]
3071[mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3072[mc "<PageUp> Move up one page in commit list"]
3073[mc "<PageDown> Move down one page in commit list"]
3074[mc "<%s-Home> Scroll to top of commit list" $M1T]
3075[mc "<%s-End> Scroll to bottom of commit list" $M1T]
3076[mc "<%s-Up> Scroll commit list up one line" $M1T]
3077[mc "<%s-Down> Scroll commit list down one line" $M1T]
3078[mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3079[mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3080[mc "<Shift-Up> Find backwards (upwards, later commits)"]
3081[mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3082[mc "<Delete>, b Scroll diff view up one page"]
3083[mc "<Backspace> Scroll diff view up one page"]
3084[mc "<Space> Scroll diff view down one page"]
3085[mc "u Scroll diff view up 18 lines"]
3086[mc "d Scroll diff view down 18 lines"]
3087[mc "<%s-F> Find" $M1T]
3088[mc "<%s-G> Move to next find hit" $M1T]
3089[mc "<Return> Move to next find hit"]
3090[mc "g Go to commit"]
3091[mc "/ Focus the search box"]
3092[mc "? Move to previous find hit"]
3093[mc "f Scroll diff view to next file"]
3094[mc "<%s-S> Search for next hit in diff view" $M1T]
3095[mc "<%s-R> Search for previous hit in diff view" $M1T]
3096[mc "<%s-KP+> Increase font size" $M1T]
3097[mc "<%s-plus> Increase font size" $M1T]
3098[mc "<%s-KP-> Decrease font size" $M1T]
3099[mc "<%s-minus> Decrease font size" $M1T]
3100[mc "<F5> Update"]
3101" \
3102 -justify left -bg white -border 2 -relief groove
3103 pack $w.m -side top -fill both -padx 2 -pady 2
3104 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3105 bind $w <Key-Escape> [list destroy $w]
3106 pack $w.ok -side bottom
3107 bind $w <Visibility> "focus $w.ok"
3108 bind $w <Key-Escape> "destroy $w"
3109 bind $w <Key-Return> "destroy $w"
3110}
3111
3112# Procedures for manipulating the file list window at the
3113# bottom right of the overall window.
3114
3115proc treeview {w l openlevs} {
3116 global treecontents treediropen treeheight treeparent treeindex
3117
3118 set ix 0
3119 set treeindex() 0
3120 set lev 0
3121 set prefix {}
3122 set prefixend -1
3123 set prefendstack {}
3124 set htstack {}
3125 set ht 0
3126 set treecontents() {}
3127 $w conf -state normal
3128 foreach f $l {
3129 while {[string range $f 0 $prefixend] ne $prefix} {
3130 if {$lev <= $openlevs} {
3131 $w mark set e:$treeindex($prefix) "end -1c"
3132 $w mark gravity e:$treeindex($prefix) left
3133 }
3134 set treeheight($prefix) $ht
3135 incr ht [lindex $htstack end]
3136 set htstack [lreplace $htstack end end]
3137 set prefixend [lindex $prefendstack end]
3138 set prefendstack [lreplace $prefendstack end end]
3139 set prefix [string range $prefix 0 $prefixend]
3140 incr lev -1
3141 }
3142 set tail [string range $f [expr {$prefixend+1}] end]
3143 while {[set slash [string first "/" $tail]] >= 0} {
3144 lappend htstack $ht
3145 set ht 0
3146 lappend prefendstack $prefixend
3147 incr prefixend [expr {$slash + 1}]
3148 set d [string range $tail 0 $slash]
3149 lappend treecontents($prefix) $d
3150 set oldprefix $prefix
3151 append prefix $d
3152 set treecontents($prefix) {}
3153 set treeindex($prefix) [incr ix]
3154 set treeparent($prefix) $oldprefix
3155 set tail [string range $tail [expr {$slash+1}] end]
3156 if {$lev <= $openlevs} {
3157 set ht 1
3158 set treediropen($prefix) [expr {$lev < $openlevs}]
3159 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3160 $w mark set d:$ix "end -1c"
3161 $w mark gravity d:$ix left
3162 set str "\n"
3163 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3164 $w insert end $str
3165 $w image create end -align center -image $bm -padx 1 \
3166 -name a:$ix
3167 $w insert end $d [highlight_tag $prefix]
3168 $w mark set s:$ix "end -1c"
3169 $w mark gravity s:$ix left
3170 }
3171 incr lev
3172 }
3173 if {$tail ne {}} {
3174 if {$lev <= $openlevs} {
3175 incr ht
3176 set str "\n"
3177 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3178 $w insert end $str
3179 $w insert end $tail [highlight_tag $f]
3180 }
3181 lappend treecontents($prefix) $tail
3182 }
3183 }
3184 while {$htstack ne {}} {
3185 set treeheight($prefix) $ht
3186 incr ht [lindex $htstack end]
3187 set htstack [lreplace $htstack end end]
3188 set prefixend [lindex $prefendstack end]
3189 set prefendstack [lreplace $prefendstack end end]
3190 set prefix [string range $prefix 0 $prefixend]
3191 }
3192 $w conf -state disabled
3193}
3194
3195proc linetoelt {l} {
3196 global treeheight treecontents
3197
3198 set y 2
3199 set prefix {}
3200 while {1} {
3201 foreach e $treecontents($prefix) {
3202 if {$y == $l} {
3203 return "$prefix$e"
3204 }
3205 set n 1
3206 if {[string index $e end] eq "/"} {
3207 set n $treeheight($prefix$e)
3208 if {$y + $n > $l} {
3209 append prefix $e
3210 incr y
3211 break
3212 }
3213 }
3214 incr y $n
3215 }
3216 }
3217}
3218
3219proc highlight_tree {y prefix} {
3220 global treeheight treecontents cflist
3221
3222 foreach e $treecontents($prefix) {
3223 set path $prefix$e
3224 if {[highlight_tag $path] ne {}} {
3225 $cflist tag add bold $y.0 "$y.0 lineend"
3226 }
3227 incr y
3228 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3229 set y [highlight_tree $y $path]
3230 }
3231 }
3232 return $y
3233}
3234
3235proc treeclosedir {w dir} {
3236 global treediropen treeheight treeparent treeindex
3237
3238 set ix $treeindex($dir)
3239 $w conf -state normal
3240 $w delete s:$ix e:$ix
3241 set treediropen($dir) 0
3242 $w image configure a:$ix -image tri-rt
3243 $w conf -state disabled
3244 set n [expr {1 - $treeheight($dir)}]
3245 while {$dir ne {}} {
3246 incr treeheight($dir) $n
3247 set dir $treeparent($dir)
3248 }
3249}
3250
3251proc treeopendir {w dir} {
3252 global treediropen treeheight treeparent treecontents treeindex
3253
3254 set ix $treeindex($dir)
3255 $w conf -state normal
3256 $w image configure a:$ix -image tri-dn
3257 $w mark set e:$ix s:$ix
3258 $w mark gravity e:$ix right
3259 set lev 0
3260 set str "\n"
3261 set n [llength $treecontents($dir)]
3262 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3263 incr lev
3264 append str "\t"
3265 incr treeheight($x) $n
3266 }
3267 foreach e $treecontents($dir) {
3268 set de $dir$e
3269 if {[string index $e end] eq "/"} {
3270 set iy $treeindex($de)
3271 $w mark set d:$iy e:$ix
3272 $w mark gravity d:$iy left
3273 $w insert e:$ix $str
3274 set treediropen($de) 0
3275 $w image create e:$ix -align center -image tri-rt -padx 1 \
3276 -name a:$iy
3277 $w insert e:$ix $e [highlight_tag $de]
3278 $w mark set s:$iy e:$ix
3279 $w mark gravity s:$iy left
3280 set treeheight($de) 1
3281 } else {
3282 $w insert e:$ix $str
3283 $w insert e:$ix $e [highlight_tag $de]
3284 }
3285 }
3286 $w mark gravity e:$ix right
3287 $w conf -state disabled
3288 set treediropen($dir) 1
3289 set top [lindex [split [$w index @0,0] .] 0]
3290 set ht [$w cget -height]
3291 set l [lindex [split [$w index s:$ix] .] 0]
3292 if {$l < $top} {
3293 $w yview $l.0
3294 } elseif {$l + $n + 1 > $top + $ht} {
3295 set top [expr {$l + $n + 2 - $ht}]
3296 if {$l < $top} {
3297 set top $l
3298 }
3299 $w yview $top.0
3300 }
3301}
3302
3303proc treeclick {w x y} {
3304 global treediropen cmitmode ctext cflist cflist_top
3305
3306 if {$cmitmode ne "tree"} return
3307 if {![info exists cflist_top]} return
3308 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3309 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3310 $cflist tag add highlight $l.0 "$l.0 lineend"
3311 set cflist_top $l
3312 if {$l == 1} {
3313 $ctext yview 1.0
3314 return
3315 }
3316 set e [linetoelt $l]
3317 if {[string index $e end] ne "/"} {
3318 showfile $e
3319 } elseif {$treediropen($e)} {
3320 treeclosedir $w $e
3321 } else {
3322 treeopendir $w $e
3323 }
3324}
3325
3326proc setfilelist {id} {
3327 global treefilelist cflist jump_to_here
3328
3329 treeview $cflist $treefilelist($id) 0
3330 if {$jump_to_here ne {}} {
3331 set f [lindex $jump_to_here 0]
3332 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3333 showfile $f
3334 }
3335 }
3336}
3337
3338image create bitmap tri-rt -background black -foreground blue -data {
3339 #define tri-rt_width 13
3340 #define tri-rt_height 13
3341 static unsigned char tri-rt_bits[] = {
3342 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3343 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3344 0x00, 0x00};
3345} -maskdata {
3346 #define tri-rt-mask_width 13
3347 #define tri-rt-mask_height 13
3348 static unsigned char tri-rt-mask_bits[] = {
3349 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3350 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3351 0x08, 0x00};
3352}
3353image create bitmap tri-dn -background black -foreground blue -data {
3354 #define tri-dn_width 13
3355 #define tri-dn_height 13
3356 static unsigned char tri-dn_bits[] = {
3357 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3358 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3359 0x00, 0x00};
3360} -maskdata {
3361 #define tri-dn-mask_width 13
3362 #define tri-dn-mask_height 13
3363 static unsigned char tri-dn-mask_bits[] = {
3364 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3365 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3366 0x00, 0x00};
3367}
3368
3369image create bitmap reficon-T -background black -foreground yellow -data {
3370 #define tagicon_width 13
3371 #define tagicon_height 9
3372 static unsigned char tagicon_bits[] = {
3373 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3374 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3375} -maskdata {
3376 #define tagicon-mask_width 13
3377 #define tagicon-mask_height 9
3378 static unsigned char tagicon-mask_bits[] = {
3379 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3380 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3381}
3382set rectdata {
3383 #define headicon_width 13
3384 #define headicon_height 9
3385 static unsigned char headicon_bits[] = {
3386 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3387 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3388}
3389set rectmask {
3390 #define headicon-mask_width 13
3391 #define headicon-mask_height 9
3392 static unsigned char headicon-mask_bits[] = {
3393 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3394 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3395}
3396image create bitmap reficon-H -background black -foreground green \
3397 -data $rectdata -maskdata $rectmask
3398image create bitmap reficon-o -background black -foreground "#ddddff" \
3399 -data $rectdata -maskdata $rectmask
3400
3401proc init_flist {first} {
3402 global cflist cflist_top difffilestart
3403
3404 $cflist conf -state normal
3405 $cflist delete 0.0 end
3406 if {$first ne {}} {
3407 $cflist insert end $first
3408 set cflist_top 1
3409 $cflist tag add highlight 1.0 "1.0 lineend"
3410 } else {
3411 unset -nocomplain cflist_top
3412 }
3413 $cflist conf -state disabled
3414 set difffilestart {}
3415}
3416
3417proc highlight_tag {f} {
3418 global highlight_paths
3419
3420 foreach p $highlight_paths {
3421 if {[string match $p $f]} {
3422 return "bold"
3423 }
3424 }
3425 return {}
3426}
3427
3428proc highlight_filelist {} {
3429 global cmitmode cflist
3430
3431 $cflist conf -state normal
3432 if {$cmitmode ne "tree"} {
3433 set end [lindex [split [$cflist index end] .] 0]
3434 for {set l 2} {$l < $end} {incr l} {
3435 set line [$cflist get $l.0 "$l.0 lineend"]
3436 if {[highlight_tag $line] ne {}} {
3437 $cflist tag add bold $l.0 "$l.0 lineend"
3438 }
3439 }
3440 } else {
3441 highlight_tree 2 {}
3442 }
3443 $cflist conf -state disabled
3444}
3445
3446proc unhighlight_filelist {} {
3447 global cflist
3448
3449 $cflist conf -state normal
3450 $cflist tag remove bold 1.0 end
3451 $cflist conf -state disabled
3452}
3453
3454proc add_flist {fl} {
3455 global cflist
3456
3457 $cflist conf -state normal
3458 foreach f $fl {
3459 $cflist insert end "\n"
3460 $cflist insert end $f [highlight_tag $f]
3461 }
3462 $cflist conf -state disabled
3463}
3464
3465proc sel_flist {w x y} {
3466 global ctext difffilestart cflist cflist_top cmitmode
3467
3468 if {$cmitmode eq "tree"} return
3469 if {![info exists cflist_top]} return
3470 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3471 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3472 $cflist tag add highlight $l.0 "$l.0 lineend"
3473 set cflist_top $l
3474 if {$l == 1} {
3475 $ctext yview 1.0
3476 } else {
3477 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3478 }
3479 suppress_highlighting_file_for_current_scrollpos
3480}
3481
3482proc pop_flist_menu {w X Y x y} {
3483 global ctext cflist cmitmode flist_menu flist_menu_file
3484 global treediffs diffids
3485
3486 stopfinding
3487 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3488 if {$l <= 1} return
3489 if {$cmitmode eq "tree"} {
3490 set e [linetoelt $l]
3491 if {[string index $e end] eq "/"} return
3492 } else {
3493 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3494 }
3495 set flist_menu_file $e
3496 set xdiffstate "normal"
3497 if {$cmitmode eq "tree"} {
3498 set xdiffstate "disabled"
3499 }
3500 # Disable "External diff" item in tree mode
3501 $flist_menu entryconf 2 -state $xdiffstate
3502 tk_popup $flist_menu $X $Y
3503}
3504
3505proc find_ctext_fileinfo {line} {
3506 global ctext_file_names ctext_file_lines
3507
3508 set ok [bsearch $ctext_file_lines $line]
3509 set tline [lindex $ctext_file_lines $ok]
3510
3511 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3512 return {}
3513 } else {
3514 return [list [lindex $ctext_file_names $ok] $tline]
3515 }
3516}
3517
3518proc pop_diff_menu {w X Y x y} {
3519 global ctext diff_menu flist_menu_file
3520 global diff_menu_txtpos diff_menu_line
3521 global diff_menu_filebase
3522
3523 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3524 set diff_menu_line [lindex $diff_menu_txtpos 0]
3525 # don't pop up the menu on hunk-separator or file-separator lines
3526 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3527 return
3528 }
3529 stopfinding
3530 set f [find_ctext_fileinfo $diff_menu_line]
3531 if {$f eq {}} return
3532 set flist_menu_file [lindex $f 0]
3533 set diff_menu_filebase [lindex $f 1]
3534 tk_popup $diff_menu $X $Y
3535}
3536
3537proc flist_hl {only} {
3538 global flist_menu_file findstring gdttype
3539
3540 set x [shellquote $flist_menu_file]
3541 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3542 set findstring $x
3543 } else {
3544 append findstring " " $x
3545 }
3546 set gdttype [mc "touching paths:"]
3547}
3548
3549proc gitknewtmpdir {} {
3550 global diffnum gitktmpdir gitdir env
3551
3552 if {![info exists gitktmpdir]} {
3553 if {[info exists env(GITK_TMPDIR)]} {
3554 set tmpdir $env(GITK_TMPDIR)
3555 } elseif {[info exists env(TMPDIR)]} {
3556 set tmpdir $env(TMPDIR)
3557 } else {
3558 set tmpdir $gitdir
3559 }
3560 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3561 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3562 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3563 }
3564 if {[catch {file mkdir $gitktmpdir} err]} {
3565 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3566 unset gitktmpdir
3567 return {}
3568 }
3569 set diffnum 0
3570 }
3571 incr diffnum
3572 set diffdir [file join $gitktmpdir $diffnum]
3573 if {[catch {file mkdir $diffdir} err]} {
3574 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3575 return {}
3576 }
3577 return $diffdir
3578}
3579
3580proc save_file_from_commit {filename output what} {
3581 global nullfile
3582
3583 if {[catch {exec git show $filename -- > $output} err]} {
3584 if {[string match "fatal: bad revision *" $err]} {
3585 return $nullfile
3586 }
3587 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3588 return {}
3589 }
3590 return $output
3591}
3592
3593proc external_diff_get_one_file {diffid filename diffdir} {
3594 global nullid nullid2 nullfile
3595 global worktree
3596
3597 if {$diffid == $nullid} {
3598 set difffile [file join $worktree $filename]
3599 if {[file exists $difffile]} {
3600 return $difffile
3601 }
3602 return $nullfile
3603 }
3604 if {$diffid == $nullid2} {
3605 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3606 return [save_file_from_commit :$filename $difffile index]
3607 }
3608 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3609 return [save_file_from_commit $diffid:$filename $difffile \
3610 "revision $diffid"]
3611}
3612
3613proc external_diff {} {
3614 global nullid nullid2
3615 global flist_menu_file
3616 global diffids
3617 global extdifftool
3618
3619 if {[llength $diffids] == 1} {
3620 # no reference commit given
3621 set diffidto [lindex $diffids 0]
3622 if {$diffidto eq $nullid} {
3623 # diffing working copy with index
3624 set diffidfrom $nullid2
3625 } elseif {$diffidto eq $nullid2} {
3626 # diffing index with HEAD
3627 set diffidfrom "HEAD"
3628 } else {
3629 # use first parent commit
3630 global parentlist selectedline
3631 set diffidfrom [lindex $parentlist $selectedline 0]
3632 }
3633 } else {
3634 set diffidfrom [lindex $diffids 0]
3635 set diffidto [lindex $diffids 1]
3636 }
3637
3638 # make sure that several diffs wont collide
3639 set diffdir [gitknewtmpdir]
3640 if {$diffdir eq {}} return
3641
3642 # gather files to diff
3643 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3644 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3645
3646 if {$difffromfile ne {} && $difftofile ne {}} {
3647 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3648 if {[catch {set fl [open |$cmd r]} err]} {
3649 file delete -force $diffdir
3650 error_popup "$extdifftool: [mc "command failed:"] $err"
3651 } else {
3652 fconfigure $fl -blocking 0
3653 filerun $fl [list delete_at_eof $fl $diffdir]
3654 }
3655 }
3656}
3657
3658proc find_hunk_blamespec {base line} {
3659 global ctext
3660
3661 # Find and parse the hunk header
3662 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3663 if {$s_lix eq {}} return
3664
3665 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3666 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3667 s_line old_specs osz osz1 new_line nsz]} {
3668 return
3669 }
3670
3671 # base lines for the parents
3672 set base_lines [list $new_line]
3673 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3674 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3675 old_spec old_line osz]} {
3676 return
3677 }
3678 lappend base_lines $old_line
3679 }
3680
3681 # Now scan the lines to determine offset within the hunk
3682 set max_parent [expr {[llength $base_lines]-2}]
3683 set dline 0
3684 set s_lno [lindex [split $s_lix "."] 0]
3685
3686 # Determine if the line is removed
3687 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3688 if {[string match {[-+ ]*} $chunk]} {
3689 set removed_idx [string first "-" $chunk]
3690 # Choose a parent index
3691 if {$removed_idx >= 0} {
3692 set parent $removed_idx
3693 } else {
3694 set unchanged_idx [string first " " $chunk]
3695 if {$unchanged_idx >= 0} {
3696 set parent $unchanged_idx
3697 } else {
3698 # blame the current commit
3699 set parent -1
3700 }
3701 }
3702 # then count other lines that belong to it
3703 for {set i $line} {[incr i -1] > $s_lno} {} {
3704 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3705 # Determine if the line is removed
3706 set removed_idx [string first "-" $chunk]
3707 if {$parent >= 0} {
3708 set code [string index $chunk $parent]
3709 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3710 incr dline
3711 }
3712 } else {
3713 if {$removed_idx < 0} {
3714 incr dline
3715 }
3716 }
3717 }
3718 incr parent
3719 } else {
3720 set parent 0
3721 }
3722
3723 incr dline [lindex $base_lines $parent]
3724 return [list $parent $dline]
3725}
3726
3727proc external_blame_diff {} {
3728 global currentid cmitmode
3729 global diff_menu_txtpos diff_menu_line
3730 global diff_menu_filebase flist_menu_file
3731
3732 if {$cmitmode eq "tree"} {
3733 set parent_idx 0
3734 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3735 } else {
3736 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3737 if {$hinfo ne {}} {
3738 set parent_idx [lindex $hinfo 0]
3739 set line [lindex $hinfo 1]
3740 } else {
3741 set parent_idx 0
3742 set line 0
3743 }
3744 }
3745
3746 external_blame $parent_idx $line
3747}
3748
3749# Find the SHA1 ID of the blob for file $fname in the index
3750# at stage 0 or 2
3751proc index_sha1 {fname} {
3752 set f [open [list | git ls-files -s $fname] r]
3753 while {[gets $f line] >= 0} {
3754 set info [lindex [split $line "\t"] 0]
3755 set stage [lindex $info 2]
3756 if {$stage eq "0" || $stage eq "2"} {
3757 close $f
3758 return [lindex $info 1]
3759 }
3760 }
3761 close $f
3762 return {}
3763}
3764
3765# Turn an absolute path into one relative to the current directory
3766proc make_relative {f} {
3767 if {[file pathtype $f] eq "relative"} {
3768 return $f
3769 }
3770 set elts [file split $f]
3771 set here [file split [pwd]]
3772 set ei 0
3773 set hi 0
3774 set res {}
3775 foreach d $here {
3776 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3777 lappend res ".."
3778 } else {
3779 incr ei
3780 }
3781 incr hi
3782 }
3783 set elts [concat $res [lrange $elts $ei end]]
3784 return [eval file join $elts]
3785}
3786
3787proc external_blame {parent_idx {line {}}} {
3788 global flist_menu_file cdup
3789 global nullid nullid2
3790 global parentlist selectedline currentid
3791
3792 if {$parent_idx > 0} {
3793 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3794 } else {
3795 set base_commit $currentid
3796 }
3797
3798 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3799 error_popup [mc "No such commit"]
3800 return
3801 }
3802
3803 set cmdline [list git gui blame]
3804 if {$line ne {} && $line > 1} {
3805 lappend cmdline "--line=$line"
3806 }
3807 set f [file join $cdup $flist_menu_file]
3808 # Unfortunately it seems git gui blame doesn't like
3809 # being given an absolute path...
3810 set f [make_relative $f]
3811 lappend cmdline $base_commit $f
3812 if {[catch {eval exec $cmdline &} err]} {
3813 error_popup "[mc "git gui blame: command failed:"] $err"
3814 }
3815}
3816
3817proc show_line_source {} {
3818 global cmitmode currentid parents curview blamestuff blameinst
3819 global diff_menu_line diff_menu_filebase flist_menu_file
3820 global nullid nullid2 gitdir cdup
3821
3822 set from_index {}
3823 if {$cmitmode eq "tree"} {
3824 set id $currentid
3825 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3826 } else {
3827 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3828 if {$h eq {}} return
3829 set pi [lindex $h 0]
3830 if {$pi == 0} {
3831 mark_ctext_line $diff_menu_line
3832 return
3833 }
3834 incr pi -1
3835 if {$currentid eq $nullid} {
3836 if {$pi > 0} {
3837 # must be a merge in progress...
3838 if {[catch {
3839 # get the last line from .git/MERGE_HEAD
3840 set f [open [file join $gitdir MERGE_HEAD] r]
3841 set id [lindex [split [read $f] "\n"] end-1]
3842 close $f
3843 } err]} {
3844 error_popup [mc "Couldn't read merge head: %s" $err]
3845 return
3846 }
3847 } elseif {$parents($curview,$currentid) eq $nullid2} {
3848 # need to do the blame from the index
3849 if {[catch {
3850 set from_index [index_sha1 $flist_menu_file]
3851 } err]} {
3852 error_popup [mc "Error reading index: %s" $err]
3853 return
3854 }
3855 } else {
3856 set id $parents($curview,$currentid)
3857 }
3858 } else {
3859 set id [lindex $parents($curview,$currentid) $pi]
3860 }
3861 set line [lindex $h 1]
3862 }
3863 set blameargs {}
3864 if {$from_index ne {}} {
3865 lappend blameargs | git cat-file blob $from_index
3866 }
3867 lappend blameargs | git blame -p -L$line,+1
3868 if {$from_index ne {}} {
3869 lappend blameargs --contents -
3870 } else {
3871 lappend blameargs $id
3872 }
3873 lappend blameargs -- [file join $cdup $flist_menu_file]
3874 if {[catch {
3875 set f [open $blameargs r]
3876 } err]} {
3877 error_popup [mc "Couldn't start git blame: %s" $err]
3878 return
3879 }
3880 nowbusy blaming [mc "Searching"]
3881 fconfigure $f -blocking 0
3882 set i [reg_instance $f]
3883 set blamestuff($i) {}
3884 set blameinst $i
3885 filerun $f [list read_line_source $f $i]
3886}
3887
3888proc stopblaming {} {
3889 global blameinst
3890
3891 if {[info exists blameinst]} {
3892 stop_instance $blameinst
3893 unset blameinst
3894 notbusy blaming
3895 }
3896}
3897
3898proc read_line_source {fd inst} {
3899 global blamestuff curview commfd blameinst nullid nullid2
3900
3901 while {[gets $fd line] >= 0} {
3902 lappend blamestuff($inst) $line
3903 }
3904 if {![eof $fd]} {
3905 return 1
3906 }
3907 unset commfd($inst)
3908 unset blameinst
3909 notbusy blaming
3910 fconfigure $fd -blocking 1
3911 if {[catch {close $fd} err]} {
3912 error_popup [mc "Error running git blame: %s" $err]
3913 return 0
3914 }
3915
3916 set fname {}
3917 set line [split [lindex $blamestuff($inst) 0] " "]
3918 set id [lindex $line 0]
3919 set lnum [lindex $line 1]
3920 if {[string length $id] == 40 && [string is xdigit $id] &&
3921 [string is digit -strict $lnum]} {
3922 # look for "filename" line
3923 foreach l $blamestuff($inst) {
3924 if {[string match "filename *" $l]} {
3925 set fname [string range $l 9 end]
3926 break
3927 }
3928 }
3929 }
3930 if {$fname ne {}} {
3931 # all looks good, select it
3932 if {$id eq $nullid} {
3933 # blame uses all-zeroes to mean not committed,
3934 # which would mean a change in the index
3935 set id $nullid2
3936 }
3937 if {[commitinview $id $curview]} {
3938 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3939 } else {
3940 error_popup [mc "That line comes from commit %s, \
3941 which is not in this view" [shortids $id]]
3942 }
3943 } else {
3944 puts "oops couldn't parse git blame output"
3945 }
3946 return 0
3947}
3948
3949# delete $dir when we see eof on $f (presumably because the child has exited)
3950proc delete_at_eof {f dir} {
3951 while {[gets $f line] >= 0} {}
3952 if {[eof $f]} {
3953 if {[catch {close $f} err]} {
3954 error_popup "[mc "External diff viewer failed:"] $err"
3955 }
3956 file delete -force $dir
3957 return 0
3958 }
3959 return 1
3960}
3961
3962# Functions for adding and removing shell-type quoting
3963
3964proc shellquote {str} {
3965 if {![string match "*\['\"\\ \t]*" $str]} {
3966 return $str
3967 }
3968 if {![string match "*\['\"\\]*" $str]} {
3969 return "\"$str\""
3970 }
3971 if {![string match "*'*" $str]} {
3972 return "'$str'"
3973 }
3974 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3975}
3976
3977proc shellarglist {l} {
3978 set str {}
3979 foreach a $l {
3980 if {$str ne {}} {
3981 append str " "
3982 }
3983 append str [shellquote $a]
3984 }
3985 return $str
3986}
3987
3988proc shelldequote {str} {
3989 set ret {}
3990 set used -1
3991 while {1} {
3992 incr used
3993 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3994 append ret [string range $str $used end]
3995 set used [string length $str]
3996 break
3997 }
3998 set first [lindex $first 0]
3999 set ch [string index $str $first]
4000 if {$first > $used} {
4001 append ret [string range $str $used [expr {$first - 1}]]
4002 set used $first
4003 }
4004 if {$ch eq " " || $ch eq "\t"} break
4005 incr used
4006 if {$ch eq "'"} {
4007 set first [string first "'" $str $used]
4008 if {$first < 0} {
4009 error "unmatched single-quote"
4010 }
4011 append ret [string range $str $used [expr {$first - 1}]]
4012 set used $first
4013 continue
4014 }
4015 if {$ch eq "\\"} {
4016 if {$used >= [string length $str]} {
4017 error "trailing backslash"
4018 }
4019 append ret [string index $str $used]
4020 continue
4021 }
4022 # here ch == "\""
4023 while {1} {
4024 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4025 error "unmatched double-quote"
4026 }
4027 set first [lindex $first 0]
4028 set ch [string index $str $first]
4029 if {$first > $used} {
4030 append ret [string range $str $used [expr {$first - 1}]]
4031 set used $first
4032 }
4033 if {$ch eq "\""} break
4034 incr used
4035 append ret [string index $str $used]
4036 incr used
4037 }
4038 }
4039 return [list $used $ret]
4040}
4041
4042proc shellsplit {str} {
4043 set l {}
4044 while {1} {
4045 set str [string trimleft $str]
4046 if {$str eq {}} break
4047 set dq [shelldequote $str]
4048 set n [lindex $dq 0]
4049 set word [lindex $dq 1]
4050 set str [string range $str $n end]
4051 lappend l $word
4052 }
4053 return $l
4054}
4055
4056proc set_window_title {} {
4057 global appname curview viewname vrevs
4058 set rev [mc "All files"]
4059 if {$curview ne 0} {
4060 if {$viewname($curview) eq [mc "Command line"]} {
4061 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4062 } else {
4063 set rev $viewname($curview)
4064 }
4065 }
4066 wm title . "[reponame]: $rev - $appname"
4067}
4068
4069# Code to implement multiple views
4070
4071proc newview {ishighlight} {
4072 global nextviewnum newviewname newishighlight
4073 global revtreeargs viewargscmd newviewopts curview
4074
4075 set newishighlight $ishighlight
4076 set top .gitkview
4077 if {[winfo exists $top]} {
4078 raise $top
4079 return
4080 }
4081 decode_view_opts $nextviewnum $revtreeargs
4082 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4083 set newviewopts($nextviewnum,perm) 0
4084 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4085 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4086}
4087
4088set known_view_options {
4089 {perm b . {} {mc "Remember this view"}}
4090 {reflabel l + {} {mc "References (space separated list):"}}
4091 {refs t15 .. {} {mc "Branches & tags:"}}
4092 {allrefs b *. "--all" {mc "All refs"}}
4093 {branches b . "--branches" {mc "All (local) branches"}}
4094 {tags b . "--tags" {mc "All tags"}}
4095 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4096 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4097 {author t15 .. "--author=*" {mc "Author:"}}
4098 {committer t15 . "--committer=*" {mc "Committer:"}}
4099 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4100 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4101 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4102 {changes_l l + {} {mc "Changes to Files:"}}
4103 {pickaxe_s r0 . {} {mc "Fixed String"}}
4104 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4105 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4106 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4107 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4108 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4109 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4110 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4111 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4112 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4113 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4114 {lright b . "--left-right" {mc "Mark branch sides"}}
4115 {first b . "--first-parent" {mc "Limit to first parent"}}
4116 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4117 {args t50 *. {} {mc "Additional arguments to git log:"}}
4118 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4119 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4120 }
4121
4122# Convert $newviewopts($n, ...) into args for git log.
4123proc encode_view_opts {n} {
4124 global known_view_options newviewopts
4125
4126 set rargs [list]
4127 foreach opt $known_view_options {
4128 set patterns [lindex $opt 3]
4129 if {$patterns eq {}} continue
4130 set pattern [lindex $patterns 0]
4131
4132 if {[lindex $opt 1] eq "b"} {
4133 set val $newviewopts($n,[lindex $opt 0])
4134 if {$val} {
4135 lappend rargs $pattern
4136 }
4137 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4138 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4139 set val $newviewopts($n,$button_id)
4140 if {$val eq $value} {
4141 lappend rargs $pattern
4142 }
4143 } else {
4144 set val $newviewopts($n,[lindex $opt 0])
4145 set val [string trim $val]
4146 if {$val ne {}} {
4147 set pfix [string range $pattern 0 end-1]
4148 lappend rargs $pfix$val
4149 }
4150 }
4151 }
4152 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4153 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4154}
4155
4156# Fill $newviewopts($n, ...) based on args for git log.
4157proc decode_view_opts {n view_args} {
4158 global known_view_options newviewopts
4159
4160 foreach opt $known_view_options {
4161 set id [lindex $opt 0]
4162 if {[lindex $opt 1] eq "b"} {
4163 # Checkboxes
4164 set val 0
4165 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4166 # Radiobuttons
4167 regexp {^(.*_)} $id uselessvar id
4168 set val 0
4169 } else {
4170 # Text fields
4171 set val {}
4172 }
4173 set newviewopts($n,$id) $val
4174 }
4175 set oargs [list]
4176 set refargs [list]
4177 foreach arg $view_args {
4178 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4179 && ![info exists found(limit)]} {
4180 set newviewopts($n,limit) $cnt
4181 set found(limit) 1
4182 continue
4183 }
4184 catch { unset val }
4185 foreach opt $known_view_options {
4186 set id [lindex $opt 0]
4187 if {[info exists found($id)]} continue
4188 foreach pattern [lindex $opt 3] {
4189 if {![string match $pattern $arg]} continue
4190 if {[lindex $opt 1] eq "b"} {
4191 # Check buttons
4192 set val 1
4193 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4194 # Radio buttons
4195 regexp {^(.*_)} $id uselessvar id
4196 set val $num
4197 } else {
4198 # Text input fields
4199 set size [string length $pattern]
4200 set val [string range $arg [expr {$size-1}] end]
4201 }
4202 set newviewopts($n,$id) $val
4203 set found($id) 1
4204 break
4205 }
4206 if {[info exists val]} break
4207 }
4208 if {[info exists val]} continue
4209 if {[regexp {^-} $arg]} {
4210 lappend oargs $arg
4211 } else {
4212 lappend refargs $arg
4213 }
4214 }
4215 set newviewopts($n,refs) [shellarglist $refargs]
4216 set newviewopts($n,args) [shellarglist $oargs]
4217}
4218
4219proc edit_or_newview {} {
4220 global curview
4221
4222 if {$curview > 0} {
4223 editview
4224 } else {
4225 newview 0
4226 }
4227}
4228
4229proc editview {} {
4230 global curview
4231 global viewname viewperm newviewname newviewopts
4232 global viewargs viewargscmd
4233
4234 set top .gitkvedit-$curview
4235 if {[winfo exists $top]} {
4236 raise $top
4237 return
4238 }
4239 decode_view_opts $curview $viewargs($curview)
4240 set newviewname($curview) $viewname($curview)
4241 set newviewopts($curview,perm) $viewperm($curview)
4242 set newviewopts($curview,cmd) $viewargscmd($curview)
4243 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4244}
4245
4246proc vieweditor {top n title} {
4247 global newviewname newviewopts viewfiles bgcolor
4248 global known_view_options NS
4249
4250 ttk_toplevel $top
4251 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4252 make_transient $top .
4253
4254 # View name
4255 ${NS}::frame $top.nfr
4256 ${NS}::label $top.nl -text [mc "View Name"]
4257 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4258 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4259 pack $top.nl -in $top.nfr -side left -padx {0 5}
4260 pack $top.name -in $top.nfr -side left -padx {0 25}
4261
4262 # View options
4263 set cframe $top.nfr
4264 set cexpand 0
4265 set cnt 0
4266 foreach opt $known_view_options {
4267 set id [lindex $opt 0]
4268 set type [lindex $opt 1]
4269 set flags [lindex $opt 2]
4270 set title [eval [lindex $opt 4]]
4271 set lxpad 0
4272
4273 if {$flags eq "+" || $flags eq "*"} {
4274 set cframe $top.fr$cnt
4275 incr cnt
4276 ${NS}::frame $cframe
4277 pack $cframe -in $top -fill x -pady 3 -padx 3
4278 set cexpand [expr {$flags eq "*"}]
4279 } elseif {$flags eq ".." || $flags eq "*."} {
4280 set cframe $top.fr$cnt
4281 incr cnt
4282 ${NS}::frame $cframe
4283 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4284 set cexpand [expr {$flags eq "*."}]
4285 } else {
4286 set lxpad 5
4287 }
4288
4289 if {$type eq "l"} {
4290 ${NS}::label $cframe.l_$id -text $title
4291 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4292 } elseif {$type eq "b"} {
4293 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4294 pack $cframe.c_$id -in $cframe -side left \
4295 -padx [list $lxpad 0] -expand $cexpand -anchor w
4296 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4297 regexp {^(.*_)} $id uselessvar button_id
4298 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4299 pack $cframe.c_$id -in $cframe -side left \
4300 -padx [list $lxpad 0] -expand $cexpand -anchor w
4301 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4302 ${NS}::label $cframe.l_$id -text $title
4303 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4304 -textvariable newviewopts($n,$id)
4305 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4306 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4307 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4308 ${NS}::label $cframe.l_$id -text $title
4309 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4310 -textvariable newviewopts($n,$id)
4311 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4312 pack $cframe.e_$id -in $cframe -side top -fill x
4313 } elseif {$type eq "path"} {
4314 ${NS}::label $top.l -text $title
4315 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4316 text $top.t -width 40 -height 5 -background $bgcolor
4317 if {[info exists viewfiles($n)]} {
4318 foreach f $viewfiles($n) {
4319 $top.t insert end $f
4320 $top.t insert end "\n"
4321 }
4322 $top.t delete {end - 1c} end
4323 $top.t mark set insert 0.0
4324 }
4325 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4326 }
4327 }
4328
4329 ${NS}::frame $top.buts
4330 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4331 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4332 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4333 bind $top <Control-Return> [list newviewok $top $n]
4334 bind $top <F5> [list newviewok $top $n 1]
4335 bind $top <Escape> [list destroy $top]
4336 grid $top.buts.ok $top.buts.apply $top.buts.can
4337 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4338 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4339 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4340 pack $top.buts -in $top -side top -fill x
4341 focus $top.t
4342}
4343
4344proc doviewmenu {m first cmd op argv} {
4345 set nmenu [$m index end]
4346 for {set i $first} {$i <= $nmenu} {incr i} {
4347 if {[$m entrycget $i -command] eq $cmd} {
4348 eval $m $op $i $argv
4349 break
4350 }
4351 }
4352}
4353
4354proc allviewmenus {n op args} {
4355 # global viewhlmenu
4356
4357 doviewmenu .bar.view 5 [list showview $n] $op $args
4358 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4359}
4360
4361proc newviewok {top n {apply 0}} {
4362 global nextviewnum newviewperm newviewname newishighlight
4363 global viewname viewfiles viewperm viewchanged selectedview curview
4364 global viewargs viewargscmd newviewopts viewhlmenu
4365
4366 if {[catch {
4367 set newargs [encode_view_opts $n]
4368 } err]} {
4369 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4370 return
4371 }
4372 set files {}
4373 foreach f [split [$top.t get 0.0 end] "\n"] {
4374 set ft [string trim $f]
4375 if {$ft ne {}} {
4376 lappend files $ft
4377 }
4378 }
4379 if {![info exists viewfiles($n)]} {
4380 # creating a new view
4381 incr nextviewnum
4382 set viewname($n) $newviewname($n)
4383 set viewperm($n) $newviewopts($n,perm)
4384 set viewchanged($n) 1
4385 set viewfiles($n) $files
4386 set viewargs($n) $newargs
4387 set viewargscmd($n) $newviewopts($n,cmd)
4388 addviewmenu $n
4389 if {!$newishighlight} {
4390 run showview $n
4391 } else {
4392 run addvhighlight $n
4393 }
4394 } else {
4395 # editing an existing view
4396 set viewperm($n) $newviewopts($n,perm)
4397 set viewchanged($n) 1
4398 if {$newviewname($n) ne $viewname($n)} {
4399 set viewname($n) $newviewname($n)
4400 doviewmenu .bar.view 5 [list showview $n] \
4401 entryconf [list -label $viewname($n)]
4402 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4403 # entryconf [list -label $viewname($n) -value $viewname($n)]
4404 }
4405 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4406 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4407 set viewfiles($n) $files
4408 set viewargs($n) $newargs
4409 set viewargscmd($n) $newviewopts($n,cmd)
4410 if {$curview == $n} {
4411 run reloadcommits
4412 }
4413 }
4414 }
4415 if {$apply} return
4416 catch {destroy $top}
4417}
4418
4419proc delview {} {
4420 global curview viewperm hlview selectedhlview viewchanged
4421
4422 if {$curview == 0} return
4423 if {[info exists hlview] && $hlview == $curview} {
4424 set selectedhlview [mc "None"]
4425 unset hlview
4426 }
4427 allviewmenus $curview delete
4428 set viewperm($curview) 0
4429 set viewchanged($curview) 1
4430 showview 0
4431}
4432
4433proc addviewmenu {n} {
4434 global viewname viewhlmenu
4435
4436 .bar.view add radiobutton -label $viewname($n) \
4437 -command [list showview $n] -variable selectedview -value $n
4438 #$viewhlmenu add radiobutton -label $viewname($n) \
4439 # -command [list addvhighlight $n] -variable selectedhlview
4440}
4441
4442proc showview {n} {
4443 global curview cached_commitrow ordertok
4444 global displayorder parentlist rowidlist rowisopt rowfinal
4445 global colormap rowtextx nextcolor canvxmax
4446 global numcommits viewcomplete
4447 global selectedline currentid canv canvy0
4448 global treediffs
4449 global pending_select mainheadid
4450 global commitidx
4451 global selectedview
4452 global hlview selectedhlview commitinterest
4453
4454 if {$n == $curview} return
4455 set selid {}
4456 set ymax [lindex [$canv cget -scrollregion] 3]
4457 set span [$canv yview]
4458 set ytop [expr {[lindex $span 0] * $ymax}]
4459 set ybot [expr {[lindex $span 1] * $ymax}]
4460 set yscreen [expr {($ybot - $ytop) / 2}]
4461 if {$selectedline ne {}} {
4462 set selid $currentid
4463 set y [yc $selectedline]
4464 if {$ytop < $y && $y < $ybot} {
4465 set yscreen [expr {$y - $ytop}]
4466 }
4467 } elseif {[info exists pending_select]} {
4468 set selid $pending_select
4469 unset pending_select
4470 }
4471 unselectline
4472 normalline
4473 unset -nocomplain treediffs
4474 clear_display
4475 if {[info exists hlview] && $hlview == $n} {
4476 unset hlview
4477 set selectedhlview [mc "None"]
4478 }
4479 unset -nocomplain commitinterest
4480 unset -nocomplain cached_commitrow
4481 unset -nocomplain ordertok
4482
4483 set curview $n
4484 set selectedview $n
4485 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4486 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4487
4488 run refill_reflist
4489 if {![info exists viewcomplete($n)]} {
4490 getcommits $selid
4491 return
4492 }
4493
4494 set displayorder {}
4495 set parentlist {}
4496 set rowidlist {}
4497 set rowisopt {}
4498 set rowfinal {}
4499 set numcommits $commitidx($n)
4500
4501 unset -nocomplain colormap
4502 unset -nocomplain rowtextx
4503 set nextcolor 0
4504 set canvxmax [$canv cget -width]
4505 set curview $n
4506 set row 0
4507 setcanvscroll
4508 set yf 0
4509 set row {}
4510 if {$selid ne {} && [commitinview $selid $n]} {
4511 set row [rowofcommit $selid]
4512 # try to get the selected row in the same position on the screen
4513 set ymax [lindex [$canv cget -scrollregion] 3]
4514 set ytop [expr {[yc $row] - $yscreen}]
4515 if {$ytop < 0} {
4516 set ytop 0
4517 }
4518 set yf [expr {$ytop * 1.0 / $ymax}]
4519 }
4520 allcanvs yview moveto $yf
4521 drawvisible
4522 if {$row ne {}} {
4523 selectline $row 0
4524 } elseif {!$viewcomplete($n)} {
4525 reset_pending_select $selid
4526 } else {
4527 reset_pending_select {}
4528
4529 if {[commitinview $pending_select $curview]} {
4530 selectline [rowofcommit $pending_select] 1
4531 } else {
4532 set row [first_real_row]
4533 if {$row < $numcommits} {
4534 selectline $row 0
4535 }
4536 }
4537 }
4538 if {!$viewcomplete($n)} {
4539 if {$numcommits == 0} {
4540 show_status [mc "Reading commits..."]
4541 }
4542 } elseif {$numcommits == 0} {
4543 show_status [mc "No commits selected"]
4544 }
4545 set_window_title
4546}
4547
4548# Stuff relating to the highlighting facility
4549
4550proc ishighlighted {id} {
4551 global vhighlights fhighlights nhighlights rhighlights
4552
4553 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4554 return $nhighlights($id)
4555 }
4556 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4557 return $vhighlights($id)
4558 }
4559 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4560 return $fhighlights($id)
4561 }
4562 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4563 return $rhighlights($id)
4564 }
4565 return 0
4566}
4567
4568proc bolden {id font} {
4569 global canv linehtag currentid boldids need_redisplay markedid
4570
4571 # need_redisplay = 1 means the display is stale and about to be redrawn
4572 if {$need_redisplay} return
4573 lappend boldids $id
4574 $canv itemconf $linehtag($id) -font $font
4575 if {[info exists currentid] && $id eq $currentid} {
4576 $canv delete secsel
4577 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4578 -outline {{}} -tags secsel \
4579 -fill [$canv cget -selectbackground]]
4580 $canv lower $t
4581 }
4582 if {[info exists markedid] && $id eq $markedid} {
4583 make_idmark $id
4584 }
4585}
4586
4587proc bolden_name {id font} {
4588 global canv2 linentag currentid boldnameids need_redisplay
4589
4590 if {$need_redisplay} return
4591 lappend boldnameids $id
4592 $canv2 itemconf $linentag($id) -font $font
4593 if {[info exists currentid] && $id eq $currentid} {
4594 $canv2 delete secsel
4595 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4596 -outline {{}} -tags secsel \
4597 -fill [$canv2 cget -selectbackground]]
4598 $canv2 lower $t
4599 }
4600}
4601
4602proc unbolden {} {
4603 global boldids
4604
4605 set stillbold {}
4606 foreach id $boldids {
4607 if {![ishighlighted $id]} {
4608 bolden $id mainfont
4609 } else {
4610 lappend stillbold $id
4611 }
4612 }
4613 set boldids $stillbold
4614}
4615
4616proc addvhighlight {n} {
4617 global hlview viewcomplete curview vhl_done commitidx
4618
4619 if {[info exists hlview]} {
4620 delvhighlight
4621 }
4622 set hlview $n
4623 if {$n != $curview && ![info exists viewcomplete($n)]} {
4624 start_rev_list $n
4625 }
4626 set vhl_done $commitidx($hlview)
4627 if {$vhl_done > 0} {
4628 drawvisible
4629 }
4630}
4631
4632proc delvhighlight {} {
4633 global hlview vhighlights
4634
4635 if {![info exists hlview]} return
4636 unset hlview
4637 unset -nocomplain vhighlights
4638 unbolden
4639}
4640
4641proc vhighlightmore {} {
4642 global hlview vhl_done commitidx vhighlights curview
4643
4644 set max $commitidx($hlview)
4645 set vr [visiblerows]
4646 set r0 [lindex $vr 0]
4647 set r1 [lindex $vr 1]
4648 for {set i $vhl_done} {$i < $max} {incr i} {
4649 set id [commitonrow $i $hlview]
4650 if {[commitinview $id $curview]} {
4651 set row [rowofcommit $id]
4652 if {$r0 <= $row && $row <= $r1} {
4653 if {![highlighted $row]} {
4654 bolden $id mainfontbold
4655 }
4656 set vhighlights($id) 1
4657 }
4658 }
4659 }
4660 set vhl_done $max
4661 return 0
4662}
4663
4664proc askvhighlight {row id} {
4665 global hlview vhighlights iddrawn
4666
4667 if {[commitinview $id $hlview]} {
4668 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4669 bolden $id mainfontbold
4670 }
4671 set vhighlights($id) 1
4672 } else {
4673 set vhighlights($id) 0
4674 }
4675}
4676
4677proc hfiles_change {} {
4678 global highlight_files filehighlight fhighlights fh_serial
4679 global highlight_paths
4680
4681 if {[info exists filehighlight]} {
4682 # delete previous highlights
4683 catch {close $filehighlight}
4684 unset filehighlight
4685 unset -nocomplain fhighlights
4686 unbolden
4687 unhighlight_filelist
4688 }
4689 set highlight_paths {}
4690 after cancel do_file_hl $fh_serial
4691 incr fh_serial
4692 if {$highlight_files ne {}} {
4693 after 300 do_file_hl $fh_serial
4694 }
4695}
4696
4697proc gdttype_change {name ix op} {
4698 global gdttype highlight_files findstring findpattern
4699
4700 stopfinding
4701 if {$findstring ne {}} {
4702 if {$gdttype eq [mc "containing:"]} {
4703 if {$highlight_files ne {}} {
4704 set highlight_files {}
4705 hfiles_change
4706 }
4707 findcom_change
4708 } else {
4709 if {$findpattern ne {}} {
4710 set findpattern {}
4711 findcom_change
4712 }
4713 set highlight_files $findstring
4714 hfiles_change
4715 }
4716 drawvisible
4717 }
4718 # enable/disable findtype/findloc menus too
4719}
4720
4721proc find_change {name ix op} {
4722 global gdttype findstring highlight_files
4723
4724 stopfinding
4725 if {$gdttype eq [mc "containing:"]} {
4726 findcom_change
4727 } else {
4728 if {$highlight_files ne $findstring} {
4729 set highlight_files $findstring
4730 hfiles_change
4731 }
4732 }
4733 drawvisible
4734}
4735
4736proc findcom_change args {
4737 global nhighlights boldnameids
4738 global findpattern findtype findstring gdttype
4739
4740 stopfinding
4741 # delete previous highlights, if any
4742 foreach id $boldnameids {
4743 bolden_name $id mainfont
4744 }
4745 set boldnameids {}
4746 unset -nocomplain nhighlights
4747 unbolden
4748 unmarkmatches
4749 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4750 set findpattern {}
4751 } elseif {$findtype eq [mc "Regexp"]} {
4752 set findpattern $findstring
4753 } else {
4754 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4755 $findstring]
4756 set findpattern "*$e*"
4757 }
4758}
4759
4760proc makepatterns {l} {
4761 set ret {}
4762 foreach e $l {
4763 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4764 if {[string index $ee end] eq "/"} {
4765 lappend ret "$ee*"
4766 } else {
4767 lappend ret $ee
4768 lappend ret "$ee/*"
4769 }
4770 }
4771 return $ret
4772}
4773
4774proc do_file_hl {serial} {
4775 global highlight_files filehighlight highlight_paths gdttype fhl_list
4776 global cdup findtype
4777
4778 if {$gdttype eq [mc "touching paths:"]} {
4779 # If "exact" match then convert backslashes to forward slashes.
4780 # Most useful to support Windows-flavoured file paths.
4781 if {$findtype eq [mc "Exact"]} {
4782 set highlight_files [string map {"\\" "/"} $highlight_files]
4783 }
4784 if {[catch {set paths [shellsplit $highlight_files]}]} return
4785 set highlight_paths [makepatterns $paths]
4786 highlight_filelist
4787 set relative_paths {}
4788 foreach path $paths {
4789 lappend relative_paths [file join $cdup $path]
4790 }
4791 set gdtargs [concat -- $relative_paths]
4792 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4793 set gdtargs [list "-S$highlight_files"]
4794 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4795 set gdtargs [list "-G$highlight_files"]
4796 } else {
4797 # must be "containing:", i.e. we're searching commit info
4798 return
4799 }
4800 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4801 set filehighlight [open $cmd r+]
4802 fconfigure $filehighlight -blocking 0
4803 filerun $filehighlight readfhighlight
4804 set fhl_list {}
4805 drawvisible
4806 flushhighlights
4807}
4808
4809proc flushhighlights {} {
4810 global filehighlight fhl_list
4811
4812 if {[info exists filehighlight]} {
4813 lappend fhl_list {}
4814 puts $filehighlight ""
4815 flush $filehighlight
4816 }
4817}
4818
4819proc askfilehighlight {row id} {
4820 global filehighlight fhighlights fhl_list
4821
4822 lappend fhl_list $id
4823 set fhighlights($id) -1
4824 puts $filehighlight $id
4825}
4826
4827proc readfhighlight {} {
4828 global filehighlight fhighlights curview iddrawn
4829 global fhl_list find_dirn
4830
4831 if {![info exists filehighlight]} {
4832 return 0
4833 }
4834 set nr 0
4835 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4836 set line [string trim $line]
4837 set i [lsearch -exact $fhl_list $line]
4838 if {$i < 0} continue
4839 for {set j 0} {$j < $i} {incr j} {
4840 set id [lindex $fhl_list $j]
4841 set fhighlights($id) 0
4842 }
4843 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4844 if {$line eq {}} continue
4845 if {![commitinview $line $curview]} continue
4846 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4847 bolden $line mainfontbold
4848 }
4849 set fhighlights($line) 1
4850 }
4851 if {[eof $filehighlight]} {
4852 # strange...
4853 puts "oops, git diff-tree died"
4854 catch {close $filehighlight}
4855 unset filehighlight
4856 return 0
4857 }
4858 if {[info exists find_dirn]} {
4859 run findmore
4860 }
4861 return 1
4862}
4863
4864proc doesmatch {f} {
4865 global findtype findpattern
4866
4867 if {$findtype eq [mc "Regexp"]} {
4868 return [regexp $findpattern $f]
4869 } elseif {$findtype eq [mc "IgnCase"]} {
4870 return [string match -nocase $findpattern $f]
4871 } else {
4872 return [string match $findpattern $f]
4873 }
4874}
4875
4876proc askfindhighlight {row id} {
4877 global nhighlights commitinfo iddrawn
4878 global findloc
4879 global markingmatches
4880
4881 if {![info exists commitinfo($id)]} {
4882 getcommit $id
4883 }
4884 set info $commitinfo($id)
4885 set isbold 0
4886 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4887 foreach f $info ty $fldtypes {
4888 if {$ty eq ""} continue
4889 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4890 [doesmatch $f]} {
4891 if {$ty eq [mc "Author"]} {
4892 set isbold 2
4893 break
4894 }
4895 set isbold 1
4896 }
4897 }
4898 if {$isbold && [info exists iddrawn($id)]} {
4899 if {![ishighlighted $id]} {
4900 bolden $id mainfontbold
4901 if {$isbold > 1} {
4902 bolden_name $id mainfontbold
4903 }
4904 }
4905 if {$markingmatches} {
4906 markrowmatches $row $id
4907 }
4908 }
4909 set nhighlights($id) $isbold
4910}
4911
4912proc markrowmatches {row id} {
4913 global canv canv2 linehtag linentag commitinfo findloc
4914
4915 set headline [lindex $commitinfo($id) 0]
4916 set author [lindex $commitinfo($id) 1]
4917 $canv delete match$row
4918 $canv2 delete match$row
4919 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4920 set m [findmatches $headline]
4921 if {$m ne {}} {
4922 markmatches $canv $row $headline $linehtag($id) $m \
4923 [$canv itemcget $linehtag($id) -font] $row
4924 }
4925 }
4926 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4927 set m [findmatches $author]
4928 if {$m ne {}} {
4929 markmatches $canv2 $row $author $linentag($id) $m \
4930 [$canv2 itemcget $linentag($id) -font] $row
4931 }
4932 }
4933}
4934
4935proc vrel_change {name ix op} {
4936 global highlight_related
4937
4938 rhighlight_none
4939 if {$highlight_related ne [mc "None"]} {
4940 run drawvisible
4941 }
4942}
4943
4944# prepare for testing whether commits are descendents or ancestors of a
4945proc rhighlight_sel {a} {
4946 global descendent desc_todo ancestor anc_todo
4947 global highlight_related
4948
4949 unset -nocomplain descendent
4950 set desc_todo [list $a]
4951 unset -nocomplain ancestor
4952 set anc_todo [list $a]
4953 if {$highlight_related ne [mc "None"]} {
4954 rhighlight_none
4955 run drawvisible
4956 }
4957}
4958
4959proc rhighlight_none {} {
4960 global rhighlights
4961
4962 unset -nocomplain rhighlights
4963 unbolden
4964}
4965
4966proc is_descendent {a} {
4967 global curview children descendent desc_todo
4968
4969 set v $curview
4970 set la [rowofcommit $a]
4971 set todo $desc_todo
4972 set leftover {}
4973 set done 0
4974 for {set i 0} {$i < [llength $todo]} {incr i} {
4975 set do [lindex $todo $i]
4976 if {[rowofcommit $do] < $la} {
4977 lappend leftover $do
4978 continue
4979 }
4980 foreach nk $children($v,$do) {
4981 if {![info exists descendent($nk)]} {
4982 set descendent($nk) 1
4983 lappend todo $nk
4984 if {$nk eq $a} {
4985 set done 1
4986 }
4987 }
4988 }
4989 if {$done} {
4990 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4991 return
4992 }
4993 }
4994 set descendent($a) 0
4995 set desc_todo $leftover
4996}
4997
4998proc is_ancestor {a} {
4999 global curview parents ancestor anc_todo
5000
5001 set v $curview
5002 set la [rowofcommit $a]
5003 set todo $anc_todo
5004 set leftover {}
5005 set done 0
5006 for {set i 0} {$i < [llength $todo]} {incr i} {
5007 set do [lindex $todo $i]
5008 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5009 lappend leftover $do
5010 continue
5011 }
5012 foreach np $parents($v,$do) {
5013 if {![info exists ancestor($np)]} {
5014 set ancestor($np) 1
5015 lappend todo $np
5016 if {$np eq $a} {
5017 set done 1
5018 }
5019 }
5020 }
5021 if {$done} {
5022 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5023 return
5024 }
5025 }
5026 set ancestor($a) 0
5027 set anc_todo $leftover
5028}
5029
5030proc askrelhighlight {row id} {
5031 global descendent highlight_related iddrawn rhighlights
5032 global selectedline ancestor
5033
5034 if {$selectedline eq {}} return
5035 set isbold 0
5036 if {$highlight_related eq [mc "Descendant"] ||
5037 $highlight_related eq [mc "Not descendant"]} {
5038 if {![info exists descendent($id)]} {
5039 is_descendent $id
5040 }
5041 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5042 set isbold 1
5043 }
5044 } elseif {$highlight_related eq [mc "Ancestor"] ||
5045 $highlight_related eq [mc "Not ancestor"]} {
5046 if {![info exists ancestor($id)]} {
5047 is_ancestor $id
5048 }
5049 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5050 set isbold 1
5051 }
5052 }
5053 if {[info exists iddrawn($id)]} {
5054 if {$isbold && ![ishighlighted $id]} {
5055 bolden $id mainfontbold
5056 }
5057 }
5058 set rhighlights($id) $isbold
5059}
5060
5061# Graph layout functions
5062
5063proc shortids {ids} {
5064 set res {}
5065 foreach id $ids {
5066 if {[llength $id] > 1} {
5067 lappend res [shortids $id]
5068 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5069 lappend res [string range $id 0 7]
5070 } else {
5071 lappend res $id
5072 }
5073 }
5074 return $res
5075}
5076
5077proc ntimes {n o} {
5078 set ret {}
5079 set o [list $o]
5080 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5081 if {($n & $mask) != 0} {
5082 set ret [concat $ret $o]
5083 }
5084 set o [concat $o $o]
5085 }
5086 return $ret
5087}
5088
5089proc ordertoken {id} {
5090 global ordertok curview varcid varcstart varctok curview parents children
5091 global nullid nullid2
5092
5093 if {[info exists ordertok($id)]} {
5094 return $ordertok($id)
5095 }
5096 set origid $id
5097 set todo {}
5098 while {1} {
5099 if {[info exists varcid($curview,$id)]} {
5100 set a $varcid($curview,$id)
5101 set p [lindex $varcstart($curview) $a]
5102 } else {
5103 set p [lindex $children($curview,$id) 0]
5104 }
5105 if {[info exists ordertok($p)]} {
5106 set tok $ordertok($p)
5107 break
5108 }
5109 set id [first_real_child $curview,$p]
5110 if {$id eq {}} {
5111 # it's a root
5112 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5113 break
5114 }
5115 if {[llength $parents($curview,$id)] == 1} {
5116 lappend todo [list $p {}]
5117 } else {
5118 set j [lsearch -exact $parents($curview,$id) $p]
5119 if {$j < 0} {
5120 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5121 }
5122 lappend todo [list $p [strrep $j]]
5123 }
5124 }
5125 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5126 set p [lindex $todo $i 0]
5127 append tok [lindex $todo $i 1]
5128 set ordertok($p) $tok
5129 }
5130 set ordertok($origid) $tok
5131 return $tok
5132}
5133
5134# Work out where id should go in idlist so that order-token
5135# values increase from left to right
5136proc idcol {idlist id {i 0}} {
5137 set t [ordertoken $id]
5138 if {$i < 0} {
5139 set i 0
5140 }
5141 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5142 if {$i > [llength $idlist]} {
5143 set i [llength $idlist]
5144 }
5145 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5146 incr i
5147 } else {
5148 if {$t > [ordertoken [lindex $idlist $i]]} {
5149 while {[incr i] < [llength $idlist] &&
5150 $t >= [ordertoken [lindex $idlist $i]]} {}
5151 }
5152 }
5153 return $i
5154}
5155
5156proc initlayout {} {
5157 global rowidlist rowisopt rowfinal displayorder parentlist
5158 global numcommits canvxmax canv
5159 global nextcolor
5160 global colormap rowtextx
5161
5162 set numcommits 0
5163 set displayorder {}
5164 set parentlist {}
5165 set nextcolor 0
5166 set rowidlist {}
5167 set rowisopt {}
5168 set rowfinal {}
5169 set canvxmax [$canv cget -width]
5170 unset -nocomplain colormap
5171 unset -nocomplain rowtextx
5172 setcanvscroll
5173}
5174
5175proc setcanvscroll {} {
5176 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5177 global lastscrollset lastscrollrows
5178
5179 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5180 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5181 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5182 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5183 set lastscrollset [clock clicks -milliseconds]
5184 set lastscrollrows $numcommits
5185}
5186
5187proc visiblerows {} {
5188 global canv numcommits linespc
5189
5190 set ymax [lindex [$canv cget -scrollregion] 3]
5191 if {$ymax eq {} || $ymax == 0} return
5192 set f [$canv yview]
5193 set y0 [expr {int([lindex $f 0] * $ymax)}]
5194 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5195 if {$r0 < 0} {
5196 set r0 0
5197 }
5198 set y1 [expr {int([lindex $f 1] * $ymax)}]
5199 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5200 if {$r1 >= $numcommits} {
5201 set r1 [expr {$numcommits - 1}]
5202 }
5203 return [list $r0 $r1]
5204}
5205
5206proc layoutmore {} {
5207 global commitidx viewcomplete curview
5208 global numcommits pending_select curview
5209 global lastscrollset lastscrollrows
5210
5211 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5212 [clock clicks -milliseconds] - $lastscrollset > 500} {
5213 setcanvscroll
5214 }
5215 if {[info exists pending_select] &&
5216 [commitinview $pending_select $curview]} {
5217 update
5218 selectline [rowofcommit $pending_select] 1
5219 }
5220 drawvisible
5221}
5222
5223# With path limiting, we mightn't get the actual HEAD commit,
5224# so ask git rev-list what is the first ancestor of HEAD that
5225# touches a file in the path limit.
5226proc get_viewmainhead {view} {
5227 global viewmainheadid vfilelimit viewinstances mainheadid
5228
5229 catch {
5230 set rfd [open [concat | git rev-list -1 $mainheadid \
5231 -- $vfilelimit($view)] r]
5232 set j [reg_instance $rfd]
5233 lappend viewinstances($view) $j
5234 fconfigure $rfd -blocking 0
5235 filerun $rfd [list getviewhead $rfd $j $view]
5236 set viewmainheadid($curview) {}
5237 }
5238}
5239
5240# git rev-list should give us just 1 line to use as viewmainheadid($view)
5241proc getviewhead {fd inst view} {
5242 global viewmainheadid commfd curview viewinstances showlocalchanges
5243
5244 set id {}
5245 if {[gets $fd line] < 0} {
5246 if {![eof $fd]} {
5247 return 1
5248 }
5249 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5250 set id $line
5251 }
5252 set viewmainheadid($view) $id
5253 close $fd
5254 unset commfd($inst)
5255 set i [lsearch -exact $viewinstances($view) $inst]
5256 if {$i >= 0} {
5257 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5258 }
5259 if {$showlocalchanges && $id ne {} && $view == $curview} {
5260 doshowlocalchanges
5261 }
5262 return 0
5263}
5264
5265proc doshowlocalchanges {} {
5266 global curview viewmainheadid
5267
5268 if {$viewmainheadid($curview) eq {}} return
5269 if {[commitinview $viewmainheadid($curview) $curview]} {
5270 dodiffindex
5271 } else {
5272 interestedin $viewmainheadid($curview) dodiffindex
5273 }
5274}
5275
5276proc dohidelocalchanges {} {
5277 global nullid nullid2 lserial curview
5278
5279 if {[commitinview $nullid $curview]} {
5280 removefakerow $nullid
5281 }
5282 if {[commitinview $nullid2 $curview]} {
5283 removefakerow $nullid2
5284 }
5285 incr lserial
5286}
5287
5288# spawn off a process to do git diff-index --cached HEAD
5289proc dodiffindex {} {
5290 global lserial showlocalchanges vfilelimit curview
5291 global hasworktree git_version
5292
5293 if {!$showlocalchanges || !$hasworktree} return
5294 incr lserial
5295 if {[package vcompare $git_version "1.7.2"] >= 0} {
5296 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5297 } else {
5298 set cmd "|git diff-index --cached HEAD"
5299 }
5300 if {$vfilelimit($curview) ne {}} {
5301 set cmd [concat $cmd -- $vfilelimit($curview)]
5302 }
5303 set fd [open $cmd r]
5304 fconfigure $fd -blocking 0
5305 set i [reg_instance $fd]
5306 filerun $fd [list readdiffindex $fd $lserial $i]
5307}
5308
5309proc readdiffindex {fd serial inst} {
5310 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5311 global vfilelimit
5312
5313 set isdiff 1
5314 if {[gets $fd line] < 0} {
5315 if {![eof $fd]} {
5316 return 1
5317 }
5318 set isdiff 0
5319 }
5320 # we only need to see one line and we don't really care what it says...
5321 stop_instance $inst
5322
5323 if {$serial != $lserial} {
5324 return 0
5325 }
5326
5327 # now see if there are any local changes not checked in to the index
5328 set cmd "|git diff-files"
5329 if {$vfilelimit($curview) ne {}} {
5330 set cmd [concat $cmd -- $vfilelimit($curview)]
5331 }
5332 set fd [open $cmd r]
5333 fconfigure $fd -blocking 0
5334 set i [reg_instance $fd]
5335 filerun $fd [list readdifffiles $fd $serial $i]
5336
5337 if {$isdiff && ![commitinview $nullid2 $curview]} {
5338 # add the line for the changes in the index to the graph
5339 set hl [mc "Local changes checked in to index but not committed"]
5340 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5341 set commitdata($nullid2) "\n $hl\n"
5342 if {[commitinview $nullid $curview]} {
5343 removefakerow $nullid
5344 }
5345 insertfakerow $nullid2 $viewmainheadid($curview)
5346 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5347 if {[commitinview $nullid $curview]} {
5348 removefakerow $nullid
5349 }
5350 removefakerow $nullid2
5351 }
5352 return 0
5353}
5354
5355proc readdifffiles {fd serial inst} {
5356 global viewmainheadid nullid nullid2 curview
5357 global commitinfo commitdata lserial
5358
5359 set isdiff 1
5360 if {[gets $fd line] < 0} {
5361 if {![eof $fd]} {
5362 return 1
5363 }
5364 set isdiff 0
5365 }
5366 # we only need to see one line and we don't really care what it says...
5367 stop_instance $inst
5368
5369 if {$serial != $lserial} {
5370 return 0
5371 }
5372
5373 if {$isdiff && ![commitinview $nullid $curview]} {
5374 # add the line for the local diff to the graph
5375 set hl [mc "Local uncommitted changes, not checked in to index"]
5376 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5377 set commitdata($nullid) "\n $hl\n"
5378 if {[commitinview $nullid2 $curview]} {
5379 set p $nullid2
5380 } else {
5381 set p $viewmainheadid($curview)
5382 }
5383 insertfakerow $nullid $p
5384 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5385 removefakerow $nullid
5386 }
5387 return 0
5388}
5389
5390proc nextuse {id row} {
5391 global curview children
5392
5393 if {[info exists children($curview,$id)]} {
5394 foreach kid $children($curview,$id) {
5395 if {![commitinview $kid $curview]} {
5396 return -1
5397 }
5398 if {[rowofcommit $kid] > $row} {
5399 return [rowofcommit $kid]
5400 }
5401 }
5402 }
5403 if {[commitinview $id $curview]} {
5404 return [rowofcommit $id]
5405 }
5406 return -1
5407}
5408
5409proc prevuse {id row} {
5410 global curview children
5411
5412 set ret -1
5413 if {[info exists children($curview,$id)]} {
5414 foreach kid $children($curview,$id) {
5415 if {![commitinview $kid $curview]} break
5416 if {[rowofcommit $kid] < $row} {
5417 set ret [rowofcommit $kid]
5418 }
5419 }
5420 }
5421 return $ret
5422}
5423
5424proc make_idlist {row} {
5425 global displayorder parentlist uparrowlen downarrowlen mingaplen
5426 global commitidx curview children
5427
5428 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5429 if {$r < 0} {
5430 set r 0
5431 }
5432 set ra [expr {$row - $downarrowlen}]
5433 if {$ra < 0} {
5434 set ra 0
5435 }
5436 set rb [expr {$row + $uparrowlen}]
5437 if {$rb > $commitidx($curview)} {
5438 set rb $commitidx($curview)
5439 }
5440 make_disporder $r [expr {$rb + 1}]
5441 set ids {}
5442 for {} {$r < $ra} {incr r} {
5443 set nextid [lindex $displayorder [expr {$r + 1}]]
5444 foreach p [lindex $parentlist $r] {
5445 if {$p eq $nextid} continue
5446 set rn [nextuse $p $r]
5447 if {$rn >= $row &&
5448 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5449 lappend ids [list [ordertoken $p] $p]
5450 }
5451 }
5452 }
5453 for {} {$r < $row} {incr r} {
5454 set nextid [lindex $displayorder [expr {$r + 1}]]
5455 foreach p [lindex $parentlist $r] {
5456 if {$p eq $nextid} continue
5457 set rn [nextuse $p $r]
5458 if {$rn < 0 || $rn >= $row} {
5459 lappend ids [list [ordertoken $p] $p]
5460 }
5461 }
5462 }
5463 set id [lindex $displayorder $row]
5464 lappend ids [list [ordertoken $id] $id]
5465 while {$r < $rb} {
5466 foreach p [lindex $parentlist $r] {
5467 set firstkid [lindex $children($curview,$p) 0]
5468 if {[rowofcommit $firstkid] < $row} {
5469 lappend ids [list [ordertoken $p] $p]
5470 }
5471 }
5472 incr r
5473 set id [lindex $displayorder $r]
5474 if {$id ne {}} {
5475 set firstkid [lindex $children($curview,$id) 0]
5476 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5477 lappend ids [list [ordertoken $id] $id]
5478 }
5479 }
5480 }
5481 set idlist {}
5482 foreach idx [lsort -unique $ids] {
5483 lappend idlist [lindex $idx 1]
5484 }
5485 return $idlist
5486}
5487
5488proc rowsequal {a b} {
5489 while {[set i [lsearch -exact $a {}]] >= 0} {
5490 set a [lreplace $a $i $i]
5491 }
5492 while {[set i [lsearch -exact $b {}]] >= 0} {
5493 set b [lreplace $b $i $i]
5494 }
5495 return [expr {$a eq $b}]
5496}
5497
5498proc makeupline {id row rend col} {
5499 global rowidlist uparrowlen downarrowlen mingaplen
5500
5501 for {set r $rend} {1} {set r $rstart} {
5502 set rstart [prevuse $id $r]
5503 if {$rstart < 0} return
5504 if {$rstart < $row} break
5505 }
5506 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5507 set rstart [expr {$rend - $uparrowlen - 1}]
5508 }
5509 for {set r $rstart} {[incr r] <= $row} {} {
5510 set idlist [lindex $rowidlist $r]
5511 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5512 set col [idcol $idlist $id $col]
5513 lset rowidlist $r [linsert $idlist $col $id]
5514 changedrow $r
5515 }
5516 }
5517}
5518
5519proc layoutrows {row endrow} {
5520 global rowidlist rowisopt rowfinal displayorder
5521 global uparrowlen downarrowlen maxwidth mingaplen
5522 global children parentlist
5523 global commitidx viewcomplete curview
5524
5525 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5526 set idlist {}
5527 if {$row > 0} {
5528 set rm1 [expr {$row - 1}]
5529 foreach id [lindex $rowidlist $rm1] {
5530 if {$id ne {}} {
5531 lappend idlist $id
5532 }
5533 }
5534 set final [lindex $rowfinal $rm1]
5535 }
5536 for {} {$row < $endrow} {incr row} {
5537 set rm1 [expr {$row - 1}]
5538 if {$rm1 < 0 || $idlist eq {}} {
5539 set idlist [make_idlist $row]
5540 set final 1
5541 } else {
5542 set id [lindex $displayorder $rm1]
5543 set col [lsearch -exact $idlist $id]
5544 set idlist [lreplace $idlist $col $col]
5545 foreach p [lindex $parentlist $rm1] {
5546 if {[lsearch -exact $idlist $p] < 0} {
5547 set col [idcol $idlist $p $col]
5548 set idlist [linsert $idlist $col $p]
5549 # if not the first child, we have to insert a line going up
5550 if {$id ne [lindex $children($curview,$p) 0]} {
5551 makeupline $p $rm1 $row $col
5552 }
5553 }
5554 }
5555 set id [lindex $displayorder $row]
5556 if {$row > $downarrowlen} {
5557 set termrow [expr {$row - $downarrowlen - 1}]
5558 foreach p [lindex $parentlist $termrow] {
5559 set i [lsearch -exact $idlist $p]
5560 if {$i < 0} continue
5561 set nr [nextuse $p $termrow]
5562 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5563 set idlist [lreplace $idlist $i $i]
5564 }
5565 }
5566 }
5567 set col [lsearch -exact $idlist $id]
5568 if {$col < 0} {
5569 set col [idcol $idlist $id]
5570 set idlist [linsert $idlist $col $id]
5571 if {$children($curview,$id) ne {}} {
5572 makeupline $id $rm1 $row $col
5573 }
5574 }
5575 set r [expr {$row + $uparrowlen - 1}]
5576 if {$r < $commitidx($curview)} {
5577 set x $col
5578 foreach p [lindex $parentlist $r] {
5579 if {[lsearch -exact $idlist $p] >= 0} continue
5580 set fk [lindex $children($curview,$p) 0]
5581 if {[rowofcommit $fk] < $row} {
5582 set x [idcol $idlist $p $x]
5583 set idlist [linsert $idlist $x $p]
5584 }
5585 }
5586 if {[incr r] < $commitidx($curview)} {
5587 set p [lindex $displayorder $r]
5588 if {[lsearch -exact $idlist $p] < 0} {
5589 set fk [lindex $children($curview,$p) 0]
5590 if {$fk ne {} && [rowofcommit $fk] < $row} {
5591 set x [idcol $idlist $p $x]
5592 set idlist [linsert $idlist $x $p]
5593 }
5594 }
5595 }
5596 }
5597 }
5598 if {$final && !$viewcomplete($curview) &&
5599 $row + $uparrowlen + $mingaplen + $downarrowlen
5600 >= $commitidx($curview)} {
5601 set final 0
5602 }
5603 set l [llength $rowidlist]
5604 if {$row == $l} {
5605 lappend rowidlist $idlist
5606 lappend rowisopt 0
5607 lappend rowfinal $final
5608 } elseif {$row < $l} {
5609 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5610 lset rowidlist $row $idlist
5611 changedrow $row
5612 }
5613 lset rowfinal $row $final
5614 } else {
5615 set pad [ntimes [expr {$row - $l}] {}]
5616 set rowidlist [concat $rowidlist $pad]
5617 lappend rowidlist $idlist
5618 set rowfinal [concat $rowfinal $pad]
5619 lappend rowfinal $final
5620 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5621 }
5622 }
5623 return $row
5624}
5625
5626proc changedrow {row} {
5627 global displayorder iddrawn rowisopt need_redisplay
5628
5629 set l [llength $rowisopt]
5630 if {$row < $l} {
5631 lset rowisopt $row 0
5632 if {$row + 1 < $l} {
5633 lset rowisopt [expr {$row + 1}] 0
5634 if {$row + 2 < $l} {
5635 lset rowisopt [expr {$row + 2}] 0
5636 }
5637 }
5638 }
5639 set id [lindex $displayorder $row]
5640 if {[info exists iddrawn($id)]} {
5641 set need_redisplay 1
5642 }
5643}
5644
5645proc insert_pad {row col npad} {
5646 global rowidlist
5647
5648 set pad [ntimes $npad {}]
5649 set idlist [lindex $rowidlist $row]
5650 set bef [lrange $idlist 0 [expr {$col - 1}]]
5651 set aft [lrange $idlist $col end]
5652 set i [lsearch -exact $aft {}]
5653 if {$i > 0} {
5654 set aft [lreplace $aft $i $i]
5655 }
5656 lset rowidlist $row [concat $bef $pad $aft]
5657 changedrow $row
5658}
5659
5660proc optimize_rows {row col endrow} {
5661 global rowidlist rowisopt displayorder curview children
5662
5663 if {$row < 1} {
5664 set row 1
5665 }
5666 for {} {$row < $endrow} {incr row; set col 0} {
5667 if {[lindex $rowisopt $row]} continue
5668 set haspad 0
5669 set y0 [expr {$row - 1}]
5670 set ym [expr {$row - 2}]
5671 set idlist [lindex $rowidlist $row]
5672 set previdlist [lindex $rowidlist $y0]
5673 if {$idlist eq {} || $previdlist eq {}} continue
5674 if {$ym >= 0} {
5675 set pprevidlist [lindex $rowidlist $ym]
5676 if {$pprevidlist eq {}} continue
5677 } else {
5678 set pprevidlist {}
5679 }
5680 set x0 -1
5681 set xm -1
5682 for {} {$col < [llength $idlist]} {incr col} {
5683 set id [lindex $idlist $col]
5684 if {[lindex $previdlist $col] eq $id} continue
5685 if {$id eq {}} {
5686 set haspad 1
5687 continue
5688 }
5689 set x0 [lsearch -exact $previdlist $id]
5690 if {$x0 < 0} continue
5691 set z [expr {$x0 - $col}]
5692 set isarrow 0
5693 set z0 {}
5694 if {$ym >= 0} {
5695 set xm [lsearch -exact $pprevidlist $id]
5696 if {$xm >= 0} {
5697 set z0 [expr {$xm - $x0}]
5698 }
5699 }
5700 if {$z0 eq {}} {
5701 # if row y0 is the first child of $id then it's not an arrow
5702 if {[lindex $children($curview,$id) 0] ne
5703 [lindex $displayorder $y0]} {
5704 set isarrow 1
5705 }
5706 }
5707 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5708 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5709 set isarrow 1
5710 }
5711 # Looking at lines from this row to the previous row,
5712 # make them go straight up if they end in an arrow on
5713 # the previous row; otherwise make them go straight up
5714 # or at 45 degrees.
5715 if {$z < -1 || ($z < 0 && $isarrow)} {
5716 # Line currently goes left too much;
5717 # insert pads in the previous row, then optimize it
5718 set npad [expr {-1 - $z + $isarrow}]
5719 insert_pad $y0 $x0 $npad
5720 if {$y0 > 0} {
5721 optimize_rows $y0 $x0 $row
5722 }
5723 set previdlist [lindex $rowidlist $y0]
5724 set x0 [lsearch -exact $previdlist $id]
5725 set z [expr {$x0 - $col}]
5726 if {$z0 ne {}} {
5727 set pprevidlist [lindex $rowidlist $ym]
5728 set xm [lsearch -exact $pprevidlist $id]
5729 set z0 [expr {$xm - $x0}]
5730 }
5731 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5732 # Line currently goes right too much;
5733 # insert pads in this line
5734 set npad [expr {$z - 1 + $isarrow}]
5735 insert_pad $row $col $npad
5736 set idlist [lindex $rowidlist $row]
5737 incr col $npad
5738 set z [expr {$x0 - $col}]
5739 set haspad 1
5740 }
5741 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5742 # this line links to its first child on row $row-2
5743 set id [lindex $displayorder $ym]
5744 set xc [lsearch -exact $pprevidlist $id]
5745 if {$xc >= 0} {
5746 set z0 [expr {$xc - $x0}]
5747 }
5748 }
5749 # avoid lines jigging left then immediately right
5750 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5751 insert_pad $y0 $x0 1
5752 incr x0
5753 optimize_rows $y0 $x0 $row
5754 set previdlist [lindex $rowidlist $y0]
5755 }
5756 }
5757 if {!$haspad} {
5758 # Find the first column that doesn't have a line going right
5759 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5760 set id [lindex $idlist $col]
5761 if {$id eq {}} break
5762 set x0 [lsearch -exact $previdlist $id]
5763 if {$x0 < 0} {
5764 # check if this is the link to the first child
5765 set kid [lindex $displayorder $y0]
5766 if {[lindex $children($curview,$id) 0] eq $kid} {
5767 # it is, work out offset to child
5768 set x0 [lsearch -exact $previdlist $kid]
5769 }
5770 }
5771 if {$x0 <= $col} break
5772 }
5773 # Insert a pad at that column as long as it has a line and
5774 # isn't the last column
5775 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5776 set idlist [linsert $idlist $col {}]
5777 lset rowidlist $row $idlist
5778 changedrow $row
5779 }
5780 }
5781 }
5782}
5783
5784proc xc {row col} {
5785 global canvx0 linespc
5786 return [expr {$canvx0 + $col * $linespc}]
5787}
5788
5789proc yc {row} {
5790 global canvy0 linespc
5791 return [expr {$canvy0 + $row * $linespc}]
5792}
5793
5794proc linewidth {id} {
5795 global thickerline lthickness
5796
5797 set wid $lthickness
5798 if {[info exists thickerline] && $id eq $thickerline} {
5799 set wid [expr {2 * $lthickness}]
5800 }
5801 return $wid
5802}
5803
5804proc rowranges {id} {
5805 global curview children uparrowlen downarrowlen
5806 global rowidlist
5807
5808 set kids $children($curview,$id)
5809 if {$kids eq {}} {
5810 return {}
5811 }
5812 set ret {}
5813 lappend kids $id
5814 foreach child $kids {
5815 if {![commitinview $child $curview]} break
5816 set row [rowofcommit $child]
5817 if {![info exists prev]} {
5818 lappend ret [expr {$row + 1}]
5819 } else {
5820 if {$row <= $prevrow} {
5821 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5822 }
5823 # see if the line extends the whole way from prevrow to row
5824 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5825 [lsearch -exact [lindex $rowidlist \
5826 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5827 # it doesn't, see where it ends
5828 set r [expr {$prevrow + $downarrowlen}]
5829 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5830 while {[incr r -1] > $prevrow &&
5831 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5832 } else {
5833 while {[incr r] <= $row &&
5834 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5835 incr r -1
5836 }
5837 lappend ret $r
5838 # see where it starts up again
5839 set r [expr {$row - $uparrowlen}]
5840 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5841 while {[incr r] < $row &&
5842 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5843 } else {
5844 while {[incr r -1] >= $prevrow &&
5845 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5846 incr r
5847 }
5848 lappend ret $r
5849 }
5850 }
5851 if {$child eq $id} {
5852 lappend ret $row
5853 }
5854 set prev $child
5855 set prevrow $row
5856 }
5857 return $ret
5858}
5859
5860proc drawlineseg {id row endrow arrowlow} {
5861 global rowidlist displayorder iddrawn linesegs
5862 global canv colormap linespc curview maxlinelen parentlist
5863
5864 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5865 set le [expr {$row + 1}]
5866 set arrowhigh 1
5867 while {1} {
5868 set c [lsearch -exact [lindex $rowidlist $le] $id]
5869 if {$c < 0} {
5870 incr le -1
5871 break
5872 }
5873 lappend cols $c
5874 set x [lindex $displayorder $le]
5875 if {$x eq $id} {
5876 set arrowhigh 0
5877 break
5878 }
5879 if {[info exists iddrawn($x)] || $le == $endrow} {
5880 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5881 if {$c >= 0} {
5882 lappend cols $c
5883 set arrowhigh 0
5884 }
5885 break
5886 }
5887 incr le
5888 }
5889 if {$le <= $row} {
5890 return $row
5891 }
5892
5893 set lines {}
5894 set i 0
5895 set joinhigh 0
5896 if {[info exists linesegs($id)]} {
5897 set lines $linesegs($id)
5898 foreach li $lines {
5899 set r0 [lindex $li 0]
5900 if {$r0 > $row} {
5901 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5902 set joinhigh 1
5903 }
5904 break
5905 }
5906 incr i
5907 }
5908 }
5909 set joinlow 0
5910 if {$i > 0} {
5911 set li [lindex $lines [expr {$i-1}]]
5912 set r1 [lindex $li 1]
5913 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5914 set joinlow 1
5915 }
5916 }
5917
5918 set x [lindex $cols [expr {$le - $row}]]
5919 set xp [lindex $cols [expr {$le - 1 - $row}]]
5920 set dir [expr {$xp - $x}]
5921 if {$joinhigh} {
5922 set ith [lindex $lines $i 2]
5923 set coords [$canv coords $ith]
5924 set ah [$canv itemcget $ith -arrow]
5925 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5926 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5927 if {$x2 ne {} && $x - $x2 == $dir} {
5928 set coords [lrange $coords 0 end-2]
5929 }
5930 } else {
5931 set coords [list [xc $le $x] [yc $le]]
5932 }
5933 if {$joinlow} {
5934 set itl [lindex $lines [expr {$i-1}] 2]
5935 set al [$canv itemcget $itl -arrow]
5936 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5937 } elseif {$arrowlow} {
5938 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5939 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5940 set arrowlow 0
5941 }
5942 }
5943 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5944 for {set y $le} {[incr y -1] > $row} {} {
5945 set x $xp
5946 set xp [lindex $cols [expr {$y - 1 - $row}]]
5947 set ndir [expr {$xp - $x}]
5948 if {$dir != $ndir || $xp < 0} {
5949 lappend coords [xc $y $x] [yc $y]
5950 }
5951 set dir $ndir
5952 }
5953 if {!$joinlow} {
5954 if {$xp < 0} {
5955 # join parent line to first child
5956 set ch [lindex $displayorder $row]
5957 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5958 if {$xc < 0} {
5959 puts "oops: drawlineseg: child $ch not on row $row"
5960 } elseif {$xc != $x} {
5961 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5962 set d [expr {int(0.5 * $linespc)}]
5963 set x1 [xc $row $x]
5964 if {$xc < $x} {
5965 set x2 [expr {$x1 - $d}]
5966 } else {
5967 set x2 [expr {$x1 + $d}]
5968 }
5969 set y2 [yc $row]
5970 set y1 [expr {$y2 + $d}]
5971 lappend coords $x1 $y1 $x2 $y2
5972 } elseif {$xc < $x - 1} {
5973 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5974 } elseif {$xc > $x + 1} {
5975 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5976 }
5977 set x $xc
5978 }
5979 lappend coords [xc $row $x] [yc $row]
5980 } else {
5981 set xn [xc $row $xp]
5982 set yn [yc $row]
5983 lappend coords $xn $yn
5984 }
5985 if {!$joinhigh} {
5986 assigncolor $id
5987 set t [$canv create line $coords -width [linewidth $id] \
5988 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5989 $canv lower $t
5990 bindline $t $id
5991 set lines [linsert $lines $i [list $row $le $t]]
5992 } else {
5993 $canv coords $ith $coords
5994 if {$arrow ne $ah} {
5995 $canv itemconf $ith -arrow $arrow
5996 }
5997 lset lines $i 0 $row
5998 }
5999 } else {
6000 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6001 set ndir [expr {$xo - $xp}]
6002 set clow [$canv coords $itl]
6003 if {$dir == $ndir} {
6004 set clow [lrange $clow 2 end]
6005 }
6006 set coords [concat $coords $clow]
6007 if {!$joinhigh} {
6008 lset lines [expr {$i-1}] 1 $le
6009 } else {
6010 # coalesce two pieces
6011 $canv delete $ith
6012 set b [lindex $lines [expr {$i-1}] 0]
6013 set e [lindex $lines $i 1]
6014 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6015 }
6016 $canv coords $itl $coords
6017 if {$arrow ne $al} {
6018 $canv itemconf $itl -arrow $arrow
6019 }
6020 }
6021
6022 set linesegs($id) $lines
6023 return $le
6024}
6025
6026proc drawparentlinks {id row} {
6027 global rowidlist canv colormap curview parentlist
6028 global idpos linespc
6029
6030 set rowids [lindex $rowidlist $row]
6031 set col [lsearch -exact $rowids $id]
6032 if {$col < 0} return
6033 set olds [lindex $parentlist $row]
6034 set row2 [expr {$row + 1}]
6035 set x [xc $row $col]
6036 set y [yc $row]
6037 set y2 [yc $row2]
6038 set d [expr {int(0.5 * $linespc)}]
6039 set ymid [expr {$y + $d}]
6040 set ids [lindex $rowidlist $row2]
6041 # rmx = right-most X coord used
6042 set rmx 0
6043 foreach p $olds {
6044 set i [lsearch -exact $ids $p]
6045 if {$i < 0} {
6046 puts "oops, parent $p of $id not in list"
6047 continue
6048 }
6049 set x2 [xc $row2 $i]
6050 if {$x2 > $rmx} {
6051 set rmx $x2
6052 }
6053 set j [lsearch -exact $rowids $p]
6054 if {$j < 0} {
6055 # drawlineseg will do this one for us
6056 continue
6057 }
6058 assigncolor $p
6059 # should handle duplicated parents here...
6060 set coords [list $x $y]
6061 if {$i != $col} {
6062 # if attaching to a vertical segment, draw a smaller
6063 # slant for visual distinctness
6064 if {$i == $j} {
6065 if {$i < $col} {
6066 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6067 } else {
6068 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6069 }
6070 } elseif {$i < $col && $i < $j} {
6071 # segment slants towards us already
6072 lappend coords [xc $row $j] $y
6073 } else {
6074 if {$i < $col - 1} {
6075 lappend coords [expr {$x2 + $linespc}] $y
6076 } elseif {$i > $col + 1} {
6077 lappend coords [expr {$x2 - $linespc}] $y
6078 }
6079 lappend coords $x2 $y2
6080 }
6081 } else {
6082 lappend coords $x2 $y2
6083 }
6084 set t [$canv create line $coords -width [linewidth $p] \
6085 -fill $colormap($p) -tags lines.$p]
6086 $canv lower $t
6087 bindline $t $p
6088 }
6089 if {$rmx > [lindex $idpos($id) 1]} {
6090 lset idpos($id) 1 $rmx
6091 redrawtags $id
6092 }
6093}
6094
6095proc drawlines {id} {
6096 global canv
6097
6098 $canv itemconf lines.$id -width [linewidth $id]
6099}
6100
6101proc drawcmittext {id row col} {
6102 global linespc canv canv2 canv3 fgcolor curview
6103 global cmitlisted commitinfo rowidlist parentlist
6104 global rowtextx idpos idtags idheads idotherrefs
6105 global linehtag linentag linedtag selectedline
6106 global canvxmax boldids boldnameids fgcolor markedid
6107 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6108 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6109 global circleoutlinecolor
6110
6111 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6112 set listed $cmitlisted($curview,$id)
6113 if {$id eq $nullid} {
6114 set ofill $workingfilescirclecolor
6115 } elseif {$id eq $nullid2} {
6116 set ofill $indexcirclecolor
6117 } elseif {$id eq $mainheadid} {
6118 set ofill $mainheadcirclecolor
6119 } else {
6120 set ofill [lindex $circlecolors $listed]
6121 }
6122 set x [xc $row $col]
6123 set y [yc $row]
6124 set orad [expr {$linespc / 3}]
6125 if {$listed <= 2} {
6126 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6127 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6128 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6129 } elseif {$listed == 3} {
6130 # triangle pointing left for left-side commits
6131 set t [$canv create polygon \
6132 [expr {$x - $orad}] $y \
6133 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6134 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6135 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6136 } else {
6137 # triangle pointing right for right-side commits
6138 set t [$canv create polygon \
6139 [expr {$x + $orad - 1}] $y \
6140 [expr {$x - $orad}] [expr {$y - $orad}] \
6141 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6142 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6143 }
6144 set circleitem($row) $t
6145 $canv raise $t
6146 $canv bind $t <1> {selcanvline {} %x %y}
6147 set rmx [llength [lindex $rowidlist $row]]
6148 set olds [lindex $parentlist $row]
6149 if {$olds ne {}} {
6150 set nextids [lindex $rowidlist [expr {$row + 1}]]
6151 foreach p $olds {
6152 set i [lsearch -exact $nextids $p]
6153 if {$i > $rmx} {
6154 set rmx $i
6155 }
6156 }
6157 }
6158 set xt [xc $row $rmx]
6159 set rowtextx($row) $xt
6160 set idpos($id) [list $x $xt $y]
6161 if {[info exists idtags($id)] || [info exists idheads($id)]
6162 || [info exists idotherrefs($id)]} {
6163 set xt [drawtags $id $x $xt $y]
6164 }
6165 if {[lindex $commitinfo($id) 6] > 0} {
6166 set xt [drawnotesign $xt $y]
6167 }
6168 set headline [lindex $commitinfo($id) 0]
6169 set name [lindex $commitinfo($id) 1]
6170 set date [lindex $commitinfo($id) 2]
6171 set date [formatdate $date]
6172 set font mainfont
6173 set nfont mainfont
6174 set isbold [ishighlighted $id]
6175 if {$isbold > 0} {
6176 lappend boldids $id
6177 set font mainfontbold
6178 if {$isbold > 1} {
6179 lappend boldnameids $id
6180 set nfont mainfontbold
6181 }
6182 }
6183 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6184 -text $headline -font $font -tags text]
6185 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6186 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6187 -text $name -font $nfont -tags text]
6188 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6189 -text $date -font mainfont -tags text]
6190 if {$selectedline == $row} {
6191 make_secsel $id
6192 }
6193 if {[info exists markedid] && $markedid eq $id} {
6194 make_idmark $id
6195 }
6196 set xr [expr {$xt + [font measure $font $headline]}]
6197 if {$xr > $canvxmax} {
6198 set canvxmax $xr
6199 setcanvscroll
6200 }
6201}
6202
6203proc drawcmitrow {row} {
6204 global displayorder rowidlist nrows_drawn
6205 global iddrawn markingmatches
6206 global commitinfo numcommits
6207 global filehighlight fhighlights findpattern nhighlights
6208 global hlview vhighlights
6209 global highlight_related rhighlights
6210
6211 if {$row >= $numcommits} return
6212
6213 set id [lindex $displayorder $row]
6214 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6215 askvhighlight $row $id
6216 }
6217 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6218 askfilehighlight $row $id
6219 }
6220 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6221 askfindhighlight $row $id
6222 }
6223 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6224 askrelhighlight $row $id
6225 }
6226 if {![info exists iddrawn($id)]} {
6227 set col [lsearch -exact [lindex $rowidlist $row] $id]
6228 if {$col < 0} {
6229 puts "oops, row $row id $id not in list"
6230 return
6231 }
6232 if {![info exists commitinfo($id)]} {
6233 getcommit $id
6234 }
6235 assigncolor $id
6236 drawcmittext $id $row $col
6237 set iddrawn($id) 1
6238 incr nrows_drawn
6239 }
6240 if {$markingmatches} {
6241 markrowmatches $row $id
6242 }
6243}
6244
6245proc drawcommits {row {endrow {}}} {
6246 global numcommits iddrawn displayorder curview need_redisplay
6247 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6248
6249 if {$row < 0} {
6250 set row 0
6251 }
6252 if {$endrow eq {}} {
6253 set endrow $row
6254 }
6255 if {$endrow >= $numcommits} {
6256 set endrow [expr {$numcommits - 1}]
6257 }
6258
6259 set rl1 [expr {$row - $downarrowlen - 3}]
6260 if {$rl1 < 0} {
6261 set rl1 0
6262 }
6263 set ro1 [expr {$row - 3}]
6264 if {$ro1 < 0} {
6265 set ro1 0
6266 }
6267 set r2 [expr {$endrow + $uparrowlen + 3}]
6268 if {$r2 > $numcommits} {
6269 set r2 $numcommits
6270 }
6271 for {set r $rl1} {$r < $r2} {incr r} {
6272 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6273 if {$rl1 < $r} {
6274 layoutrows $rl1 $r
6275 }
6276 set rl1 [expr {$r + 1}]
6277 }
6278 }
6279 if {$rl1 < $r} {
6280 layoutrows $rl1 $r
6281 }
6282 optimize_rows $ro1 0 $r2
6283 if {$need_redisplay || $nrows_drawn > 2000} {
6284 clear_display
6285 }
6286
6287 # make the lines join to already-drawn rows either side
6288 set r [expr {$row - 1}]
6289 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6290 set r $row
6291 }
6292 set er [expr {$endrow + 1}]
6293 if {$er >= $numcommits ||
6294 ![info exists iddrawn([lindex $displayorder $er])]} {
6295 set er $endrow
6296 }
6297 for {} {$r <= $er} {incr r} {
6298 set id [lindex $displayorder $r]
6299 set wasdrawn [info exists iddrawn($id)]
6300 drawcmitrow $r
6301 if {$r == $er} break
6302 set nextid [lindex $displayorder [expr {$r + 1}]]
6303 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6304 drawparentlinks $id $r
6305
6306 set rowids [lindex $rowidlist $r]
6307 foreach lid $rowids {
6308 if {$lid eq {}} continue
6309 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6310 if {$lid eq $id} {
6311 # see if this is the first child of any of its parents
6312 foreach p [lindex $parentlist $r] {
6313 if {[lsearch -exact $rowids $p] < 0} {
6314 # make this line extend up to the child
6315 set lineend($p) [drawlineseg $p $r $er 0]
6316 }
6317 }
6318 } else {
6319 set lineend($lid) [drawlineseg $lid $r $er 1]
6320 }
6321 }
6322 }
6323}
6324
6325proc undolayout {row} {
6326 global uparrowlen mingaplen downarrowlen
6327 global rowidlist rowisopt rowfinal need_redisplay
6328
6329 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6330 if {$r < 0} {
6331 set r 0
6332 }
6333 if {[llength $rowidlist] > $r} {
6334 incr r -1
6335 set rowidlist [lrange $rowidlist 0 $r]
6336 set rowfinal [lrange $rowfinal 0 $r]
6337 set rowisopt [lrange $rowisopt 0 $r]
6338 set need_redisplay 1
6339 run drawvisible
6340 }
6341}
6342
6343proc drawvisible {} {
6344 global canv linespc curview vrowmod selectedline targetrow targetid
6345 global need_redisplay cscroll numcommits
6346
6347 set fs [$canv yview]
6348 set ymax [lindex [$canv cget -scrollregion] 3]
6349 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6350 set f0 [lindex $fs 0]
6351 set f1 [lindex $fs 1]
6352 set y0 [expr {int($f0 * $ymax)}]
6353 set y1 [expr {int($f1 * $ymax)}]
6354
6355 if {[info exists targetid]} {
6356 if {[commitinview $targetid $curview]} {
6357 set r [rowofcommit $targetid]
6358 if {$r != $targetrow} {
6359 # Fix up the scrollregion and change the scrolling position
6360 # now that our target row has moved.
6361 set diff [expr {($r - $targetrow) * $linespc}]
6362 set targetrow $r
6363 setcanvscroll
6364 set ymax [lindex [$canv cget -scrollregion] 3]
6365 incr y0 $diff
6366 incr y1 $diff
6367 set f0 [expr {$y0 / $ymax}]
6368 set f1 [expr {$y1 / $ymax}]
6369 allcanvs yview moveto $f0
6370 $cscroll set $f0 $f1
6371 set need_redisplay 1
6372 }
6373 } else {
6374 unset targetid
6375 }
6376 }
6377
6378 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6379 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6380 if {$endrow >= $vrowmod($curview)} {
6381 update_arcrows $curview
6382 }
6383 if {$selectedline ne {} &&
6384 $row <= $selectedline && $selectedline <= $endrow} {
6385 set targetrow $selectedline
6386 } elseif {[info exists targetid]} {
6387 set targetrow [expr {int(($row + $endrow) / 2)}]
6388 }
6389 if {[info exists targetrow]} {
6390 if {$targetrow >= $numcommits} {
6391 set targetrow [expr {$numcommits - 1}]
6392 }
6393 set targetid [commitonrow $targetrow]
6394 }
6395 drawcommits $row $endrow
6396}
6397
6398proc clear_display {} {
6399 global iddrawn linesegs need_redisplay nrows_drawn
6400 global vhighlights fhighlights nhighlights rhighlights
6401 global linehtag linentag linedtag boldids boldnameids
6402
6403 allcanvs delete all
6404 unset -nocomplain iddrawn
6405 unset -nocomplain linesegs
6406 unset -nocomplain linehtag
6407 unset -nocomplain linentag
6408 unset -nocomplain linedtag
6409 set boldids {}
6410 set boldnameids {}
6411 unset -nocomplain vhighlights
6412 unset -nocomplain fhighlights
6413 unset -nocomplain nhighlights
6414 unset -nocomplain rhighlights
6415 set need_redisplay 0
6416 set nrows_drawn 0
6417}
6418
6419proc findcrossings {id} {
6420 global rowidlist parentlist numcommits displayorder
6421
6422 set cross {}
6423 set ccross {}
6424 foreach {s e} [rowranges $id] {
6425 if {$e >= $numcommits} {
6426 set e [expr {$numcommits - 1}]
6427 }
6428 if {$e <= $s} continue
6429 for {set row $e} {[incr row -1] >= $s} {} {
6430 set x [lsearch -exact [lindex $rowidlist $row] $id]
6431 if {$x < 0} break
6432 set olds [lindex $parentlist $row]
6433 set kid [lindex $displayorder $row]
6434 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6435 if {$kidx < 0} continue
6436 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6437 foreach p $olds {
6438 set px [lsearch -exact $nextrow $p]
6439 if {$px < 0} continue
6440 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6441 if {[lsearch -exact $ccross $p] >= 0} continue
6442 if {$x == $px + ($kidx < $px? -1: 1)} {
6443 lappend ccross $p
6444 } elseif {[lsearch -exact $cross $p] < 0} {
6445 lappend cross $p
6446 }
6447 }
6448 }
6449 }
6450 }
6451 return [concat $ccross {{}} $cross]
6452}
6453
6454proc assigncolor {id} {
6455 global colormap colors nextcolor
6456 global parents children children curview
6457
6458 if {[info exists colormap($id)]} return
6459 set ncolors [llength $colors]
6460 if {[info exists children($curview,$id)]} {
6461 set kids $children($curview,$id)
6462 } else {
6463 set kids {}
6464 }
6465 if {[llength $kids] == 1} {
6466 set child [lindex $kids 0]
6467 if {[info exists colormap($child)]
6468 && [llength $parents($curview,$child)] == 1} {
6469 set colormap($id) $colormap($child)
6470 return
6471 }
6472 }
6473 set badcolors {}
6474 set origbad {}
6475 foreach x [findcrossings $id] {
6476 if {$x eq {}} {
6477 # delimiter between corner crossings and other crossings
6478 if {[llength $badcolors] >= $ncolors - 1} break
6479 set origbad $badcolors
6480 }
6481 if {[info exists colormap($x)]
6482 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6483 lappend badcolors $colormap($x)
6484 }
6485 }
6486 if {[llength $badcolors] >= $ncolors} {
6487 set badcolors $origbad
6488 }
6489 set origbad $badcolors
6490 if {[llength $badcolors] < $ncolors - 1} {
6491 foreach child $kids {
6492 if {[info exists colormap($child)]
6493 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6494 lappend badcolors $colormap($child)
6495 }
6496 foreach p $parents($curview,$child) {
6497 if {[info exists colormap($p)]
6498 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6499 lappend badcolors $colormap($p)
6500 }
6501 }
6502 }
6503 if {[llength $badcolors] >= $ncolors} {
6504 set badcolors $origbad
6505 }
6506 }
6507 for {set i 0} {$i <= $ncolors} {incr i} {
6508 set c [lindex $colors $nextcolor]
6509 if {[incr nextcolor] >= $ncolors} {
6510 set nextcolor 0
6511 }
6512 if {[lsearch -exact $badcolors $c]} break
6513 }
6514 set colormap($id) $c
6515}
6516
6517proc bindline {t id} {
6518 global canv
6519
6520 $canv bind $t <Enter> "lineenter %x %y $id"
6521 $canv bind $t <Motion> "linemotion %x %y $id"
6522 $canv bind $t <Leave> "lineleave $id"
6523 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6524}
6525
6526proc graph_pane_width {} {
6527 global use_ttk
6528
6529 if {$use_ttk} {
6530 set g [.tf.histframe.pwclist sashpos 0]
6531 } else {
6532 set g [.tf.histframe.pwclist sash coord 0]
6533 }
6534 return [lindex $g 0]
6535}
6536
6537proc totalwidth {l font extra} {
6538 set tot 0
6539 foreach str $l {
6540 set tot [expr {$tot + [font measure $font $str] + $extra}]
6541 }
6542 return $tot
6543}
6544
6545proc drawtags {id x xt y1} {
6546 global idtags idheads idotherrefs mainhead
6547 global linespc lthickness
6548 global canv rowtextx curview fgcolor bgcolor ctxbut
6549 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6550 global tagbgcolor tagfgcolor tagoutlinecolor
6551 global reflinecolor
6552
6553 set marks {}
6554 set ntags 0
6555 set nheads 0
6556 set singletag 0
6557 set maxtags 3
6558 set maxtagpct 25
6559 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6560 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6561 set extra [expr {$delta + $lthickness + $linespc}]
6562
6563 if {[info exists idtags($id)]} {
6564 set marks $idtags($id)
6565 set ntags [llength $marks]
6566 if {$ntags > $maxtags ||
6567 [totalwidth $marks mainfont $extra] > $maxwidth} {
6568 # show just a single "n tags..." tag
6569 set singletag 1
6570 if {$ntags == 1} {
6571 set marks [list "tag..."]
6572 } else {
6573 set marks [list [format "%d tags..." $ntags]]
6574 }
6575 set ntags 1
6576 }
6577 }
6578 if {[info exists idheads($id)]} {
6579 set marks [concat $marks $idheads($id)]
6580 set nheads [llength $idheads($id)]
6581 }
6582 if {[info exists idotherrefs($id)]} {
6583 set marks [concat $marks $idotherrefs($id)]
6584 }
6585 if {$marks eq {}} {
6586 return $xt
6587 }
6588
6589 set yt [expr {$y1 - 0.5 * $linespc}]
6590 set yb [expr {$yt + $linespc - 1}]
6591 set xvals {}
6592 set wvals {}
6593 set i -1
6594 foreach tag $marks {
6595 incr i
6596 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6597 set wid [font measure mainfontbold $tag]
6598 } else {
6599 set wid [font measure mainfont $tag]
6600 }
6601 lappend xvals $xt
6602 lappend wvals $wid
6603 set xt [expr {$xt + $wid + $extra}]
6604 }
6605 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6606 -width $lthickness -fill $reflinecolor -tags tag.$id]
6607 $canv lower $t
6608 foreach tag $marks x $xvals wid $wvals {
6609 set tag_quoted [string map {% %%} $tag]
6610 set xl [expr {$x + $delta}]
6611 set xr [expr {$x + $delta + $wid + $lthickness}]
6612 set font mainfont
6613 if {[incr ntags -1] >= 0} {
6614 # draw a tag
6615 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6616 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6617 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6618 -tags tag.$id]
6619 if {$singletag} {
6620 set tagclick [list showtags $id 1]
6621 } else {
6622 set tagclick [list showtag $tag_quoted 1]
6623 }
6624 $canv bind $t <1> $tagclick
6625 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6626 } else {
6627 # draw a head or other ref
6628 if {[incr nheads -1] >= 0} {
6629 set col $headbgcolor
6630 if {$tag eq $mainhead} {
6631 set font mainfontbold
6632 }
6633 } else {
6634 set col "#ddddff"
6635 }
6636 set xl [expr {$xl - $delta/2}]
6637 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6638 -width 1 -outline black -fill $col -tags tag.$id
6639 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6640 set rwid [font measure mainfont $remoteprefix]
6641 set xi [expr {$x + 1}]
6642 set yti [expr {$yt + 1}]
6643 set xri [expr {$x + $rwid}]
6644 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6645 -width 0 -fill $remotebgcolor -tags tag.$id
6646 }
6647 }
6648 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6649 -font $font -tags [list tag.$id text]]
6650 if {$ntags >= 0} {
6651 $canv bind $t <1> $tagclick
6652 } elseif {$nheads >= 0} {
6653 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6654 }
6655 }
6656 return $xt
6657}
6658
6659proc drawnotesign {xt y} {
6660 global linespc canv fgcolor
6661
6662 set orad [expr {$linespc / 3}]
6663 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6664 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6665 -fill yellow -outline $fgcolor -width 1 -tags circle]
6666 set xt [expr {$xt + $orad * 3}]
6667 return $xt
6668}
6669
6670proc xcoord {i level ln} {
6671 global canvx0 xspc1 xspc2
6672
6673 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6674 if {$i > 0 && $i == $level} {
6675 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6676 } elseif {$i > $level} {
6677 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6678 }
6679 return $x
6680}
6681
6682proc show_status {msg} {
6683 global canv fgcolor
6684
6685 clear_display
6686 set_window_title
6687 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6688 -tags text -fill $fgcolor
6689}
6690
6691# Don't change the text pane cursor if it is currently the hand cursor,
6692# showing that we are over a sha1 ID link.
6693proc settextcursor {c} {
6694 global ctext curtextcursor
6695
6696 if {[$ctext cget -cursor] == $curtextcursor} {
6697 $ctext config -cursor $c
6698 }
6699 set curtextcursor $c
6700}
6701
6702proc nowbusy {what {name {}}} {
6703 global isbusy busyname statusw
6704
6705 if {[array names isbusy] eq {}} {
6706 . config -cursor watch
6707 settextcursor watch
6708 }
6709 set isbusy($what) 1
6710 set busyname($what) $name
6711 if {$name ne {}} {
6712 $statusw conf -text $name
6713 }
6714}
6715
6716proc notbusy {what} {
6717 global isbusy maincursor textcursor busyname statusw
6718
6719 catch {
6720 unset isbusy($what)
6721 if {$busyname($what) ne {} &&
6722 [$statusw cget -text] eq $busyname($what)} {
6723 $statusw conf -text {}
6724 }
6725 }
6726 if {[array names isbusy] eq {}} {
6727 . config -cursor $maincursor
6728 settextcursor $textcursor
6729 }
6730}
6731
6732proc findmatches {f} {
6733 global findtype findstring
6734 if {$findtype == [mc "Regexp"]} {
6735 set matches [regexp -indices -all -inline $findstring $f]
6736 } else {
6737 set fs $findstring
6738 if {$findtype == [mc "IgnCase"]} {
6739 set f [string tolower $f]
6740 set fs [string tolower $fs]
6741 }
6742 set matches {}
6743 set i 0
6744 set l [string length $fs]
6745 while {[set j [string first $fs $f $i]] >= 0} {
6746 lappend matches [list $j [expr {$j+$l-1}]]
6747 set i [expr {$j + $l}]
6748 }
6749 }
6750 return $matches
6751}
6752
6753proc dofind {{dirn 1} {wrap 1}} {
6754 global findstring findstartline findcurline selectedline numcommits
6755 global gdttype filehighlight fh_serial find_dirn findallowwrap
6756
6757 if {[info exists find_dirn]} {
6758 if {$find_dirn == $dirn} return
6759 stopfinding
6760 }
6761 focus .
6762 if {$findstring eq {} || $numcommits == 0} return
6763 if {$selectedline eq {}} {
6764 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6765 } else {
6766 set findstartline $selectedline
6767 }
6768 set findcurline $findstartline
6769 nowbusy finding [mc "Searching"]
6770 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6771 after cancel do_file_hl $fh_serial
6772 do_file_hl $fh_serial
6773 }
6774 set find_dirn $dirn
6775 set findallowwrap $wrap
6776 run findmore
6777}
6778
6779proc stopfinding {} {
6780 global find_dirn findcurline fprogcoord
6781
6782 if {[info exists find_dirn]} {
6783 unset find_dirn
6784 unset findcurline
6785 notbusy finding
6786 set fprogcoord 0
6787 adjustprogress
6788 }
6789 stopblaming
6790}
6791
6792proc findmore {} {
6793 global commitdata commitinfo numcommits findpattern findloc
6794 global findstartline findcurline findallowwrap
6795 global find_dirn gdttype fhighlights fprogcoord
6796 global curview varcorder vrownum varccommits vrowmod
6797
6798 if {![info exists find_dirn]} {
6799 return 0
6800 }
6801 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6802 set l $findcurline
6803 set moretodo 0
6804 if {$find_dirn > 0} {
6805 incr l
6806 if {$l >= $numcommits} {
6807 set l 0
6808 }
6809 if {$l <= $findstartline} {
6810 set lim [expr {$findstartline + 1}]
6811 } else {
6812 set lim $numcommits
6813 set moretodo $findallowwrap
6814 }
6815 } else {
6816 if {$l == 0} {
6817 set l $numcommits
6818 }
6819 incr l -1
6820 if {$l >= $findstartline} {
6821 set lim [expr {$findstartline - 1}]
6822 } else {
6823 set lim -1
6824 set moretodo $findallowwrap
6825 }
6826 }
6827 set n [expr {($lim - $l) * $find_dirn}]
6828 if {$n > 500} {
6829 set n 500
6830 set moretodo 1
6831 }
6832 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6833 update_arcrows $curview
6834 }
6835 set found 0
6836 set domore 1
6837 set ai [bsearch $vrownum($curview) $l]
6838 set a [lindex $varcorder($curview) $ai]
6839 set arow [lindex $vrownum($curview) $ai]
6840 set ids [lindex $varccommits($curview,$a)]
6841 set arowend [expr {$arow + [llength $ids]}]
6842 if {$gdttype eq [mc "containing:"]} {
6843 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6844 if {$l < $arow || $l >= $arowend} {
6845 incr ai $find_dirn
6846 set a [lindex $varcorder($curview) $ai]
6847 set arow [lindex $vrownum($curview) $ai]
6848 set ids [lindex $varccommits($curview,$a)]
6849 set arowend [expr {$arow + [llength $ids]}]
6850 }
6851 set id [lindex $ids [expr {$l - $arow}]]
6852 # shouldn't happen unless git log doesn't give all the commits...
6853 if {![info exists commitdata($id)] ||
6854 ![doesmatch $commitdata($id)]} {
6855 continue
6856 }
6857 if {![info exists commitinfo($id)]} {
6858 getcommit $id
6859 }
6860 set info $commitinfo($id)
6861 foreach f $info ty $fldtypes {
6862 if {$ty eq ""} continue
6863 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6864 [doesmatch $f]} {
6865 set found 1
6866 break
6867 }
6868 }
6869 if {$found} break
6870 }
6871 } else {
6872 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6873 if {$l < $arow || $l >= $arowend} {
6874 incr ai $find_dirn
6875 set a [lindex $varcorder($curview) $ai]
6876 set arow [lindex $vrownum($curview) $ai]
6877 set ids [lindex $varccommits($curview,$a)]
6878 set arowend [expr {$arow + [llength $ids]}]
6879 }
6880 set id [lindex $ids [expr {$l - $arow}]]
6881 if {![info exists fhighlights($id)]} {
6882 # this sets fhighlights($id) to -1
6883 askfilehighlight $l $id
6884 }
6885 if {$fhighlights($id) > 0} {
6886 set found $domore
6887 break
6888 }
6889 if {$fhighlights($id) < 0} {
6890 if {$domore} {
6891 set domore 0
6892 set findcurline [expr {$l - $find_dirn}]
6893 }
6894 }
6895 }
6896 }
6897 if {$found || ($domore && !$moretodo)} {
6898 unset findcurline
6899 unset find_dirn
6900 notbusy finding
6901 set fprogcoord 0
6902 adjustprogress
6903 if {$found} {
6904 findselectline $l
6905 } else {
6906 bell
6907 }
6908 return 0
6909 }
6910 if {!$domore} {
6911 flushhighlights
6912 } else {
6913 set findcurline [expr {$l - $find_dirn}]
6914 }
6915 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6916 if {$n < 0} {
6917 incr n $numcommits
6918 }
6919 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6920 adjustprogress
6921 return $domore
6922}
6923
6924proc findselectline {l} {
6925 global findloc commentend ctext findcurline markingmatches gdttype
6926
6927 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6928 set findcurline $l
6929 selectline $l 1
6930 if {$markingmatches &&
6931 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6932 # highlight the matches in the comments
6933 set f [$ctext get 1.0 $commentend]
6934 set matches [findmatches $f]
6935 foreach match $matches {
6936 set start [lindex $match 0]
6937 set end [expr {[lindex $match 1] + 1}]
6938 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6939 }
6940 }
6941 drawvisible
6942}
6943
6944# mark the bits of a headline or author that match a find string
6945proc markmatches {canv l str tag matches font row} {
6946 global selectedline
6947
6948 set bbox [$canv bbox $tag]
6949 set x0 [lindex $bbox 0]
6950 set y0 [lindex $bbox 1]
6951 set y1 [lindex $bbox 3]
6952 foreach match $matches {
6953 set start [lindex $match 0]
6954 set end [lindex $match 1]
6955 if {$start > $end} continue
6956 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6957 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6958 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6959 [expr {$x0+$xlen+2}] $y1 \
6960 -outline {} -tags [list match$l matches] -fill yellow]
6961 $canv lower $t
6962 if {$row == $selectedline} {
6963 $canv raise $t secsel
6964 }
6965 }
6966}
6967
6968proc unmarkmatches {} {
6969 global markingmatches
6970
6971 allcanvs delete matches
6972 set markingmatches 0
6973 stopfinding
6974}
6975
6976proc selcanvline {w x y} {
6977 global canv canvy0 ctext linespc
6978 global rowtextx
6979 set ymax [lindex [$canv cget -scrollregion] 3]
6980 if {$ymax == {}} return
6981 set yfrac [lindex [$canv yview] 0]
6982 set y [expr {$y + $yfrac * $ymax}]
6983 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6984 if {$l < 0} {
6985 set l 0
6986 }
6987 if {$w eq $canv} {
6988 set xmax [lindex [$canv cget -scrollregion] 2]
6989 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6990 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6991 }
6992 unmarkmatches
6993 selectline $l 1
6994}
6995
6996proc commit_descriptor {p} {
6997 global commitinfo
6998 if {![info exists commitinfo($p)]} {
6999 getcommit $p
7000 }
7001 set l "..."
7002 if {[llength $commitinfo($p)] > 1} {
7003 set l [lindex $commitinfo($p) 0]
7004 }
7005 return "$p ($l)\n"
7006}
7007
7008# append some text to the ctext widget, and make any SHA1 ID
7009# that we know about be a clickable link.
7010proc appendwithlinks {text tags} {
7011 global ctext linknum curview
7012
7013 set start [$ctext index "end - 1c"]
7014 $ctext insert end $text $tags
7015 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7016 foreach l $links {
7017 set s [lindex $l 0]
7018 set e [lindex $l 1]
7019 set linkid [string range $text $s $e]
7020 incr e
7021 $ctext tag delete link$linknum
7022 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7023 setlink $linkid link$linknum
7024 incr linknum
7025 }
7026}
7027
7028proc setlink {id lk} {
7029 global curview ctext pendinglinks
7030 global linkfgcolor
7031
7032 if {[string range $id 0 1] eq "-g"} {
7033 set id [string range $id 2 end]
7034 }
7035
7036 set known 0
7037 if {[string length $id] < 40} {
7038 set matches [longid $id]
7039 if {[llength $matches] > 0} {
7040 if {[llength $matches] > 1} return
7041 set known 1
7042 set id [lindex $matches 0]
7043 }
7044 } else {
7045 set known [commitinview $id $curview]
7046 }
7047 if {$known} {
7048 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7049 $ctext tag bind $lk <1> [list selbyid $id]
7050 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7051 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7052 } else {
7053 lappend pendinglinks($id) $lk
7054 interestedin $id {makelink %P}
7055 }
7056}
7057
7058proc appendshortlink {id {pre {}} {post {}}} {
7059 global ctext linknum
7060
7061 $ctext insert end $pre
7062 $ctext tag delete link$linknum
7063 $ctext insert end [string range $id 0 7] link$linknum
7064 $ctext insert end $post
7065 setlink $id link$linknum
7066 incr linknum
7067}
7068
7069proc makelink {id} {
7070 global pendinglinks
7071
7072 if {![info exists pendinglinks($id)]} return
7073 foreach lk $pendinglinks($id) {
7074 setlink $id $lk
7075 }
7076 unset pendinglinks($id)
7077}
7078
7079proc linkcursor {w inc} {
7080 global linkentercount curtextcursor
7081
7082 if {[incr linkentercount $inc] > 0} {
7083 $w configure -cursor hand2
7084 } else {
7085 $w configure -cursor $curtextcursor
7086 if {$linkentercount < 0} {
7087 set linkentercount 0
7088 }
7089 }
7090}
7091
7092proc viewnextline {dir} {
7093 global canv linespc
7094
7095 $canv delete hover
7096 set ymax [lindex [$canv cget -scrollregion] 3]
7097 set wnow [$canv yview]
7098 set wtop [expr {[lindex $wnow 0] * $ymax}]
7099 set newtop [expr {$wtop + $dir * $linespc}]
7100 if {$newtop < 0} {
7101 set newtop 0
7102 } elseif {$newtop > $ymax} {
7103 set newtop $ymax
7104 }
7105 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7106}
7107
7108# add a list of tag or branch names at position pos
7109# returns the number of names inserted
7110proc appendrefs {pos ids var} {
7111 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7112
7113 if {[catch {$ctext index $pos}]} {
7114 return 0
7115 }
7116 $ctext conf -state normal
7117 $ctext delete $pos "$pos lineend"
7118 set tags {}
7119 foreach id $ids {
7120 foreach tag [set $var\($id\)] {
7121 lappend tags [list $tag $id]
7122 }
7123 }
7124
7125 set sep {}
7126 set tags [lsort -index 0 -decreasing $tags]
7127 set nutags 0
7128
7129 if {[llength $tags] > $maxrefs} {
7130 # If we are displaying heads, and there are too many,
7131 # see if there are some important heads to display.
7132 # Currently that are the current head and heads listed in $visiblerefs option
7133 set itags {}
7134 if {$var eq "idheads"} {
7135 set utags {}
7136 foreach ti $tags {
7137 set hname [lindex $ti 0]
7138 set id [lindex $ti 1]
7139 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7140 [llength $itags] < $maxrefs} {
7141 lappend itags $ti
7142 } else {
7143 lappend utags $ti
7144 }
7145 }
7146 set tags $utags
7147 }
7148 if {$itags ne {}} {
7149 set str [mc "and many more"]
7150 set sep " "
7151 } else {
7152 set str [mc "many"]
7153 }
7154 $ctext insert $pos "$str ([llength $tags])"
7155 set nutags [llength $tags]
7156 set tags $itags
7157 }
7158
7159 foreach ti $tags {
7160 set id [lindex $ti 1]
7161 set lk link$linknum
7162 incr linknum
7163 $ctext tag delete $lk
7164 $ctext insert $pos $sep
7165 $ctext insert $pos [lindex $ti 0] $lk
7166 setlink $id $lk
7167 set sep ", "
7168 }
7169 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7170 $ctext conf -state disabled
7171 return [expr {[llength $tags] + $nutags}]
7172}
7173
7174# called when we have finished computing the nearby tags
7175proc dispneartags {delay} {
7176 global selectedline currentid showneartags tagphase
7177
7178 if {$selectedline eq {} || !$showneartags} return
7179 after cancel dispnexttag
7180 if {$delay} {
7181 after 200 dispnexttag
7182 set tagphase -1
7183 } else {
7184 after idle dispnexttag
7185 set tagphase 0
7186 }
7187}
7188
7189proc dispnexttag {} {
7190 global selectedline currentid showneartags tagphase ctext
7191
7192 if {$selectedline eq {} || !$showneartags} return
7193 switch -- $tagphase {
7194 0 {
7195 set dtags [desctags $currentid]
7196 if {$dtags ne {}} {
7197 appendrefs precedes $dtags idtags
7198 }
7199 }
7200 1 {
7201 set atags [anctags $currentid]
7202 if {$atags ne {}} {
7203 appendrefs follows $atags idtags
7204 }
7205 }
7206 2 {
7207 set dheads [descheads $currentid]
7208 if {$dheads ne {}} {
7209 if {[appendrefs branch $dheads idheads] > 1
7210 && [$ctext get "branch -3c"] eq "h"} {
7211 # turn "Branch" into "Branches"
7212 $ctext conf -state normal
7213 $ctext insert "branch -2c" "es"
7214 $ctext conf -state disabled
7215 }
7216 }
7217 }
7218 }
7219 if {[incr tagphase] <= 2} {
7220 after idle dispnexttag
7221 }
7222}
7223
7224proc make_secsel {id} {
7225 global linehtag linentag linedtag canv canv2 canv3
7226
7227 if {![info exists linehtag($id)]} return
7228 $canv delete secsel
7229 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7230 -tags secsel -fill [$canv cget -selectbackground]]
7231 $canv lower $t
7232 $canv2 delete secsel
7233 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7234 -tags secsel -fill [$canv2 cget -selectbackground]]
7235 $canv2 lower $t
7236 $canv3 delete secsel
7237 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7238 -tags secsel -fill [$canv3 cget -selectbackground]]
7239 $canv3 lower $t
7240}
7241
7242proc make_idmark {id} {
7243 global linehtag canv fgcolor
7244
7245 if {![info exists linehtag($id)]} return
7246 $canv delete markid
7247 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7248 -tags markid -outline $fgcolor]
7249 $canv raise $t
7250}
7251
7252proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7253 global canv ctext commitinfo selectedline
7254 global canvy0 linespc parents children curview
7255 global currentid sha1entry
7256 global commentend idtags linknum
7257 global mergemax numcommits pending_select
7258 global cmitmode showneartags allcommits
7259 global targetrow targetid lastscrollrows
7260 global autoselect autosellen jump_to_here
7261 global vinlinediff
7262
7263 unset -nocomplain pending_select
7264 $canv delete hover
7265 normalline
7266 unsel_reflist
7267 stopfinding
7268 if {$l < 0 || $l >= $numcommits} return
7269 set id [commitonrow $l]
7270 set targetid $id
7271 set targetrow $l
7272 set selectedline $l
7273 set currentid $id
7274 if {$lastscrollrows < $numcommits} {
7275 setcanvscroll
7276 }
7277
7278 if {$cmitmode ne "patch" && $switch_to_patch} {
7279 set cmitmode "patch"
7280 }
7281
7282 set y [expr {$canvy0 + $l * $linespc}]
7283 set ymax [lindex [$canv cget -scrollregion] 3]
7284 set ytop [expr {$y - $linespc - 1}]
7285 set ybot [expr {$y + $linespc + 1}]
7286 set wnow [$canv yview]
7287 set wtop [expr {[lindex $wnow 0] * $ymax}]
7288 set wbot [expr {[lindex $wnow 1] * $ymax}]
7289 set wh [expr {$wbot - $wtop}]
7290 set newtop $wtop
7291 if {$ytop < $wtop} {
7292 if {$ybot < $wtop} {
7293 set newtop [expr {$y - $wh / 2.0}]
7294 } else {
7295 set newtop $ytop
7296 if {$newtop > $wtop - $linespc} {
7297 set newtop [expr {$wtop - $linespc}]
7298 }
7299 }
7300 } elseif {$ybot > $wbot} {
7301 if {$ytop > $wbot} {
7302 set newtop [expr {$y - $wh / 2.0}]
7303 } else {
7304 set newtop [expr {$ybot - $wh}]
7305 if {$newtop < $wtop + $linespc} {
7306 set newtop [expr {$wtop + $linespc}]
7307 }
7308 }
7309 }
7310 if {$newtop != $wtop} {
7311 if {$newtop < 0} {
7312 set newtop 0
7313 }
7314 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7315 drawvisible
7316 }
7317
7318 make_secsel $id
7319
7320 if {$isnew} {
7321 addtohistory [list selbyid $id 0] savecmitpos
7322 }
7323
7324 $sha1entry delete 0 end
7325 $sha1entry insert 0 $id
7326 if {$autoselect} {
7327 $sha1entry selection range 0 $autosellen
7328 }
7329 rhighlight_sel $id
7330
7331 $ctext conf -state normal
7332 clear_ctext
7333 set linknum 0
7334 if {![info exists commitinfo($id)]} {
7335 getcommit $id
7336 }
7337 set info $commitinfo($id)
7338 set date [formatdate [lindex $info 2]]
7339 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7340 set date [formatdate [lindex $info 4]]
7341 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7342 if {[info exists idtags($id)]} {
7343 $ctext insert end [mc "Tags:"]
7344 foreach tag $idtags($id) {
7345 $ctext insert end " $tag"
7346 }
7347 $ctext insert end "\n"
7348 }
7349
7350 set headers {}
7351 set olds $parents($curview,$id)
7352 if {[llength $olds] > 1} {
7353 set np 0
7354 foreach p $olds {
7355 if {$np >= $mergemax} {
7356 set tag mmax
7357 } else {
7358 set tag m$np
7359 }
7360 $ctext insert end "[mc "Parent"]: " $tag
7361 appendwithlinks [commit_descriptor $p] {}
7362 incr np
7363 }
7364 } else {
7365 foreach p $olds {
7366 append headers "[mc "Parent"]: [commit_descriptor $p]"
7367 }
7368 }
7369
7370 foreach c $children($curview,$id) {
7371 append headers "[mc "Child"]: [commit_descriptor $c]"
7372 }
7373
7374 # make anything that looks like a SHA1 ID be a clickable link
7375 appendwithlinks $headers {}
7376 if {$showneartags} {
7377 if {![info exists allcommits]} {
7378 getallcommits
7379 }
7380 $ctext insert end "[mc "Branch"]: "
7381 $ctext mark set branch "end -1c"
7382 $ctext mark gravity branch left
7383 $ctext insert end "\n[mc "Follows"]: "
7384 $ctext mark set follows "end -1c"
7385 $ctext mark gravity follows left
7386 $ctext insert end "\n[mc "Precedes"]: "
7387 $ctext mark set precedes "end -1c"
7388 $ctext mark gravity precedes left
7389 $ctext insert end "\n"
7390 dispneartags 1
7391 }
7392 $ctext insert end "\n"
7393 set comment [lindex $info 5]
7394 if {[string first "\r" $comment] >= 0} {
7395 set comment [string map {"\r" "\n "} $comment]
7396 }
7397 appendwithlinks $comment {comment}
7398
7399 $ctext tag remove found 1.0 end
7400 $ctext conf -state disabled
7401 set commentend [$ctext index "end - 1c"]
7402
7403 set jump_to_here $desired_loc
7404 init_flist [mc "Comments"]
7405 if {$cmitmode eq "tree"} {
7406 gettree $id
7407 } elseif {$vinlinediff($curview) == 1} {
7408 showinlinediff $id
7409 } elseif {[llength $olds] <= 1} {
7410 startdiff $id
7411 } else {
7412 mergediff $id
7413 }
7414}
7415
7416proc selfirstline {} {
7417 unmarkmatches
7418 selectline 0 1
7419}
7420
7421proc sellastline {} {
7422 global numcommits
7423 unmarkmatches
7424 set l [expr {$numcommits - 1}]
7425 selectline $l 1
7426}
7427
7428proc selnextline {dir} {
7429 global selectedline
7430 focus .
7431 if {$selectedline eq {}} return
7432 set l [expr {$selectedline + $dir}]
7433 unmarkmatches
7434 selectline $l 1
7435}
7436
7437proc selnextpage {dir} {
7438 global canv linespc selectedline numcommits
7439
7440 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7441 if {$lpp < 1} {
7442 set lpp 1
7443 }
7444 allcanvs yview scroll [expr {$dir * $lpp}] units
7445 drawvisible
7446 if {$selectedline eq {}} return
7447 set l [expr {$selectedline + $dir * $lpp}]
7448 if {$l < 0} {
7449 set l 0
7450 } elseif {$l >= $numcommits} {
7451 set l [expr $numcommits - 1]
7452 }
7453 unmarkmatches
7454 selectline $l 1
7455}
7456
7457proc unselectline {} {
7458 global selectedline currentid
7459
7460 set selectedline {}
7461 unset -nocomplain currentid
7462 allcanvs delete secsel
7463 rhighlight_none
7464}
7465
7466proc reselectline {} {
7467 global selectedline
7468
7469 if {$selectedline ne {}} {
7470 selectline $selectedline 0
7471 }
7472}
7473
7474proc addtohistory {cmd {saveproc {}}} {
7475 global history historyindex curview
7476
7477 unset_posvars
7478 save_position
7479 set elt [list $curview $cmd $saveproc {}]
7480 if {$historyindex > 0
7481 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7482 return
7483 }
7484
7485 if {$historyindex < [llength $history]} {
7486 set history [lreplace $history $historyindex end $elt]
7487 } else {
7488 lappend history $elt
7489 }
7490 incr historyindex
7491 if {$historyindex > 1} {
7492 .tf.bar.leftbut conf -state normal
7493 } else {
7494 .tf.bar.leftbut conf -state disabled
7495 }
7496 .tf.bar.rightbut conf -state disabled
7497}
7498
7499# save the scrolling position of the diff display pane
7500proc save_position {} {
7501 global historyindex history
7502
7503 if {$historyindex < 1} return
7504 set hi [expr {$historyindex - 1}]
7505 set fn [lindex $history $hi 2]
7506 if {$fn ne {}} {
7507 lset history $hi 3 [eval $fn]
7508 }
7509}
7510
7511proc unset_posvars {} {
7512 global last_posvars
7513
7514 if {[info exists last_posvars]} {
7515 foreach {var val} $last_posvars {
7516 global $var
7517 unset -nocomplain $var
7518 }
7519 unset last_posvars
7520 }
7521}
7522
7523proc godo {elt} {
7524 global curview last_posvars
7525
7526 set view [lindex $elt 0]
7527 set cmd [lindex $elt 1]
7528 set pv [lindex $elt 3]
7529 if {$curview != $view} {
7530 showview $view
7531 }
7532 unset_posvars
7533 foreach {var val} $pv {
7534 global $var
7535 set $var $val
7536 }
7537 set last_posvars $pv
7538 eval $cmd
7539}
7540
7541proc goback {} {
7542 global history historyindex
7543 focus .
7544
7545 if {$historyindex > 1} {
7546 save_position
7547 incr historyindex -1
7548 godo [lindex $history [expr {$historyindex - 1}]]
7549 .tf.bar.rightbut conf -state normal
7550 }
7551 if {$historyindex <= 1} {
7552 .tf.bar.leftbut conf -state disabled
7553 }
7554}
7555
7556proc goforw {} {
7557 global history historyindex
7558 focus .
7559
7560 if {$historyindex < [llength $history]} {
7561 save_position
7562 set cmd [lindex $history $historyindex]
7563 incr historyindex
7564 godo $cmd
7565 .tf.bar.leftbut conf -state normal
7566 }
7567 if {$historyindex >= [llength $history]} {
7568 .tf.bar.rightbut conf -state disabled
7569 }
7570}
7571
7572proc go_to_parent {i} {
7573 global parents curview targetid
7574 set ps $parents($curview,$targetid)
7575 if {[llength $ps] >= $i} {
7576 selbyid [lindex $ps [expr $i - 1]]
7577 }
7578}
7579
7580proc gettree {id} {
7581 global treefilelist treeidlist diffids diffmergeid treepending
7582 global nullid nullid2
7583
7584 set diffids $id
7585 unset -nocomplain diffmergeid
7586 if {![info exists treefilelist($id)]} {
7587 if {![info exists treepending]} {
7588 if {$id eq $nullid} {
7589 set cmd [list | git ls-files]
7590 } elseif {$id eq $nullid2} {
7591 set cmd [list | git ls-files --stage -t]
7592 } else {
7593 set cmd [list | git ls-tree -r $id]
7594 }
7595 if {[catch {set gtf [open $cmd r]}]} {
7596 return
7597 }
7598 set treepending $id
7599 set treefilelist($id) {}
7600 set treeidlist($id) {}
7601 fconfigure $gtf -blocking 0 -encoding binary
7602 filerun $gtf [list gettreeline $gtf $id]
7603 }
7604 } else {
7605 setfilelist $id
7606 }
7607}
7608
7609proc gettreeline {gtf id} {
7610 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7611
7612 set nl 0
7613 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7614 if {$diffids eq $nullid} {
7615 set fname $line
7616 } else {
7617 set i [string first "\t" $line]
7618 if {$i < 0} continue
7619 set fname [string range $line [expr {$i+1}] end]
7620 set line [string range $line 0 [expr {$i-1}]]
7621 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7622 set sha1 [lindex $line 2]
7623 lappend treeidlist($id) $sha1
7624 }
7625 if {[string index $fname 0] eq "\""} {
7626 set fname [lindex $fname 0]
7627 }
7628 set fname [encoding convertfrom $fname]
7629 lappend treefilelist($id) $fname
7630 }
7631 if {![eof $gtf]} {
7632 return [expr {$nl >= 1000? 2: 1}]
7633 }
7634 close $gtf
7635 unset treepending
7636 if {$cmitmode ne "tree"} {
7637 if {![info exists diffmergeid]} {
7638 gettreediffs $diffids
7639 }
7640 } elseif {$id ne $diffids} {
7641 gettree $diffids
7642 } else {
7643 setfilelist $id
7644 }
7645 return 0
7646}
7647
7648proc showfile {f} {
7649 global treefilelist treeidlist diffids nullid nullid2
7650 global ctext_file_names ctext_file_lines
7651 global ctext commentend
7652
7653 set i [lsearch -exact $treefilelist($diffids) $f]
7654 if {$i < 0} {
7655 puts "oops, $f not in list for id $diffids"
7656 return
7657 }
7658 if {$diffids eq $nullid} {
7659 if {[catch {set bf [open $f r]} err]} {
7660 puts "oops, can't read $f: $err"
7661 return
7662 }
7663 } else {
7664 set blob [lindex $treeidlist($diffids) $i]
7665 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7666 puts "oops, error reading blob $blob: $err"
7667 return
7668 }
7669 }
7670 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7671 filerun $bf [list getblobline $bf $diffids]
7672 $ctext config -state normal
7673 clear_ctext $commentend
7674 lappend ctext_file_names $f
7675 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7676 $ctext insert end "\n"
7677 $ctext insert end "$f\n" filesep
7678 $ctext config -state disabled
7679 $ctext yview $commentend
7680 settabs 0
7681}
7682
7683proc getblobline {bf id} {
7684 global diffids cmitmode ctext
7685
7686 if {$id ne $diffids || $cmitmode ne "tree"} {
7687 catch {close $bf}
7688 return 0
7689 }
7690 $ctext config -state normal
7691 set nl 0
7692 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7693 $ctext insert end "$line\n"
7694 }
7695 if {[eof $bf]} {
7696 global jump_to_here ctext_file_names commentend
7697
7698 # delete last newline
7699 $ctext delete "end - 2c" "end - 1c"
7700 close $bf
7701 if {$jump_to_here ne {} &&
7702 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7703 set lnum [expr {[lindex $jump_to_here 1] +
7704 [lindex [split $commentend .] 0]}]
7705 mark_ctext_line $lnum
7706 }
7707 $ctext config -state disabled
7708 return 0
7709 }
7710 $ctext config -state disabled
7711 return [expr {$nl >= 1000? 2: 1}]
7712}
7713
7714proc mark_ctext_line {lnum} {
7715 global ctext markbgcolor
7716
7717 $ctext tag delete omark
7718 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7719 $ctext tag conf omark -background $markbgcolor
7720 $ctext see $lnum.0
7721}
7722
7723proc mergediff {id} {
7724 global diffmergeid
7725 global diffids treediffs
7726 global parents curview
7727
7728 set diffmergeid $id
7729 set diffids $id
7730 set treediffs($id) {}
7731 set np [llength $parents($curview,$id)]
7732 settabs $np
7733 getblobdiffs $id
7734}
7735
7736proc startdiff {ids} {
7737 global treediffs diffids treepending diffmergeid nullid nullid2
7738
7739 settabs 1
7740 set diffids $ids
7741 unset -nocomplain diffmergeid
7742 if {![info exists treediffs($ids)] ||
7743 [lsearch -exact $ids $nullid] >= 0 ||
7744 [lsearch -exact $ids $nullid2] >= 0} {
7745 if {![info exists treepending]} {
7746 gettreediffs $ids
7747 }
7748 } else {
7749 addtocflist $ids
7750 }
7751}
7752
7753proc showinlinediff {ids} {
7754 global commitinfo commitdata ctext
7755 global treediffs
7756
7757 set info $commitinfo($ids)
7758 set diff [lindex $info 7]
7759 set difflines [split $diff "\n"]
7760
7761 initblobdiffvars
7762 set treediff {}
7763
7764 set inhdr 0
7765 foreach line $difflines {
7766 if {![string compare -length 5 "diff " $line]} {
7767 set inhdr 1
7768 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7769 # offset also accounts for the b/ prefix
7770 lappend treediff [string range $line 6 end]
7771 set inhdr 0
7772 }
7773 }
7774
7775 set treediffs($ids) $treediff
7776 add_flist $treediff
7777
7778 $ctext conf -state normal
7779 foreach line $difflines {
7780 parseblobdiffline $ids $line
7781 }
7782 maybe_scroll_ctext 1
7783 $ctext conf -state disabled
7784}
7785
7786# If the filename (name) is under any of the passed filter paths
7787# then return true to include the file in the listing.
7788proc path_filter {filter name} {
7789 set worktree [gitworktree]
7790 foreach p $filter {
7791 set fq_p [file normalize $p]
7792 set fq_n [file normalize [file join $worktree $name]]
7793 if {[string match [file normalize $fq_p]* $fq_n]} {
7794 return 1
7795 }
7796 }
7797 return 0
7798}
7799
7800proc addtocflist {ids} {
7801 global treediffs
7802
7803 add_flist $treediffs($ids)
7804 getblobdiffs $ids
7805}
7806
7807proc diffcmd {ids flags} {
7808 global log_showroot nullid nullid2 git_version
7809
7810 set i [lsearch -exact $ids $nullid]
7811 set j [lsearch -exact $ids $nullid2]
7812 if {$i >= 0} {
7813 if {[llength $ids] > 1 && $j < 0} {
7814 # comparing working directory with some specific revision
7815 set cmd [concat | git diff-index $flags]
7816 if {$i == 0} {
7817 lappend cmd -R [lindex $ids 1]
7818 } else {
7819 lappend cmd [lindex $ids 0]
7820 }
7821 } else {
7822 # comparing working directory with index
7823 set cmd [concat | git diff-files $flags]
7824 if {$j == 1} {
7825 lappend cmd -R
7826 }
7827 }
7828 } elseif {$j >= 0} {
7829 if {[package vcompare $git_version "1.7.2"] >= 0} {
7830 set flags "$flags --ignore-submodules=dirty"
7831 }
7832 set cmd [concat | git diff-index --cached $flags]
7833 if {[llength $ids] > 1} {
7834 # comparing index with specific revision
7835 if {$j == 0} {
7836 lappend cmd -R [lindex $ids 1]
7837 } else {
7838 lappend cmd [lindex $ids 0]
7839 }
7840 } else {
7841 # comparing index with HEAD
7842 lappend cmd HEAD
7843 }
7844 } else {
7845 if {$log_showroot} {
7846 lappend flags --root
7847 }
7848 set cmd [concat | git diff-tree -r $flags $ids]
7849 }
7850 return $cmd
7851}
7852
7853proc gettreediffs {ids} {
7854 global treediff treepending limitdiffs vfilelimit curview
7855
7856 set cmd [diffcmd $ids {--no-commit-id}]
7857 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7858 set cmd [concat $cmd -- $vfilelimit($curview)]
7859 }
7860 if {[catch {set gdtf [open $cmd r]}]} return
7861
7862 set treepending $ids
7863 set treediff {}
7864 fconfigure $gdtf -blocking 0 -encoding binary
7865 filerun $gdtf [list gettreediffline $gdtf $ids]
7866}
7867
7868proc gettreediffline {gdtf ids} {
7869 global treediff treediffs treepending diffids diffmergeid
7870 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7871
7872 set nr 0
7873 set sublist {}
7874 set max 1000
7875 if {$perfile_attrs} {
7876 # cache_gitattr is slow, and even slower on win32 where we
7877 # have to invoke it for only about 30 paths at a time
7878 set max 500
7879 if {[tk windowingsystem] == "win32"} {
7880 set max 120
7881 }
7882 }
7883 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7884 set i [string first "\t" $line]
7885 if {$i >= 0} {
7886 set file [string range $line [expr {$i+1}] end]
7887 if {[string index $file 0] eq "\""} {
7888 set file [lindex $file 0]
7889 }
7890 set file [encoding convertfrom $file]
7891 if {$file ne [lindex $treediff end]} {
7892 lappend treediff $file
7893 lappend sublist $file
7894 }
7895 }
7896 }
7897 if {$perfile_attrs} {
7898 cache_gitattr encoding $sublist
7899 }
7900 if {![eof $gdtf]} {
7901 return [expr {$nr >= $max? 2: 1}]
7902 }
7903 close $gdtf
7904 set treediffs($ids) $treediff
7905 unset treepending
7906 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7907 gettree $diffids
7908 } elseif {$ids != $diffids} {
7909 if {![info exists diffmergeid]} {
7910 gettreediffs $diffids
7911 }
7912 } else {
7913 addtocflist $ids
7914 }
7915 return 0
7916}
7917
7918# empty string or positive integer
7919proc diffcontextvalidate {v} {
7920 return [regexp {^(|[1-9][0-9]*)$} $v]
7921}
7922
7923proc diffcontextchange {n1 n2 op} {
7924 global diffcontextstring diffcontext
7925
7926 if {[string is integer -strict $diffcontextstring]} {
7927 if {$diffcontextstring >= 0} {
7928 set diffcontext $diffcontextstring
7929 reselectline
7930 }
7931 }
7932}
7933
7934proc changeignorespace {} {
7935 reselectline
7936}
7937
7938proc changeworddiff {name ix op} {
7939 reselectline
7940}
7941
7942proc initblobdiffvars {} {
7943 global diffencoding targetline diffnparents
7944 global diffinhdr currdiffsubmod diffseehere
7945 set targetline {}
7946 set diffnparents 0
7947 set diffinhdr 0
7948 set diffencoding [get_path_encoding {}]
7949 set currdiffsubmod ""
7950 set diffseehere -1
7951}
7952
7953proc getblobdiffs {ids} {
7954 global blobdifffd diffids env
7955 global treediffs
7956 global diffcontext
7957 global ignorespace
7958 global worddiff
7959 global limitdiffs vfilelimit curview
7960 global git_version
7961
7962 set textconv {}
7963 if {[package vcompare $git_version "1.6.1"] >= 0} {
7964 set textconv "--textconv"
7965 }
7966 set submodule {}
7967 if {[package vcompare $git_version "1.6.6"] >= 0} {
7968 set submodule "--submodule"
7969 }
7970 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7971 if {$ignorespace} {
7972 append cmd " -w"
7973 }
7974 if {$worddiff ne [mc "Line diff"]} {
7975 append cmd " --word-diff=porcelain"
7976 }
7977 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7978 set cmd [concat $cmd -- $vfilelimit($curview)]
7979 }
7980 if {[catch {set bdf [open $cmd r]} err]} {
7981 error_popup [mc "Error getting diffs: %s" $err]
7982 return
7983 }
7984 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7985 set blobdifffd($ids) $bdf
7986 initblobdiffvars
7987 filerun $bdf [list getblobdiffline $bdf $diffids]
7988}
7989
7990proc savecmitpos {} {
7991 global ctext cmitmode
7992
7993 if {$cmitmode eq "tree"} {
7994 return {}
7995 }
7996 return [list target_scrollpos [$ctext index @0,0]]
7997}
7998
7999proc savectextpos {} {
8000 global ctext
8001
8002 return [list target_scrollpos [$ctext index @0,0]]
8003}
8004
8005proc maybe_scroll_ctext {ateof} {
8006 global ctext target_scrollpos
8007
8008 if {![info exists target_scrollpos]} return
8009 if {!$ateof} {
8010 set nlines [expr {[winfo height $ctext]
8011 / [font metrics textfont -linespace]}]
8012 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8013 }
8014 $ctext yview $target_scrollpos
8015 unset target_scrollpos
8016}
8017
8018proc setinlist {var i val} {
8019 global $var
8020
8021 while {[llength [set $var]] < $i} {
8022 lappend $var {}
8023 }
8024 if {[llength [set $var]] == $i} {
8025 lappend $var $val
8026 } else {
8027 lset $var $i $val
8028 }
8029}
8030
8031proc makediffhdr {fname ids} {
8032 global ctext curdiffstart treediffs diffencoding
8033 global ctext_file_names jump_to_here targetline diffline
8034
8035 set fname [encoding convertfrom $fname]
8036 set diffencoding [get_path_encoding $fname]
8037 set i [lsearch -exact $treediffs($ids) $fname]
8038 if {$i >= 0} {
8039 setinlist difffilestart $i $curdiffstart
8040 }
8041 lset ctext_file_names end $fname
8042 set l [expr {(78 - [string length $fname]) / 2}]
8043 set pad [string range "----------------------------------------" 1 $l]
8044 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8045 set targetline {}
8046 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8047 set targetline [lindex $jump_to_here 1]
8048 }
8049 set diffline 0
8050}
8051
8052proc blobdiffmaybeseehere {ateof} {
8053 global diffseehere
8054 if {$diffseehere >= 0} {
8055 mark_ctext_line [lindex [split $diffseehere .] 0]
8056 }
8057 maybe_scroll_ctext $ateof
8058}
8059
8060proc getblobdiffline {bdf ids} {
8061 global diffids blobdifffd
8062 global ctext
8063
8064 set nr 0
8065 $ctext conf -state normal
8066 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8067 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8068 catch {close $bdf}
8069 return 0
8070 }
8071 parseblobdiffline $ids $line
8072 }
8073 $ctext conf -state disabled
8074 blobdiffmaybeseehere [eof $bdf]
8075 if {[eof $bdf]} {
8076 catch {close $bdf}
8077 return 0
8078 }
8079 return [expr {$nr >= 1000? 2: 1}]
8080}
8081
8082proc parseblobdiffline {ids line} {
8083 global ctext curdiffstart
8084 global diffnexthead diffnextnote difffilestart
8085 global ctext_file_names ctext_file_lines
8086 global diffinhdr treediffs mergemax diffnparents
8087 global diffencoding jump_to_here targetline diffline currdiffsubmod
8088 global worddiff diffseehere
8089
8090 if {![string compare -length 5 "diff " $line]} {
8091 if {![regexp {^diff (--cc|--git) } $line m type]} {
8092 set line [encoding convertfrom $line]
8093 $ctext insert end "$line\n" hunksep
8094 continue
8095 }
8096 # start of a new file
8097 set diffinhdr 1
8098 $ctext insert end "\n"
8099 set curdiffstart [$ctext index "end - 1c"]
8100 lappend ctext_file_names ""
8101 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8102 $ctext insert end "\n" filesep
8103
8104 if {$type eq "--cc"} {
8105 # start of a new file in a merge diff
8106 set fname [string range $line 10 end]
8107 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8108 lappend treediffs($ids) $fname
8109 add_flist [list $fname]
8110 }
8111
8112 } else {
8113 set line [string range $line 11 end]
8114 # If the name hasn't changed the length will be odd,
8115 # the middle char will be a space, and the two bits either
8116 # side will be a/name and b/name, or "a/name" and "b/name".
8117 # If the name has changed we'll get "rename from" and
8118 # "rename to" or "copy from" and "copy to" lines following
8119 # this, and we'll use them to get the filenames.
8120 # This complexity is necessary because spaces in the
8121 # filename(s) don't get escaped.
8122 set l [string length $line]
8123 set i [expr {$l / 2}]
8124 if {!(($l & 1) && [string index $line $i] eq " " &&
8125 [string range $line 2 [expr {$i - 1}]] eq \
8126 [string range $line [expr {$i + 3}] end])} {
8127 return
8128 }
8129 # unescape if quoted and chop off the a/ from the front
8130 if {[string index $line 0] eq "\""} {
8131 set fname [string range [lindex $line 0] 2 end]
8132 } else {
8133 set fname [string range $line 2 [expr {$i - 1}]]
8134 }
8135 }
8136 makediffhdr $fname $ids
8137
8138 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8139 set fname [encoding convertfrom [string range $line 16 end]]
8140 $ctext insert end "\n"
8141 set curdiffstart [$ctext index "end - 1c"]
8142 lappend ctext_file_names $fname
8143 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8144 $ctext insert end "$line\n" filesep
8145 set i [lsearch -exact $treediffs($ids) $fname]
8146 if {$i >= 0} {
8147 setinlist difffilestart $i $curdiffstart
8148 }
8149
8150 } elseif {![string compare -length 2 "@@" $line]} {
8151 regexp {^@@+} $line ats
8152 set line [encoding convertfrom $diffencoding $line]
8153 $ctext insert end "$line\n" hunksep
8154 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8155 set diffline $nl
8156 }
8157 set diffnparents [expr {[string length $ats] - 1}]
8158 set diffinhdr 0
8159
8160 } elseif {![string compare -length 10 "Submodule " $line]} {
8161 # start of a new submodule
8162 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8163 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8164 } else {
8165 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8166 }
8167 if {$currdiffsubmod != $fname} {
8168 $ctext insert end "\n"; # Add newline after commit message
8169 }
8170 set curdiffstart [$ctext index "end - 1c"]
8171 lappend ctext_file_names ""
8172 if {$currdiffsubmod != $fname} {
8173 lappend ctext_file_lines $fname
8174 makediffhdr $fname $ids
8175 set currdiffsubmod $fname
8176 $ctext insert end "\n$line\n" filesep
8177 } else {
8178 $ctext insert end "$line\n" filesep
8179 }
8180 } elseif {![string compare -length 3 " >" $line]} {
8181 set $currdiffsubmod ""
8182 set line [encoding convertfrom $diffencoding $line]
8183 $ctext insert end "$line\n" dresult
8184 } elseif {![string compare -length 3 " <" $line]} {
8185 set $currdiffsubmod ""
8186 set line [encoding convertfrom $diffencoding $line]
8187 $ctext insert end "$line\n" d0
8188 } elseif {$diffinhdr} {
8189 if {![string compare -length 12 "rename from " $line]} {
8190 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8191 if {[string index $fname 0] eq "\""} {
8192 set fname [lindex $fname 0]
8193 }
8194 set fname [encoding convertfrom $fname]
8195 set i [lsearch -exact $treediffs($ids) $fname]
8196 if {$i >= 0} {
8197 setinlist difffilestart $i $curdiffstart
8198 }
8199 } elseif {![string compare -length 10 $line "rename to "] ||
8200 ![string compare -length 8 $line "copy to "]} {
8201 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8202 if {[string index $fname 0] eq "\""} {
8203 set fname [lindex $fname 0]
8204 }
8205 makediffhdr $fname $ids
8206 } elseif {[string compare -length 3 $line "---"] == 0} {
8207 # do nothing
8208 return
8209 } elseif {[string compare -length 3 $line "+++"] == 0} {
8210 set diffinhdr 0
8211 return
8212 }
8213 $ctext insert end "$line\n" filesep
8214
8215 } else {
8216 set line [string map {\x1A ^Z} \
8217 [encoding convertfrom $diffencoding $line]]
8218 # parse the prefix - one ' ', '-' or '+' for each parent
8219 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8220 set tag [expr {$diffnparents > 1? "m": "d"}]
8221 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8222 set words_pre_markup ""
8223 set words_post_markup ""
8224 if {[string trim $prefix " -+"] eq {}} {
8225 # prefix only has " ", "-" and "+" in it: normal diff line
8226 set num [string first "-" $prefix]
8227 if {$dowords} {
8228 set line [string range $line 1 end]
8229 }
8230 if {$num >= 0} {
8231 # removed line, first parent with line is $num
8232 if {$num >= $mergemax} {
8233 set num "max"
8234 }
8235 if {$dowords && $worddiff eq [mc "Markup words"]} {
8236 $ctext insert end "\[-$line-\]" $tag$num
8237 } else {
8238 $ctext insert end "$line" $tag$num
8239 }
8240 if {!$dowords} {
8241 $ctext insert end "\n" $tag$num
8242 }
8243 } else {
8244 set tags {}
8245 if {[string first "+" $prefix] >= 0} {
8246 # added line
8247 lappend tags ${tag}result
8248 if {$diffnparents > 1} {
8249 set num [string first " " $prefix]
8250 if {$num >= 0} {
8251 if {$num >= $mergemax} {
8252 set num "max"
8253 }
8254 lappend tags m$num
8255 }
8256 }
8257 set words_pre_markup "{+"
8258 set words_post_markup "+}"
8259 }
8260 if {$targetline ne {}} {
8261 if {$diffline == $targetline} {
8262 set diffseehere [$ctext index "end - 1 chars"]
8263 set targetline {}
8264 } else {
8265 incr diffline
8266 }
8267 }
8268 if {$dowords && $worddiff eq [mc "Markup words"]} {
8269 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8270 } else {
8271 $ctext insert end "$line" $tags
8272 }
8273 if {!$dowords} {
8274 $ctext insert end "\n" $tags
8275 }
8276 }
8277 } elseif {$dowords && $prefix eq "~"} {
8278 $ctext insert end "\n" {}
8279 } else {
8280 # "\ No newline at end of file",
8281 # or something else we don't recognize
8282 $ctext insert end "$line\n" hunksep
8283 }
8284 }
8285}
8286
8287proc changediffdisp {} {
8288 global ctext diffelide
8289
8290 $ctext tag conf d0 -elide [lindex $diffelide 0]
8291 $ctext tag conf dresult -elide [lindex $diffelide 1]
8292}
8293
8294proc highlightfile {cline} {
8295 global cflist cflist_top
8296
8297 if {![info exists cflist_top]} return
8298
8299 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8300 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8301 $cflist see $cline.0
8302 set cflist_top $cline
8303}
8304
8305proc highlightfile_for_scrollpos {topidx} {
8306 global cmitmode difffilestart
8307
8308 if {$cmitmode eq "tree"} return
8309 if {![info exists difffilestart]} return
8310
8311 set top [lindex [split $topidx .] 0]
8312 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8313 highlightfile 0
8314 } else {
8315 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8316 }
8317}
8318
8319proc prevfile {} {
8320 global difffilestart ctext cmitmode
8321
8322 if {$cmitmode eq "tree"} return
8323 set prev 0.0
8324 set here [$ctext index @0,0]
8325 foreach loc $difffilestart {
8326 if {[$ctext compare $loc >= $here]} {
8327 $ctext yview $prev
8328 return
8329 }
8330 set prev $loc
8331 }
8332 $ctext yview $prev
8333}
8334
8335proc nextfile {} {
8336 global difffilestart ctext cmitmode
8337
8338 if {$cmitmode eq "tree"} return
8339 set here [$ctext index @0,0]
8340 foreach loc $difffilestart {
8341 if {[$ctext compare $loc > $here]} {
8342 $ctext yview $loc
8343 return
8344 }
8345 }
8346}
8347
8348proc clear_ctext {{first 1.0}} {
8349 global ctext smarktop smarkbot
8350 global ctext_file_names ctext_file_lines
8351 global pendinglinks
8352
8353 set l [lindex [split $first .] 0]
8354 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8355 set smarktop $l
8356 }
8357 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8358 set smarkbot $l
8359 }
8360 $ctext delete $first end
8361 if {$first eq "1.0"} {
8362 unset -nocomplain pendinglinks
8363 }
8364 set ctext_file_names {}
8365 set ctext_file_lines {}
8366}
8367
8368proc settabs {{firstab {}}} {
8369 global firsttabstop tabstop ctext have_tk85
8370
8371 if {$firstab ne {} && $have_tk85} {
8372 set firsttabstop $firstab
8373 }
8374 set w [font measure textfont "0"]
8375 if {$firsttabstop != 0} {
8376 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8377 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8378 } elseif {$have_tk85 || $tabstop != 8} {
8379 $ctext conf -tabs [expr {$tabstop * $w}]
8380 } else {
8381 $ctext conf -tabs {}
8382 }
8383}
8384
8385proc incrsearch {name ix op} {
8386 global ctext searchstring searchdirn
8387
8388 if {[catch {$ctext index anchor}]} {
8389 # no anchor set, use start of selection, or of visible area
8390 set sel [$ctext tag ranges sel]
8391 if {$sel ne {}} {
8392 $ctext mark set anchor [lindex $sel 0]
8393 } elseif {$searchdirn eq "-forwards"} {
8394 $ctext mark set anchor @0,0
8395 } else {
8396 $ctext mark set anchor @0,[winfo height $ctext]
8397 }
8398 }
8399 if {$searchstring ne {}} {
8400 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8401 if {$here ne {}} {
8402 $ctext see $here
8403 set mend "$here + $mlen c"
8404 $ctext tag remove sel 1.0 end
8405 $ctext tag add sel $here $mend
8406 suppress_highlighting_file_for_current_scrollpos
8407 highlightfile_for_scrollpos $here
8408 }
8409 }
8410 rehighlight_search_results
8411}
8412
8413proc dosearch {} {
8414 global sstring ctext searchstring searchdirn
8415
8416 focus $sstring
8417 $sstring icursor end
8418 set searchdirn -forwards
8419 if {$searchstring ne {}} {
8420 set sel [$ctext tag ranges sel]
8421 if {$sel ne {}} {
8422 set start "[lindex $sel 0] + 1c"
8423 } elseif {[catch {set start [$ctext index anchor]}]} {
8424 set start "@0,0"
8425 }
8426 set match [$ctext search -count mlen -- $searchstring $start]
8427 $ctext tag remove sel 1.0 end
8428 if {$match eq {}} {
8429 bell
8430 return
8431 }
8432 $ctext see $match
8433 suppress_highlighting_file_for_current_scrollpos
8434 highlightfile_for_scrollpos $match
8435 set mend "$match + $mlen c"
8436 $ctext tag add sel $match $mend
8437 $ctext mark unset anchor
8438 rehighlight_search_results
8439 }
8440}
8441
8442proc dosearchback {} {
8443 global sstring ctext searchstring searchdirn
8444
8445 focus $sstring
8446 $sstring icursor end
8447 set searchdirn -backwards
8448 if {$searchstring ne {}} {
8449 set sel [$ctext tag ranges sel]
8450 if {$sel ne {}} {
8451 set start [lindex $sel 0]
8452 } elseif {[catch {set start [$ctext index anchor]}]} {
8453 set start @0,[winfo height $ctext]
8454 }
8455 set match [$ctext search -backwards -count ml -- $searchstring $start]
8456 $ctext tag remove sel 1.0 end
8457 if {$match eq {}} {
8458 bell
8459 return
8460 }
8461 $ctext see $match
8462 suppress_highlighting_file_for_current_scrollpos
8463 highlightfile_for_scrollpos $match
8464 set mend "$match + $ml c"
8465 $ctext tag add sel $match $mend
8466 $ctext mark unset anchor
8467 rehighlight_search_results
8468 }
8469}
8470
8471proc rehighlight_search_results {} {
8472 global ctext searchstring
8473
8474 $ctext tag remove found 1.0 end
8475 $ctext tag remove currentsearchhit 1.0 end
8476
8477 if {$searchstring ne {}} {
8478 searchmarkvisible 1
8479 }
8480}
8481
8482proc searchmark {first last} {
8483 global ctext searchstring
8484
8485 set sel [$ctext tag ranges sel]
8486
8487 set mend $first.0
8488 while {1} {
8489 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8490 if {$match eq {}} break
8491 set mend "$match + $mlen c"
8492 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8493 $ctext tag add currentsearchhit $match $mend
8494 } else {
8495 $ctext tag add found $match $mend
8496 }
8497 }
8498}
8499
8500proc searchmarkvisible {doall} {
8501 global ctext smarktop smarkbot
8502
8503 set topline [lindex [split [$ctext index @0,0] .] 0]
8504 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8505 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8506 # no overlap with previous
8507 searchmark $topline $botline
8508 set smarktop $topline
8509 set smarkbot $botline
8510 } else {
8511 if {$topline < $smarktop} {
8512 searchmark $topline [expr {$smarktop-1}]
8513 set smarktop $topline
8514 }
8515 if {$botline > $smarkbot} {
8516 searchmark [expr {$smarkbot+1}] $botline
8517 set smarkbot $botline
8518 }
8519 }
8520}
8521
8522proc suppress_highlighting_file_for_current_scrollpos {} {
8523 global ctext suppress_highlighting_file_for_this_scrollpos
8524
8525 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8526}
8527
8528proc scrolltext {f0 f1} {
8529 global searchstring cmitmode ctext
8530 global suppress_highlighting_file_for_this_scrollpos
8531
8532 set topidx [$ctext index @0,0]
8533 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8534 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8535 highlightfile_for_scrollpos $topidx
8536 }
8537
8538 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8539
8540 .bleft.bottom.sb set $f0 $f1
8541 if {$searchstring ne {}} {
8542 searchmarkvisible 0
8543 }
8544}
8545
8546proc setcoords {} {
8547 global linespc charspc canvx0 canvy0
8548 global xspc1 xspc2 lthickness
8549
8550 set linespc [font metrics mainfont -linespace]
8551 set charspc [font measure mainfont "m"]
8552 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8553 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8554 set lthickness [expr {int($linespc / 9) + 1}]
8555 set xspc1(0) $linespc
8556 set xspc2 $linespc
8557}
8558
8559proc redisplay {} {
8560 global canv
8561 global selectedline
8562
8563 set ymax [lindex [$canv cget -scrollregion] 3]
8564 if {$ymax eq {} || $ymax == 0} return
8565 set span [$canv yview]
8566 clear_display
8567 setcanvscroll
8568 allcanvs yview moveto [lindex $span 0]
8569 drawvisible
8570 if {$selectedline ne {}} {
8571 selectline $selectedline 0
8572 allcanvs yview moveto [lindex $span 0]
8573 }
8574}
8575
8576proc parsefont {f n} {
8577 global fontattr
8578
8579 set fontattr($f,family) [lindex $n 0]
8580 set s [lindex $n 1]
8581 if {$s eq {} || $s == 0} {
8582 set s 10
8583 } elseif {$s < 0} {
8584 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8585 }
8586 set fontattr($f,size) $s
8587 set fontattr($f,weight) normal
8588 set fontattr($f,slant) roman
8589 foreach style [lrange $n 2 end] {
8590 switch -- $style {
8591 "normal" -
8592 "bold" {set fontattr($f,weight) $style}
8593 "roman" -
8594 "italic" {set fontattr($f,slant) $style}
8595 }
8596 }
8597}
8598
8599proc fontflags {f {isbold 0}} {
8600 global fontattr
8601
8602 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8603 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8604 -slant $fontattr($f,slant)]
8605}
8606
8607proc fontname {f} {
8608 global fontattr
8609
8610 set n [list $fontattr($f,family) $fontattr($f,size)]
8611 if {$fontattr($f,weight) eq "bold"} {
8612 lappend n "bold"
8613 }
8614 if {$fontattr($f,slant) eq "italic"} {
8615 lappend n "italic"
8616 }
8617 return $n
8618}
8619
8620proc incrfont {inc} {
8621 global mainfont textfont ctext canv cflist showrefstop
8622 global stopped entries fontattr
8623
8624 unmarkmatches
8625 set s $fontattr(mainfont,size)
8626 incr s $inc
8627 if {$s < 1} {
8628 set s 1
8629 }
8630 set fontattr(mainfont,size) $s
8631 font config mainfont -size $s
8632 font config mainfontbold -size $s
8633 set mainfont [fontname mainfont]
8634 set s $fontattr(textfont,size)
8635 incr s $inc
8636 if {$s < 1} {
8637 set s 1
8638 }
8639 set fontattr(textfont,size) $s
8640 font config textfont -size $s
8641 font config textfontbold -size $s
8642 set textfont [fontname textfont]
8643 setcoords
8644 settabs
8645 redisplay
8646}
8647
8648proc clearsha1 {} {
8649 global sha1entry sha1string
8650 if {[string length $sha1string] == 40} {
8651 $sha1entry delete 0 end
8652 }
8653}
8654
8655proc sha1change {n1 n2 op} {
8656 global sha1string currentid sha1but
8657 if {$sha1string == {}
8658 || ([info exists currentid] && $sha1string == $currentid)} {
8659 set state disabled
8660 } else {
8661 set state normal
8662 }
8663 if {[$sha1but cget -state] == $state} return
8664 if {$state == "normal"} {
8665 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8666 } else {
8667 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8668 }
8669}
8670
8671proc gotocommit {} {
8672 global sha1string tagids headids curview varcid
8673
8674 if {$sha1string == {}
8675 || ([info exists currentid] && $sha1string == $currentid)} return
8676 if {[info exists tagids($sha1string)]} {
8677 set id $tagids($sha1string)
8678 } elseif {[info exists headids($sha1string)]} {
8679 set id $headids($sha1string)
8680 } else {
8681 set id [string tolower $sha1string]
8682 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8683 set matches [longid $id]
8684 if {$matches ne {}} {
8685 if {[llength $matches] > 1} {
8686 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8687 return
8688 }
8689 set id [lindex $matches 0]
8690 }
8691 } else {
8692 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8693 error_popup [mc "Revision %s is not known" $sha1string]
8694 return
8695 }
8696 }
8697 }
8698 if {[commitinview $id $curview]} {
8699 selectline [rowofcommit $id] 1
8700 return
8701 }
8702 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8703 set msg [mc "SHA1 id %s is not known" $sha1string]
8704 } else {
8705 set msg [mc "Revision %s is not in the current view" $sha1string]
8706 }
8707 error_popup $msg
8708}
8709
8710proc lineenter {x y id} {
8711 global hoverx hovery hoverid hovertimer
8712 global commitinfo canv
8713
8714 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8715 set hoverx $x
8716 set hovery $y
8717 set hoverid $id
8718 if {[info exists hovertimer]} {
8719 after cancel $hovertimer
8720 }
8721 set hovertimer [after 500 linehover]
8722 $canv delete hover
8723}
8724
8725proc linemotion {x y id} {
8726 global hoverx hovery hoverid hovertimer
8727
8728 if {[info exists hoverid] && $id == $hoverid} {
8729 set hoverx $x
8730 set hovery $y
8731 if {[info exists hovertimer]} {
8732 after cancel $hovertimer
8733 }
8734 set hovertimer [after 500 linehover]
8735 }
8736}
8737
8738proc lineleave {id} {
8739 global hoverid hovertimer canv
8740
8741 if {[info exists hoverid] && $id == $hoverid} {
8742 $canv delete hover
8743 if {[info exists hovertimer]} {
8744 after cancel $hovertimer
8745 unset hovertimer
8746 }
8747 unset hoverid
8748 }
8749}
8750
8751proc linehover {} {
8752 global hoverx hovery hoverid hovertimer
8753 global canv linespc lthickness
8754 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8755
8756 global commitinfo
8757
8758 set text [lindex $commitinfo($hoverid) 0]
8759 set ymax [lindex [$canv cget -scrollregion] 3]
8760 if {$ymax == {}} return
8761 set yfrac [lindex [$canv yview] 0]
8762 set x [expr {$hoverx + 2 * $linespc}]
8763 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8764 set x0 [expr {$x - 2 * $lthickness}]
8765 set y0 [expr {$y - 2 * $lthickness}]
8766 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8767 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8768 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8769 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8770 -width 1 -tags hover]
8771 $canv raise $t
8772 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8773 -font mainfont -fill $linehoverfgcolor]
8774 $canv raise $t
8775}
8776
8777proc clickisonarrow {id y} {
8778 global lthickness
8779
8780 set ranges [rowranges $id]
8781 set thresh [expr {2 * $lthickness + 6}]
8782 set n [expr {[llength $ranges] - 1}]
8783 for {set i 1} {$i < $n} {incr i} {
8784 set row [lindex $ranges $i]
8785 if {abs([yc $row] - $y) < $thresh} {
8786 return $i
8787 }
8788 }
8789 return {}
8790}
8791
8792proc arrowjump {id n y} {
8793 global canv
8794
8795 # 1 <-> 2, 3 <-> 4, etc...
8796 set n [expr {(($n - 1) ^ 1) + 1}]
8797 set row [lindex [rowranges $id] $n]
8798 set yt [yc $row]
8799 set ymax [lindex [$canv cget -scrollregion] 3]
8800 if {$ymax eq {} || $ymax <= 0} return
8801 set view [$canv yview]
8802 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8803 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8804 if {$yfrac < 0} {
8805 set yfrac 0
8806 }
8807 allcanvs yview moveto $yfrac
8808}
8809
8810proc lineclick {x y id isnew} {
8811 global ctext commitinfo children canv thickerline curview
8812
8813 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8814 unmarkmatches
8815 unselectline
8816 normalline
8817 $canv delete hover
8818 # draw this line thicker than normal
8819 set thickerline $id
8820 drawlines $id
8821 if {$isnew} {
8822 set ymax [lindex [$canv cget -scrollregion] 3]
8823 if {$ymax eq {}} return
8824 set yfrac [lindex [$canv yview] 0]
8825 set y [expr {$y + $yfrac * $ymax}]
8826 }
8827 set dirn [clickisonarrow $id $y]
8828 if {$dirn ne {}} {
8829 arrowjump $id $dirn $y
8830 return
8831 }
8832
8833 if {$isnew} {
8834 addtohistory [list lineclick $x $y $id 0] savectextpos
8835 }
8836 # fill the details pane with info about this line
8837 $ctext conf -state normal
8838 clear_ctext
8839 settabs 0
8840 $ctext insert end "[mc "Parent"]:\t"
8841 $ctext insert end $id link0
8842 setlink $id link0
8843 set info $commitinfo($id)
8844 $ctext insert end "\n\t[lindex $info 0]\n"
8845 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8846 set date [formatdate [lindex $info 2]]
8847 $ctext insert end "\t[mc "Date"]:\t$date\n"
8848 set kids $children($curview,$id)
8849 if {$kids ne {}} {
8850 $ctext insert end "\n[mc "Children"]:"
8851 set i 0
8852 foreach child $kids {
8853 incr i
8854 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8855 set info $commitinfo($child)
8856 $ctext insert end "\n\t"
8857 $ctext insert end $child link$i
8858 setlink $child link$i
8859 $ctext insert end "\n\t[lindex $info 0]"
8860 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8861 set date [formatdate [lindex $info 2]]
8862 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8863 }
8864 }
8865 maybe_scroll_ctext 1
8866 $ctext conf -state disabled
8867 init_flist {}
8868}
8869
8870proc normalline {} {
8871 global thickerline
8872 if {[info exists thickerline]} {
8873 set id $thickerline
8874 unset thickerline
8875 drawlines $id
8876 }
8877}
8878
8879proc selbyid {id {isnew 1}} {
8880 global curview
8881 if {[commitinview $id $curview]} {
8882 selectline [rowofcommit $id] $isnew
8883 }
8884}
8885
8886proc mstime {} {
8887 global startmstime
8888 if {![info exists startmstime]} {
8889 set startmstime [clock clicks -milliseconds]
8890 }
8891 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8892}
8893
8894proc rowmenu {x y id} {
8895 global rowctxmenu selectedline rowmenuid curview
8896 global nullid nullid2 fakerowmenu mainhead markedid
8897
8898 stopfinding
8899 set rowmenuid $id
8900 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8901 set state disabled
8902 } else {
8903 set state normal
8904 }
8905 if {[info exists markedid] && $markedid ne $id} {
8906 set mstate normal
8907 } else {
8908 set mstate disabled
8909 }
8910 if {$id ne $nullid && $id ne $nullid2} {
8911 set menu $rowctxmenu
8912 if {$mainhead ne {}} {
8913 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8914 } else {
8915 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8916 }
8917 $menu entryconfigure 10 -state $mstate
8918 $menu entryconfigure 11 -state $mstate
8919 $menu entryconfigure 12 -state $mstate
8920 } else {
8921 set menu $fakerowmenu
8922 }
8923 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8924 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8925 $menu entryconfigure [mca "Make patch"] -state $state
8926 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8927 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8928 tk_popup $menu $x $y
8929}
8930
8931proc markhere {} {
8932 global rowmenuid markedid canv
8933
8934 set markedid $rowmenuid
8935 make_idmark $markedid
8936}
8937
8938proc gotomark {} {
8939 global markedid
8940
8941 if {[info exists markedid]} {
8942 selbyid $markedid
8943 }
8944}
8945
8946proc replace_by_kids {l r} {
8947 global curview children
8948
8949 set id [commitonrow $r]
8950 set l [lreplace $l 0 0]
8951 foreach kid $children($curview,$id) {
8952 lappend l [rowofcommit $kid]
8953 }
8954 return [lsort -integer -decreasing -unique $l]
8955}
8956
8957proc find_common_desc {} {
8958 global markedid rowmenuid curview children
8959
8960 if {![info exists markedid]} return
8961 if {![commitinview $markedid $curview] ||
8962 ![commitinview $rowmenuid $curview]} return
8963 #set t1 [clock clicks -milliseconds]
8964 set l1 [list [rowofcommit $markedid]]
8965 set l2 [list [rowofcommit $rowmenuid]]
8966 while 1 {
8967 set r1 [lindex $l1 0]
8968 set r2 [lindex $l2 0]
8969 if {$r1 eq {} || $r2 eq {}} break
8970 if {$r1 == $r2} {
8971 selectline $r1 1
8972 break
8973 }
8974 if {$r1 > $r2} {
8975 set l1 [replace_by_kids $l1 $r1]
8976 } else {
8977 set l2 [replace_by_kids $l2 $r2]
8978 }
8979 }
8980 #set t2 [clock clicks -milliseconds]
8981 #puts "took [expr {$t2-$t1}]ms"
8982}
8983
8984proc compare_commits {} {
8985 global markedid rowmenuid curview children
8986
8987 if {![info exists markedid]} return
8988 if {![commitinview $markedid $curview]} return
8989 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8990 do_cmp_commits $markedid $rowmenuid
8991}
8992
8993proc getpatchid {id} {
8994 global patchids
8995
8996 if {![info exists patchids($id)]} {
8997 set cmd [diffcmd [list $id] {-p --root}]
8998 # trim off the initial "|"
8999 set cmd [lrange $cmd 1 end]
9000 if {[catch {
9001 set x [eval exec $cmd | git patch-id]
9002 set patchids($id) [lindex $x 0]
9003 }]} {
9004 set patchids($id) "error"
9005 }
9006 }
9007 return $patchids($id)
9008}
9009
9010proc do_cmp_commits {a b} {
9011 global ctext curview parents children patchids commitinfo
9012
9013 $ctext conf -state normal
9014 clear_ctext
9015 init_flist {}
9016 for {set i 0} {$i < 100} {incr i} {
9017 set skipa 0
9018 set skipb 0
9019 if {[llength $parents($curview,$a)] > 1} {
9020 appendshortlink $a [mc "Skipping merge commit "] "\n"
9021 set skipa 1
9022 } else {
9023 set patcha [getpatchid $a]
9024 }
9025 if {[llength $parents($curview,$b)] > 1} {
9026 appendshortlink $b [mc "Skipping merge commit "] "\n"
9027 set skipb 1
9028 } else {
9029 set patchb [getpatchid $b]
9030 }
9031 if {!$skipa && !$skipb} {
9032 set heada [lindex $commitinfo($a) 0]
9033 set headb [lindex $commitinfo($b) 0]
9034 if {$patcha eq "error"} {
9035 appendshortlink $a [mc "Error getting patch ID for "] \
9036 [mc " - stopping\n"]
9037 break
9038 }
9039 if {$patchb eq "error"} {
9040 appendshortlink $b [mc "Error getting patch ID for "] \
9041 [mc " - stopping\n"]
9042 break
9043 }
9044 if {$patcha eq $patchb} {
9045 if {$heada eq $headb} {
9046 appendshortlink $a [mc "Commit "]
9047 appendshortlink $b " == " " $heada\n"
9048 } else {
9049 appendshortlink $a [mc "Commit "] " $heada\n"
9050 appendshortlink $b [mc " is the same patch as\n "] \
9051 " $headb\n"
9052 }
9053 set skipa 1
9054 set skipb 1
9055 } else {
9056 $ctext insert end "\n"
9057 appendshortlink $a [mc "Commit "] " $heada\n"
9058 appendshortlink $b [mc " differs from\n "] \
9059 " $headb\n"
9060 $ctext insert end [mc "Diff of commits:\n\n"]
9061 $ctext conf -state disabled
9062 update
9063 diffcommits $a $b
9064 return
9065 }
9066 }
9067 if {$skipa} {
9068 set kids [real_children $curview,$a]
9069 if {[llength $kids] != 1} {
9070 $ctext insert end "\n"
9071 appendshortlink $a [mc "Commit "] \
9072 [mc " has %s children - stopping\n" [llength $kids]]
9073 break
9074 }
9075 set a [lindex $kids 0]
9076 }
9077 if {$skipb} {
9078 set kids [real_children $curview,$b]
9079 if {[llength $kids] != 1} {
9080 appendshortlink $b [mc "Commit "] \
9081 [mc " has %s children - stopping\n" [llength $kids]]
9082 break
9083 }
9084 set b [lindex $kids 0]
9085 }
9086 }
9087 $ctext conf -state disabled
9088}
9089
9090proc diffcommits {a b} {
9091 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9092
9093 set tmpdir [gitknewtmpdir]
9094 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9095 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9096 if {[catch {
9097 exec git diff-tree -p --pretty $a >$fna
9098 exec git diff-tree -p --pretty $b >$fnb
9099 } err]} {
9100 error_popup [mc "Error writing commit to file: %s" $err]
9101 return
9102 }
9103 if {[catch {
9104 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9105 } err]} {
9106 error_popup [mc "Error diffing commits: %s" $err]
9107 return
9108 }
9109 set diffids [list commits $a $b]
9110 set blobdifffd($diffids) $fd
9111 set diffinhdr 0
9112 set currdiffsubmod ""
9113 filerun $fd [list getblobdiffline $fd $diffids]
9114}
9115
9116proc diffvssel {dirn} {
9117 global rowmenuid selectedline
9118
9119 if {$selectedline eq {}} return
9120 if {$dirn} {
9121 set oldid [commitonrow $selectedline]
9122 set newid $rowmenuid
9123 } else {
9124 set oldid $rowmenuid
9125 set newid [commitonrow $selectedline]
9126 }
9127 addtohistory [list doseldiff $oldid $newid] savectextpos
9128 doseldiff $oldid $newid
9129}
9130
9131proc diffvsmark {dirn} {
9132 global rowmenuid markedid
9133
9134 if {![info exists markedid]} return
9135 if {$dirn} {
9136 set oldid $markedid
9137 set newid $rowmenuid
9138 } else {
9139 set oldid $rowmenuid
9140 set newid $markedid
9141 }
9142 addtohistory [list doseldiff $oldid $newid] savectextpos
9143 doseldiff $oldid $newid
9144}
9145
9146proc doseldiff {oldid newid} {
9147 global ctext
9148 global commitinfo
9149
9150 $ctext conf -state normal
9151 clear_ctext
9152 init_flist [mc "Top"]
9153 $ctext insert end "[mc "From"] "
9154 $ctext insert end $oldid link0
9155 setlink $oldid link0
9156 $ctext insert end "\n "
9157 $ctext insert end [lindex $commitinfo($oldid) 0]
9158 $ctext insert end "\n\n[mc "To"] "
9159 $ctext insert end $newid link1
9160 setlink $newid link1
9161 $ctext insert end "\n "
9162 $ctext insert end [lindex $commitinfo($newid) 0]
9163 $ctext insert end "\n"
9164 $ctext conf -state disabled
9165 $ctext tag remove found 1.0 end
9166 startdiff [list $oldid $newid]
9167}
9168
9169proc mkpatch {} {
9170 global rowmenuid currentid commitinfo patchtop patchnum NS
9171
9172 if {![info exists currentid]} return
9173 set oldid $currentid
9174 set oldhead [lindex $commitinfo($oldid) 0]
9175 set newid $rowmenuid
9176 set newhead [lindex $commitinfo($newid) 0]
9177 set top .patch
9178 set patchtop $top
9179 catch {destroy $top}
9180 ttk_toplevel $top
9181 make_transient $top .
9182 ${NS}::label $top.title -text [mc "Generate patch"]
9183 grid $top.title - -pady 10
9184 ${NS}::label $top.from -text [mc "From:"]
9185 ${NS}::entry $top.fromsha1 -width 40
9186 $top.fromsha1 insert 0 $oldid
9187 $top.fromsha1 conf -state readonly
9188 grid $top.from $top.fromsha1 -sticky w
9189 ${NS}::entry $top.fromhead -width 60
9190 $top.fromhead insert 0 $oldhead
9191 $top.fromhead conf -state readonly
9192 grid x $top.fromhead -sticky w
9193 ${NS}::label $top.to -text [mc "To:"]
9194 ${NS}::entry $top.tosha1 -width 40
9195 $top.tosha1 insert 0 $newid
9196 $top.tosha1 conf -state readonly
9197 grid $top.to $top.tosha1 -sticky w
9198 ${NS}::entry $top.tohead -width 60
9199 $top.tohead insert 0 $newhead
9200 $top.tohead conf -state readonly
9201 grid x $top.tohead -sticky w
9202 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9203 grid $top.rev x -pady 10 -padx 5
9204 ${NS}::label $top.flab -text [mc "Output file:"]
9205 ${NS}::entry $top.fname -width 60
9206 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9207 incr patchnum
9208 grid $top.flab $top.fname -sticky w
9209 ${NS}::frame $top.buts
9210 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9211 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9212 bind $top <Key-Return> mkpatchgo
9213 bind $top <Key-Escape> mkpatchcan
9214 grid $top.buts.gen $top.buts.can
9215 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9216 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9217 grid $top.buts - -pady 10 -sticky ew
9218 focus $top.fname
9219}
9220
9221proc mkpatchrev {} {
9222 global patchtop
9223
9224 set oldid [$patchtop.fromsha1 get]
9225 set oldhead [$patchtop.fromhead get]
9226 set newid [$patchtop.tosha1 get]
9227 set newhead [$patchtop.tohead get]
9228 foreach e [list fromsha1 fromhead tosha1 tohead] \
9229 v [list $newid $newhead $oldid $oldhead] {
9230 $patchtop.$e conf -state normal
9231 $patchtop.$e delete 0 end
9232 $patchtop.$e insert 0 $v
9233 $patchtop.$e conf -state readonly
9234 }
9235}
9236
9237proc mkpatchgo {} {
9238 global patchtop nullid nullid2
9239
9240 set oldid [$patchtop.fromsha1 get]
9241 set newid [$patchtop.tosha1 get]
9242 set fname [$patchtop.fname get]
9243 set cmd [diffcmd [list $oldid $newid] -p]
9244 # trim off the initial "|"
9245 set cmd [lrange $cmd 1 end]
9246 lappend cmd >$fname &
9247 if {[catch {eval exec $cmd} err]} {
9248 error_popup "[mc "Error creating patch:"] $err" $patchtop
9249 }
9250 catch {destroy $patchtop}
9251 unset patchtop
9252}
9253
9254proc mkpatchcan {} {
9255 global patchtop
9256
9257 catch {destroy $patchtop}
9258 unset patchtop
9259}
9260
9261proc mktag {} {
9262 global rowmenuid mktagtop commitinfo NS
9263
9264 set top .maketag
9265 set mktagtop $top
9266 catch {destroy $top}
9267 ttk_toplevel $top
9268 make_transient $top .
9269 ${NS}::label $top.title -text [mc "Create tag"]
9270 grid $top.title - -pady 10
9271 ${NS}::label $top.id -text [mc "ID:"]
9272 ${NS}::entry $top.sha1 -width 40
9273 $top.sha1 insert 0 $rowmenuid
9274 $top.sha1 conf -state readonly
9275 grid $top.id $top.sha1 -sticky w
9276 ${NS}::entry $top.head -width 60
9277 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9278 $top.head conf -state readonly
9279 grid x $top.head -sticky w
9280 ${NS}::label $top.tlab -text [mc "Tag name:"]
9281 ${NS}::entry $top.tag -width 60
9282 grid $top.tlab $top.tag -sticky w
9283 ${NS}::label $top.op -text [mc "Tag message is optional"]
9284 grid $top.op -columnspan 2 -sticky we
9285 ${NS}::label $top.mlab -text [mc "Tag message:"]
9286 ${NS}::entry $top.msg -width 60
9287 grid $top.mlab $top.msg -sticky w
9288 ${NS}::frame $top.buts
9289 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9290 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9291 bind $top <Key-Return> mktaggo
9292 bind $top <Key-Escape> mktagcan
9293 grid $top.buts.gen $top.buts.can
9294 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9295 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9296 grid $top.buts - -pady 10 -sticky ew
9297 focus $top.tag
9298}
9299
9300proc domktag {} {
9301 global mktagtop env tagids idtags
9302
9303 set id [$mktagtop.sha1 get]
9304 set tag [$mktagtop.tag get]
9305 set msg [$mktagtop.msg get]
9306 if {$tag == {}} {
9307 error_popup [mc "No tag name specified"] $mktagtop
9308 return 0
9309 }
9310 if {[info exists tagids($tag)]} {
9311 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9312 return 0
9313 }
9314 if {[catch {
9315 if {$msg != {}} {
9316 exec git tag -a -m $msg $tag $id
9317 } else {
9318 exec git tag $tag $id
9319 }
9320 } err]} {
9321 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9322 return 0
9323 }
9324
9325 set tagids($tag) $id
9326 lappend idtags($id) $tag
9327 redrawtags $id
9328 addedtag $id
9329 dispneartags 0
9330 run refill_reflist
9331 return 1
9332}
9333
9334proc redrawtags {id} {
9335 global canv linehtag idpos currentid curview cmitlisted markedid
9336 global canvxmax iddrawn circleitem mainheadid circlecolors
9337 global mainheadcirclecolor
9338
9339 if {![commitinview $id $curview]} return
9340 if {![info exists iddrawn($id)]} return
9341 set row [rowofcommit $id]
9342 if {$id eq $mainheadid} {
9343 set ofill $mainheadcirclecolor
9344 } else {
9345 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9346 }
9347 $canv itemconf $circleitem($row) -fill $ofill
9348 $canv delete tag.$id
9349 set xt [eval drawtags $id $idpos($id)]
9350 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9351 set text [$canv itemcget $linehtag($id) -text]
9352 set font [$canv itemcget $linehtag($id) -font]
9353 set xr [expr {$xt + [font measure $font $text]}]
9354 if {$xr > $canvxmax} {
9355 set canvxmax $xr
9356 setcanvscroll
9357 }
9358 if {[info exists currentid] && $currentid == $id} {
9359 make_secsel $id
9360 }
9361 if {[info exists markedid] && $markedid eq $id} {
9362 make_idmark $id
9363 }
9364}
9365
9366proc mktagcan {} {
9367 global mktagtop
9368
9369 catch {destroy $mktagtop}
9370 unset mktagtop
9371}
9372
9373proc mktaggo {} {
9374 if {![domktag]} return
9375 mktagcan
9376}
9377
9378proc copysummary {} {
9379 global rowmenuid autosellen
9380
9381 set format "%h (\"%s\", %ad)"
9382 set cmd [list git show -s --pretty=format:$format --date=short]
9383 if {$autosellen < 40} {
9384 lappend cmd --abbrev=$autosellen
9385 }
9386 set summary [eval exec $cmd $rowmenuid]
9387
9388 clipboard clear
9389 clipboard append $summary
9390}
9391
9392proc writecommit {} {
9393 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9394
9395 set top .writecommit
9396 set wrcomtop $top
9397 catch {destroy $top}
9398 ttk_toplevel $top
9399 make_transient $top .
9400 ${NS}::label $top.title -text [mc "Write commit to file"]
9401 grid $top.title - -pady 10
9402 ${NS}::label $top.id -text [mc "ID:"]
9403 ${NS}::entry $top.sha1 -width 40
9404 $top.sha1 insert 0 $rowmenuid
9405 $top.sha1 conf -state readonly
9406 grid $top.id $top.sha1 -sticky w
9407 ${NS}::entry $top.head -width 60
9408 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9409 $top.head conf -state readonly
9410 grid x $top.head -sticky w
9411 ${NS}::label $top.clab -text [mc "Command:"]
9412 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9413 grid $top.clab $top.cmd -sticky w -pady 10
9414 ${NS}::label $top.flab -text [mc "Output file:"]
9415 ${NS}::entry $top.fname -width 60
9416 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9417 grid $top.flab $top.fname -sticky w
9418 ${NS}::frame $top.buts
9419 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9420 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9421 bind $top <Key-Return> wrcomgo
9422 bind $top <Key-Escape> wrcomcan
9423 grid $top.buts.gen $top.buts.can
9424 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9425 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9426 grid $top.buts - -pady 10 -sticky ew
9427 focus $top.fname
9428}
9429
9430proc wrcomgo {} {
9431 global wrcomtop
9432
9433 set id [$wrcomtop.sha1 get]
9434 set cmd "echo $id | [$wrcomtop.cmd get]"
9435 set fname [$wrcomtop.fname get]
9436 if {[catch {exec sh -c $cmd >$fname &} err]} {
9437 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9438 }
9439 catch {destroy $wrcomtop}
9440 unset wrcomtop
9441}
9442
9443proc wrcomcan {} {
9444 global wrcomtop
9445
9446 catch {destroy $wrcomtop}
9447 unset wrcomtop
9448}
9449
9450proc mkbranch {} {
9451 global rowmenuid mkbrtop NS
9452
9453 set top .makebranch
9454 catch {destroy $top}
9455 ttk_toplevel $top
9456 make_transient $top .
9457 ${NS}::label $top.title -text [mc "Create new branch"]
9458 grid $top.title - -pady 10
9459 ${NS}::label $top.id -text [mc "ID:"]
9460 ${NS}::entry $top.sha1 -width 40
9461 $top.sha1 insert 0 $rowmenuid
9462 $top.sha1 conf -state readonly
9463 grid $top.id $top.sha1 -sticky w
9464 ${NS}::label $top.nlab -text [mc "Name:"]
9465 ${NS}::entry $top.name -width 40
9466 grid $top.nlab $top.name -sticky w
9467 ${NS}::frame $top.buts
9468 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9469 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9470 bind $top <Key-Return> [list mkbrgo $top]
9471 bind $top <Key-Escape> "catch {destroy $top}"
9472 grid $top.buts.go $top.buts.can
9473 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9474 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9475 grid $top.buts - -pady 10 -sticky ew
9476 focus $top.name
9477}
9478
9479proc mkbrgo {top} {
9480 global headids idheads
9481
9482 set name [$top.name get]
9483 set id [$top.sha1 get]
9484 set cmdargs {}
9485 set old_id {}
9486 if {$name eq {}} {
9487 error_popup [mc "Please specify a name for the new branch"] $top
9488 return
9489 }
9490 if {[info exists headids($name)]} {
9491 if {![confirm_popup [mc \
9492 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9493 return
9494 }
9495 set old_id $headids($name)
9496 lappend cmdargs -f
9497 }
9498 catch {destroy $top}
9499 lappend cmdargs $name $id
9500 nowbusy newbranch
9501 update
9502 if {[catch {
9503 eval exec git branch $cmdargs
9504 } err]} {
9505 notbusy newbranch
9506 error_popup $err
9507 } else {
9508 notbusy newbranch
9509 if {$old_id ne {}} {
9510 movehead $id $name
9511 movedhead $id $name
9512 redrawtags $old_id
9513 redrawtags $id
9514 } else {
9515 set headids($name) $id
9516 lappend idheads($id) $name
9517 addedhead $id $name
9518 redrawtags $id
9519 }
9520 dispneartags 0
9521 run refill_reflist
9522 }
9523}
9524
9525proc exec_citool {tool_args {baseid {}}} {
9526 global commitinfo env
9527
9528 set save_env [array get env GIT_AUTHOR_*]
9529
9530 if {$baseid ne {}} {
9531 if {![info exists commitinfo($baseid)]} {
9532 getcommit $baseid
9533 }
9534 set author [lindex $commitinfo($baseid) 1]
9535 set date [lindex $commitinfo($baseid) 2]
9536 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9537 $author author name email]
9538 && $date ne {}} {
9539 set env(GIT_AUTHOR_NAME) $name
9540 set env(GIT_AUTHOR_EMAIL) $email
9541 set env(GIT_AUTHOR_DATE) $date
9542 }
9543 }
9544
9545 eval exec git citool $tool_args &
9546
9547 array unset env GIT_AUTHOR_*
9548 array set env $save_env
9549}
9550
9551proc cherrypick {} {
9552 global rowmenuid curview
9553 global mainhead mainheadid
9554 global gitdir
9555
9556 set oldhead [exec git rev-parse HEAD]
9557 set dheads [descheads $rowmenuid]
9558 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9559 set ok [confirm_popup [mc "Commit %s is already\
9560 included in branch %s -- really re-apply it?" \
9561 [string range $rowmenuid 0 7] $mainhead]]
9562 if {!$ok} return
9563 }
9564 nowbusy cherrypick [mc "Cherry-picking"]
9565 update
9566 # Unfortunately git-cherry-pick writes stuff to stderr even when
9567 # no error occurs, and exec takes that as an indication of error...
9568 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9569 notbusy cherrypick
9570 if {[regexp -line \
9571 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9572 $err msg fname]} {
9573 error_popup [mc "Cherry-pick failed because of local changes\
9574 to file '%s'.\nPlease commit, reset or stash\
9575 your changes and try again." $fname]
9576 } elseif {[regexp -line \
9577 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9578 $err]} {
9579 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9580 conflict.\nDo you wish to run git citool to\
9581 resolve it?"]]} {
9582 # Force citool to read MERGE_MSG
9583 file delete [file join $gitdir "GITGUI_MSG"]
9584 exec_citool {} $rowmenuid
9585 }
9586 } else {
9587 error_popup $err
9588 }
9589 run updatecommits
9590 return
9591 }
9592 set newhead [exec git rev-parse HEAD]
9593 if {$newhead eq $oldhead} {
9594 notbusy cherrypick
9595 error_popup [mc "No changes committed"]
9596 return
9597 }
9598 addnewchild $newhead $oldhead
9599 if {[commitinview $oldhead $curview]} {
9600 # XXX this isn't right if we have a path limit...
9601 insertrow $newhead $oldhead $curview
9602 if {$mainhead ne {}} {
9603 movehead $newhead $mainhead
9604 movedhead $newhead $mainhead
9605 }
9606 set mainheadid $newhead
9607 redrawtags $oldhead
9608 redrawtags $newhead
9609 selbyid $newhead
9610 }
9611 notbusy cherrypick
9612}
9613
9614proc revert {} {
9615 global rowmenuid curview
9616 global mainhead mainheadid
9617 global gitdir
9618
9619 set oldhead [exec git rev-parse HEAD]
9620 set dheads [descheads $rowmenuid]
9621 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9622 set ok [confirm_popup [mc "Commit %s is not\
9623 included in branch %s -- really revert it?" \
9624 [string range $rowmenuid 0 7] $mainhead]]
9625 if {!$ok} return
9626 }
9627 nowbusy revert [mc "Reverting"]
9628 update
9629
9630 if [catch {exec git revert --no-edit $rowmenuid} err] {
9631 notbusy revert
9632 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9633 $err match files] {
9634 regsub {\n( |\t)+} $files "\n" files
9635 error_popup [mc "Revert failed because of local changes to\
9636 the following files:%s Please commit, reset or stash \
9637 your changes and try again." $files]
9638 } elseif [regexp {error: could not revert} $err] {
9639 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9640 Do you wish to run git citool to resolve it?"]] {
9641 # Force citool to read MERGE_MSG
9642 file delete [file join $gitdir "GITGUI_MSG"]
9643 exec_citool {} $rowmenuid
9644 }
9645 } else { error_popup $err }
9646 run updatecommits
9647 return
9648 }
9649
9650 set newhead [exec git rev-parse HEAD]
9651 if { $newhead eq $oldhead } {
9652 notbusy revert
9653 error_popup [mc "No changes committed"]
9654 return
9655 }
9656
9657 addnewchild $newhead $oldhead
9658
9659 if [commitinview $oldhead $curview] {
9660 # XXX this isn't right if we have a path limit...
9661 insertrow $newhead $oldhead $curview
9662 if {$mainhead ne {}} {
9663 movehead $newhead $mainhead
9664 movedhead $newhead $mainhead
9665 }
9666 set mainheadid $newhead
9667 redrawtags $oldhead
9668 redrawtags $newhead
9669 selbyid $newhead
9670 }
9671
9672 notbusy revert
9673}
9674
9675proc resethead {} {
9676 global mainhead rowmenuid confirm_ok resettype NS
9677
9678 set confirm_ok 0
9679 set w ".confirmreset"
9680 ttk_toplevel $w
9681 make_transient $w .
9682 wm title $w [mc "Confirm reset"]
9683 ${NS}::label $w.m -text \
9684 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9685 pack $w.m -side top -fill x -padx 20 -pady 20
9686 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9687 set resettype mixed
9688 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9689 -text [mc "Soft: Leave working tree and index untouched"]
9690 grid $w.f.soft -sticky w
9691 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9692 -text [mc "Mixed: Leave working tree untouched, reset index"]
9693 grid $w.f.mixed -sticky w
9694 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9695 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9696 grid $w.f.hard -sticky w
9697 pack $w.f -side top -fill x -padx 4
9698 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9699 pack $w.ok -side left -fill x -padx 20 -pady 20
9700 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9701 bind $w <Key-Escape> [list destroy $w]
9702 pack $w.cancel -side right -fill x -padx 20 -pady 20
9703 bind $w <Visibility> "grab $w; focus $w"
9704 tkwait window $w
9705 if {!$confirm_ok} return
9706 if {[catch {set fd [open \
9707 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9708 error_popup $err
9709 } else {
9710 dohidelocalchanges
9711 filerun $fd [list readresetstat $fd]
9712 nowbusy reset [mc "Resetting"]
9713 selbyid $rowmenuid
9714 }
9715}
9716
9717proc readresetstat {fd} {
9718 global mainhead mainheadid showlocalchanges rprogcoord
9719
9720 if {[gets $fd line] >= 0} {
9721 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9722 set rprogcoord [expr {1.0 * $m / $n}]
9723 adjustprogress
9724 }
9725 return 1
9726 }
9727 set rprogcoord 0
9728 adjustprogress
9729 notbusy reset
9730 if {[catch {close $fd} err]} {
9731 error_popup $err
9732 }
9733 set oldhead $mainheadid
9734 set newhead [exec git rev-parse HEAD]
9735 if {$newhead ne $oldhead} {
9736 movehead $newhead $mainhead
9737 movedhead $newhead $mainhead
9738 set mainheadid $newhead
9739 redrawtags $oldhead
9740 redrawtags $newhead
9741 }
9742 if {$showlocalchanges} {
9743 doshowlocalchanges
9744 }
9745 return 0
9746}
9747
9748# context menu for a head
9749proc headmenu {x y id head} {
9750 global headmenuid headmenuhead headctxmenu mainhead
9751
9752 stopfinding
9753 set headmenuid $id
9754 set headmenuhead $head
9755 set state normal
9756 if {[string match "remotes/*" $head]} {
9757 set state disabled
9758 }
9759 if {$head eq $mainhead} {
9760 set state disabled
9761 }
9762 $headctxmenu entryconfigure 0 -state $state
9763 $headctxmenu entryconfigure 1 -state $state
9764 tk_popup $headctxmenu $x $y
9765}
9766
9767proc cobranch {} {
9768 global headmenuid headmenuhead headids
9769 global showlocalchanges
9770
9771 # check the tree is clean first??
9772 nowbusy checkout [mc "Checking out"]
9773 update
9774 dohidelocalchanges
9775 if {[catch {
9776 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9777 } err]} {
9778 notbusy checkout
9779 error_popup $err
9780 if {$showlocalchanges} {
9781 dodiffindex
9782 }
9783 } else {
9784 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9785 }
9786}
9787
9788proc readcheckoutstat {fd newhead newheadid} {
9789 global mainhead mainheadid headids showlocalchanges progresscoords
9790 global viewmainheadid curview
9791
9792 if {[gets $fd line] >= 0} {
9793 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9794 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9795 adjustprogress
9796 }
9797 return 1
9798 }
9799 set progresscoords {0 0}
9800 adjustprogress
9801 notbusy checkout
9802 if {[catch {close $fd} err]} {
9803 error_popup $err
9804 }
9805 set oldmainid $mainheadid
9806 set mainhead $newhead
9807 set mainheadid $newheadid
9808 set viewmainheadid($curview) $newheadid
9809 redrawtags $oldmainid
9810 redrawtags $newheadid
9811 selbyid $newheadid
9812 if {$showlocalchanges} {
9813 dodiffindex
9814 }
9815}
9816
9817proc rmbranch {} {
9818 global headmenuid headmenuhead mainhead
9819 global idheads
9820
9821 set head $headmenuhead
9822 set id $headmenuid
9823 # this check shouldn't be needed any more...
9824 if {$head eq $mainhead} {
9825 error_popup [mc "Cannot delete the currently checked-out branch"]
9826 return
9827 }
9828 set dheads [descheads $id]
9829 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9830 # the stuff on this branch isn't on any other branch
9831 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9832 branch.\nReally delete branch %s?" $head $head]]} return
9833 }
9834 nowbusy rmbranch
9835 update
9836 if {[catch {exec git branch -D $head} err]} {
9837 notbusy rmbranch
9838 error_popup $err
9839 return
9840 }
9841 removehead $id $head
9842 removedhead $id $head
9843 redrawtags $id
9844 notbusy rmbranch
9845 dispneartags 0
9846 run refill_reflist
9847}
9848
9849# Display a list of tags and heads
9850proc showrefs {} {
9851 global showrefstop bgcolor fgcolor selectbgcolor NS
9852 global bglist fglist reflistfilter reflist maincursor
9853
9854 set top .showrefs
9855 set showrefstop $top
9856 if {[winfo exists $top]} {
9857 raise $top
9858 refill_reflist
9859 return
9860 }
9861 ttk_toplevel $top
9862 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9863 make_transient $top .
9864 text $top.list -background $bgcolor -foreground $fgcolor \
9865 -selectbackground $selectbgcolor -font mainfont \
9866 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9867 -width 30 -height 20 -cursor $maincursor \
9868 -spacing1 1 -spacing3 1 -state disabled
9869 $top.list tag configure highlight -background $selectbgcolor
9870 if {![lsearch -exact $bglist $top.list]} {
9871 lappend bglist $top.list
9872 lappend fglist $top.list
9873 }
9874 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9875 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9876 grid $top.list $top.ysb -sticky nsew
9877 grid $top.xsb x -sticky ew
9878 ${NS}::frame $top.f
9879 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9880 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9881 set reflistfilter "*"
9882 trace add variable reflistfilter write reflistfilter_change
9883 pack $top.f.e -side right -fill x -expand 1
9884 pack $top.f.l -side left
9885 grid $top.f - -sticky ew -pady 2
9886 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9887 bind $top <Key-Escape> [list destroy $top]
9888 grid $top.close -
9889 grid columnconfigure $top 0 -weight 1
9890 grid rowconfigure $top 0 -weight 1
9891 bind $top.list <1> {break}
9892 bind $top.list <B1-Motion> {break}
9893 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9894 set reflist {}
9895 refill_reflist
9896}
9897
9898proc sel_reflist {w x y} {
9899 global showrefstop reflist headids tagids otherrefids
9900
9901 if {![winfo exists $showrefstop]} return
9902 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9903 set ref [lindex $reflist [expr {$l-1}]]
9904 set n [lindex $ref 0]
9905 switch -- [lindex $ref 1] {
9906 "H" {selbyid $headids($n)}
9907 "T" {selbyid $tagids($n)}
9908 "o" {selbyid $otherrefids($n)}
9909 }
9910 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9911}
9912
9913proc unsel_reflist {} {
9914 global showrefstop
9915
9916 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9917 $showrefstop.list tag remove highlight 0.0 end
9918}
9919
9920proc reflistfilter_change {n1 n2 op} {
9921 global reflistfilter
9922
9923 after cancel refill_reflist
9924 after 200 refill_reflist
9925}
9926
9927proc refill_reflist {} {
9928 global reflist reflistfilter showrefstop headids tagids otherrefids
9929 global curview
9930
9931 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9932 set refs {}
9933 foreach n [array names headids] {
9934 if {[string match $reflistfilter $n]} {
9935 if {[commitinview $headids($n) $curview]} {
9936 lappend refs [list $n H]
9937 } else {
9938 interestedin $headids($n) {run refill_reflist}
9939 }
9940 }
9941 }
9942 foreach n [array names tagids] {
9943 if {[string match $reflistfilter $n]} {
9944 if {[commitinview $tagids($n) $curview]} {
9945 lappend refs [list $n T]
9946 } else {
9947 interestedin $tagids($n) {run refill_reflist}
9948 }
9949 }
9950 }
9951 foreach n [array names otherrefids] {
9952 if {[string match $reflistfilter $n]} {
9953 if {[commitinview $otherrefids($n) $curview]} {
9954 lappend refs [list $n o]
9955 } else {
9956 interestedin $otherrefids($n) {run refill_reflist}
9957 }
9958 }
9959 }
9960 set refs [lsort -index 0 $refs]
9961 if {$refs eq $reflist} return
9962
9963 # Update the contents of $showrefstop.list according to the
9964 # differences between $reflist (old) and $refs (new)
9965 $showrefstop.list conf -state normal
9966 $showrefstop.list insert end "\n"
9967 set i 0
9968 set j 0
9969 while {$i < [llength $reflist] || $j < [llength $refs]} {
9970 if {$i < [llength $reflist]} {
9971 if {$j < [llength $refs]} {
9972 set cmp [string compare [lindex $reflist $i 0] \
9973 [lindex $refs $j 0]]
9974 if {$cmp == 0} {
9975 set cmp [string compare [lindex $reflist $i 1] \
9976 [lindex $refs $j 1]]
9977 }
9978 } else {
9979 set cmp -1
9980 }
9981 } else {
9982 set cmp 1
9983 }
9984 switch -- $cmp {
9985 -1 {
9986 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9987 incr i
9988 }
9989 0 {
9990 incr i
9991 incr j
9992 }
9993 1 {
9994 set l [expr {$j + 1}]
9995 $showrefstop.list image create $l.0 -align baseline \
9996 -image reficon-[lindex $refs $j 1] -padx 2
9997 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9998 incr j
9999 }
10000 }
10001 }
10002 set reflist $refs
10003 # delete last newline
10004 $showrefstop.list delete end-2c end-1c
10005 $showrefstop.list conf -state disabled
10006}
10007
10008# Stuff for finding nearby tags
10009proc getallcommits {} {
10010 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10011 global idheads idtags idotherrefs allparents tagobjid
10012 global gitdir
10013
10014 if {![info exists allcommits]} {
10015 set nextarc 0
10016 set allcommits 0
10017 set seeds {}
10018 set allcwait 0
10019 set cachedarcs 0
10020 set allccache [file join $gitdir "gitk.cache"]
10021 if {![catch {
10022 set f [open $allccache r]
10023 set allcwait 1
10024 getcache $f
10025 }]} return
10026 }
10027
10028 if {$allcwait} {
10029 return
10030 }
10031 set cmd [list | git rev-list --parents]
10032 set allcupdate [expr {$seeds ne {}}]
10033 if {!$allcupdate} {
10034 set ids "--all"
10035 } else {
10036 set refs [concat [array names idheads] [array names idtags] \
10037 [array names idotherrefs]]
10038 set ids {}
10039 set tagobjs {}
10040 foreach name [array names tagobjid] {
10041 lappend tagobjs $tagobjid($name)
10042 }
10043 foreach id [lsort -unique $refs] {
10044 if {![info exists allparents($id)] &&
10045 [lsearch -exact $tagobjs $id] < 0} {
10046 lappend ids $id
10047 }
10048 }
10049 if {$ids ne {}} {
10050 foreach id $seeds {
10051 lappend ids "^$id"
10052 }
10053 }
10054 }
10055 if {$ids ne {}} {
10056 set fd [open [concat $cmd $ids] r]
10057 fconfigure $fd -blocking 0
10058 incr allcommits
10059 nowbusy allcommits
10060 filerun $fd [list getallclines $fd]
10061 } else {
10062 dispneartags 0
10063 }
10064}
10065
10066# Since most commits have 1 parent and 1 child, we group strings of
10067# such commits into "arcs" joining branch/merge points (BMPs), which
10068# are commits that either don't have 1 parent or don't have 1 child.
10069#
10070# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10071# arcout(id) - outgoing arcs for BMP
10072# arcids(a) - list of IDs on arc including end but not start
10073# arcstart(a) - BMP ID at start of arc
10074# arcend(a) - BMP ID at end of arc
10075# growing(a) - arc a is still growing
10076# arctags(a) - IDs out of arcids (excluding end) that have tags
10077# archeads(a) - IDs out of arcids (excluding end) that have heads
10078# The start of an arc is at the descendent end, so "incoming" means
10079# coming from descendents, and "outgoing" means going towards ancestors.
10080
10081proc getallclines {fd} {
10082 global allparents allchildren idtags idheads nextarc
10083 global arcnos arcids arctags arcout arcend arcstart archeads growing
10084 global seeds allcommits cachedarcs allcupdate
10085
10086 set nid 0
10087 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10088 set id [lindex $line 0]
10089 if {[info exists allparents($id)]} {
10090 # seen it already
10091 continue
10092 }
10093 set cachedarcs 0
10094 set olds [lrange $line 1 end]
10095 set allparents($id) $olds
10096 if {![info exists allchildren($id)]} {
10097 set allchildren($id) {}
10098 set arcnos($id) {}
10099 lappend seeds $id
10100 } else {
10101 set a $arcnos($id)
10102 if {[llength $olds] == 1 && [llength $a] == 1} {
10103 lappend arcids($a) $id
10104 if {[info exists idtags($id)]} {
10105 lappend arctags($a) $id
10106 }
10107 if {[info exists idheads($id)]} {
10108 lappend archeads($a) $id
10109 }
10110 if {[info exists allparents($olds)]} {
10111 # seen parent already
10112 if {![info exists arcout($olds)]} {
10113 splitarc $olds
10114 }
10115 lappend arcids($a) $olds
10116 set arcend($a) $olds
10117 unset growing($a)
10118 }
10119 lappend allchildren($olds) $id
10120 lappend arcnos($olds) $a
10121 continue
10122 }
10123 }
10124 foreach a $arcnos($id) {
10125 lappend arcids($a) $id
10126 set arcend($a) $id
10127 unset growing($a)
10128 }
10129
10130 set ao {}
10131 foreach p $olds {
10132 lappend allchildren($p) $id
10133 set a [incr nextarc]
10134 set arcstart($a) $id
10135 set archeads($a) {}
10136 set arctags($a) {}
10137 set archeads($a) {}
10138 set arcids($a) {}
10139 lappend ao $a
10140 set growing($a) 1
10141 if {[info exists allparents($p)]} {
10142 # seen it already, may need to make a new branch
10143 if {![info exists arcout($p)]} {
10144 splitarc $p
10145 }
10146 lappend arcids($a) $p
10147 set arcend($a) $p
10148 unset growing($a)
10149 }
10150 lappend arcnos($p) $a
10151 }
10152 set arcout($id) $ao
10153 }
10154 if {$nid > 0} {
10155 global cached_dheads cached_dtags cached_atags
10156 unset -nocomplain cached_dheads
10157 unset -nocomplain cached_dtags
10158 unset -nocomplain cached_atags
10159 }
10160 if {![eof $fd]} {
10161 return [expr {$nid >= 1000? 2: 1}]
10162 }
10163 set cacheok 1
10164 if {[catch {
10165 fconfigure $fd -blocking 1
10166 close $fd
10167 } err]} {
10168 # got an error reading the list of commits
10169 # if we were updating, try rereading the whole thing again
10170 if {$allcupdate} {
10171 incr allcommits -1
10172 dropcache $err
10173 return
10174 }
10175 error_popup "[mc "Error reading commit topology information;\
10176 branch and preceding/following tag information\
10177 will be incomplete."]\n($err)"
10178 set cacheok 0
10179 }
10180 if {[incr allcommits -1] == 0} {
10181 notbusy allcommits
10182 if {$cacheok} {
10183 run savecache
10184 }
10185 }
10186 dispneartags 0
10187 return 0
10188}
10189
10190proc recalcarc {a} {
10191 global arctags archeads arcids idtags idheads
10192
10193 set at {}
10194 set ah {}
10195 foreach id [lrange $arcids($a) 0 end-1] {
10196 if {[info exists idtags($id)]} {
10197 lappend at $id
10198 }
10199 if {[info exists idheads($id)]} {
10200 lappend ah $id
10201 }
10202 }
10203 set arctags($a) $at
10204 set archeads($a) $ah
10205}
10206
10207proc splitarc {p} {
10208 global arcnos arcids nextarc arctags archeads idtags idheads
10209 global arcstart arcend arcout allparents growing
10210
10211 set a $arcnos($p)
10212 if {[llength $a] != 1} {
10213 puts "oops splitarc called but [llength $a] arcs already"
10214 return
10215 }
10216 set a [lindex $a 0]
10217 set i [lsearch -exact $arcids($a) $p]
10218 if {$i < 0} {
10219 puts "oops splitarc $p not in arc $a"
10220 return
10221 }
10222 set na [incr nextarc]
10223 if {[info exists arcend($a)]} {
10224 set arcend($na) $arcend($a)
10225 } else {
10226 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10227 set j [lsearch -exact $arcnos($l) $a]
10228 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10229 }
10230 set tail [lrange $arcids($a) [expr {$i+1}] end]
10231 set arcids($a) [lrange $arcids($a) 0 $i]
10232 set arcend($a) $p
10233 set arcstart($na) $p
10234 set arcout($p) $na
10235 set arcids($na) $tail
10236 if {[info exists growing($a)]} {
10237 set growing($na) 1
10238 unset growing($a)
10239 }
10240
10241 foreach id $tail {
10242 if {[llength $arcnos($id)] == 1} {
10243 set arcnos($id) $na
10244 } else {
10245 set j [lsearch -exact $arcnos($id) $a]
10246 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10247 }
10248 }
10249
10250 # reconstruct tags and heads lists
10251 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10252 recalcarc $a
10253 recalcarc $na
10254 } else {
10255 set arctags($na) {}
10256 set archeads($na) {}
10257 }
10258}
10259
10260# Update things for a new commit added that is a child of one
10261# existing commit. Used when cherry-picking.
10262proc addnewchild {id p} {
10263 global allparents allchildren idtags nextarc
10264 global arcnos arcids arctags arcout arcend arcstart archeads growing
10265 global seeds allcommits
10266
10267 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10268 set allparents($id) [list $p]
10269 set allchildren($id) {}
10270 set arcnos($id) {}
10271 lappend seeds $id
10272 lappend allchildren($p) $id
10273 set a [incr nextarc]
10274 set arcstart($a) $id
10275 set archeads($a) {}
10276 set arctags($a) {}
10277 set arcids($a) [list $p]
10278 set arcend($a) $p
10279 if {![info exists arcout($p)]} {
10280 splitarc $p
10281 }
10282 lappend arcnos($p) $a
10283 set arcout($id) [list $a]
10284}
10285
10286# This implements a cache for the topology information.
10287# The cache saves, for each arc, the start and end of the arc,
10288# the ids on the arc, and the outgoing arcs from the end.
10289proc readcache {f} {
10290 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10291 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10292 global allcwait
10293
10294 set a $nextarc
10295 set lim $cachedarcs
10296 if {$lim - $a > 500} {
10297 set lim [expr {$a + 500}]
10298 }
10299 if {[catch {
10300 if {$a == $lim} {
10301 # finish reading the cache and setting up arctags, etc.
10302 set line [gets $f]
10303 if {$line ne "1"} {error "bad final version"}
10304 close $f
10305 foreach id [array names idtags] {
10306 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10307 [llength $allparents($id)] == 1} {
10308 set a [lindex $arcnos($id) 0]
10309 if {$arctags($a) eq {}} {
10310 recalcarc $a
10311 }
10312 }
10313 }
10314 foreach id [array names idheads] {
10315 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10316 [llength $allparents($id)] == 1} {
10317 set a [lindex $arcnos($id) 0]
10318 if {$archeads($a) eq {}} {
10319 recalcarc $a
10320 }
10321 }
10322 }
10323 foreach id [lsort -unique $possible_seeds] {
10324 if {$arcnos($id) eq {}} {
10325 lappend seeds $id
10326 }
10327 }
10328 set allcwait 0
10329 } else {
10330 while {[incr a] <= $lim} {
10331 set line [gets $f]
10332 if {[llength $line] != 3} {error "bad line"}
10333 set s [lindex $line 0]
10334 set arcstart($a) $s
10335 lappend arcout($s) $a
10336 if {![info exists arcnos($s)]} {
10337 lappend possible_seeds $s
10338 set arcnos($s) {}
10339 }
10340 set e [lindex $line 1]
10341 if {$e eq {}} {
10342 set growing($a) 1
10343 } else {
10344 set arcend($a) $e
10345 if {![info exists arcout($e)]} {
10346 set arcout($e) {}
10347 }
10348 }
10349 set arcids($a) [lindex $line 2]
10350 foreach id $arcids($a) {
10351 lappend allparents($s) $id
10352 set s $id
10353 lappend arcnos($id) $a
10354 }
10355 if {![info exists allparents($s)]} {
10356 set allparents($s) {}
10357 }
10358 set arctags($a) {}
10359 set archeads($a) {}
10360 }
10361 set nextarc [expr {$a - 1}]
10362 }
10363 } err]} {
10364 dropcache $err
10365 return 0
10366 }
10367 if {!$allcwait} {
10368 getallcommits
10369 }
10370 return $allcwait
10371}
10372
10373proc getcache {f} {
10374 global nextarc cachedarcs possible_seeds
10375
10376 if {[catch {
10377 set line [gets $f]
10378 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10379 # make sure it's an integer
10380 set cachedarcs [expr {int([lindex $line 1])}]
10381 if {$cachedarcs < 0} {error "bad number of arcs"}
10382 set nextarc 0
10383 set possible_seeds {}
10384 run readcache $f
10385 } err]} {
10386 dropcache $err
10387 }
10388 return 0
10389}
10390
10391proc dropcache {err} {
10392 global allcwait nextarc cachedarcs seeds
10393
10394 #puts "dropping cache ($err)"
10395 foreach v {arcnos arcout arcids arcstart arcend growing \
10396 arctags archeads allparents allchildren} {
10397 global $v
10398 unset -nocomplain $v
10399 }
10400 set allcwait 0
10401 set nextarc 0
10402 set cachedarcs 0
10403 set seeds {}
10404 getallcommits
10405}
10406
10407proc writecache {f} {
10408 global cachearc cachedarcs allccache
10409 global arcstart arcend arcnos arcids arcout
10410
10411 set a $cachearc
10412 set lim $cachedarcs
10413 if {$lim - $a > 1000} {
10414 set lim [expr {$a + 1000}]
10415 }
10416 if {[catch {
10417 while {[incr a] <= $lim} {
10418 if {[info exists arcend($a)]} {
10419 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10420 } else {
10421 puts $f [list $arcstart($a) {} $arcids($a)]
10422 }
10423 }
10424 } err]} {
10425 catch {close $f}
10426 catch {file delete $allccache}
10427 #puts "writing cache failed ($err)"
10428 return 0
10429 }
10430 set cachearc [expr {$a - 1}]
10431 if {$a > $cachedarcs} {
10432 puts $f "1"
10433 close $f
10434 return 0
10435 }
10436 return 1
10437}
10438
10439proc savecache {} {
10440 global nextarc cachedarcs cachearc allccache
10441
10442 if {$nextarc == $cachedarcs} return
10443 set cachearc 0
10444 set cachedarcs $nextarc
10445 catch {
10446 set f [open $allccache w]
10447 puts $f [list 1 $cachedarcs]
10448 run writecache $f
10449 }
10450}
10451
10452# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10453# or 0 if neither is true.
10454proc anc_or_desc {a b} {
10455 global arcout arcstart arcend arcnos cached_isanc
10456
10457 if {$arcnos($a) eq $arcnos($b)} {
10458 # Both are on the same arc(s); either both are the same BMP,
10459 # or if one is not a BMP, the other is also not a BMP or is
10460 # the BMP at end of the arc (and it only has 1 incoming arc).
10461 # Or both can be BMPs with no incoming arcs.
10462 if {$a eq $b || $arcnos($a) eq {}} {
10463 return 0
10464 }
10465 # assert {[llength $arcnos($a)] == 1}
10466 set arc [lindex $arcnos($a) 0]
10467 set i [lsearch -exact $arcids($arc) $a]
10468 set j [lsearch -exact $arcids($arc) $b]
10469 if {$i < 0 || $i > $j} {
10470 return 1
10471 } else {
10472 return -1
10473 }
10474 }
10475
10476 if {![info exists arcout($a)]} {
10477 set arc [lindex $arcnos($a) 0]
10478 if {[info exists arcend($arc)]} {
10479 set aend $arcend($arc)
10480 } else {
10481 set aend {}
10482 }
10483 set a $arcstart($arc)
10484 } else {
10485 set aend $a
10486 }
10487 if {![info exists arcout($b)]} {
10488 set arc [lindex $arcnos($b) 0]
10489 if {[info exists arcend($arc)]} {
10490 set bend $arcend($arc)
10491 } else {
10492 set bend {}
10493 }
10494 set b $arcstart($arc)
10495 } else {
10496 set bend $b
10497 }
10498 if {$a eq $bend} {
10499 return 1
10500 }
10501 if {$b eq $aend} {
10502 return -1
10503 }
10504 if {[info exists cached_isanc($a,$bend)]} {
10505 if {$cached_isanc($a,$bend)} {
10506 return 1
10507 }
10508 }
10509 if {[info exists cached_isanc($b,$aend)]} {
10510 if {$cached_isanc($b,$aend)} {
10511 return -1
10512 }
10513 if {[info exists cached_isanc($a,$bend)]} {
10514 return 0
10515 }
10516 }
10517
10518 set todo [list $a $b]
10519 set anc($a) a
10520 set anc($b) b
10521 for {set i 0} {$i < [llength $todo]} {incr i} {
10522 set x [lindex $todo $i]
10523 if {$anc($x) eq {}} {
10524 continue
10525 }
10526 foreach arc $arcnos($x) {
10527 set xd $arcstart($arc)
10528 if {$xd eq $bend} {
10529 set cached_isanc($a,$bend) 1
10530 set cached_isanc($b,$aend) 0
10531 return 1
10532 } elseif {$xd eq $aend} {
10533 set cached_isanc($b,$aend) 1
10534 set cached_isanc($a,$bend) 0
10535 return -1
10536 }
10537 if {![info exists anc($xd)]} {
10538 set anc($xd) $anc($x)
10539 lappend todo $xd
10540 } elseif {$anc($xd) ne $anc($x)} {
10541 set anc($xd) {}
10542 }
10543 }
10544 }
10545 set cached_isanc($a,$bend) 0
10546 set cached_isanc($b,$aend) 0
10547 return 0
10548}
10549
10550# This identifies whether $desc has an ancestor that is
10551# a growing tip of the graph and which is not an ancestor of $anc
10552# and returns 0 if so and 1 if not.
10553# If we subsequently discover a tag on such a growing tip, and that
10554# turns out to be a descendent of $anc (which it could, since we
10555# don't necessarily see children before parents), then $desc
10556# isn't a good choice to display as a descendent tag of
10557# $anc (since it is the descendent of another tag which is
10558# a descendent of $anc). Similarly, $anc isn't a good choice to
10559# display as a ancestor tag of $desc.
10560#
10561proc is_certain {desc anc} {
10562 global arcnos arcout arcstart arcend growing problems
10563
10564 set certain {}
10565 if {[llength $arcnos($anc)] == 1} {
10566 # tags on the same arc are certain
10567 if {$arcnos($desc) eq $arcnos($anc)} {
10568 return 1
10569 }
10570 if {![info exists arcout($anc)]} {
10571 # if $anc is partway along an arc, use the start of the arc instead
10572 set a [lindex $arcnos($anc) 0]
10573 set anc $arcstart($a)
10574 }
10575 }
10576 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10577 set x $desc
10578 } else {
10579 set a [lindex $arcnos($desc) 0]
10580 set x $arcend($a)
10581 }
10582 if {$x == $anc} {
10583 return 1
10584 }
10585 set anclist [list $x]
10586 set dl($x) 1
10587 set nnh 1
10588 set ngrowanc 0
10589 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10590 set x [lindex $anclist $i]
10591 if {$dl($x)} {
10592 incr nnh -1
10593 }
10594 set done($x) 1
10595 foreach a $arcout($x) {
10596 if {[info exists growing($a)]} {
10597 if {![info exists growanc($x)] && $dl($x)} {
10598 set growanc($x) 1
10599 incr ngrowanc
10600 }
10601 } else {
10602 set y $arcend($a)
10603 if {[info exists dl($y)]} {
10604 if {$dl($y)} {
10605 if {!$dl($x)} {
10606 set dl($y) 0
10607 if {![info exists done($y)]} {
10608 incr nnh -1
10609 }
10610 if {[info exists growanc($x)]} {
10611 incr ngrowanc -1
10612 }
10613 set xl [list $y]
10614 for {set k 0} {$k < [llength $xl]} {incr k} {
10615 set z [lindex $xl $k]
10616 foreach c $arcout($z) {
10617 if {[info exists arcend($c)]} {
10618 set v $arcend($c)
10619 if {[info exists dl($v)] && $dl($v)} {
10620 set dl($v) 0
10621 if {![info exists done($v)]} {
10622 incr nnh -1
10623 }
10624 if {[info exists growanc($v)]} {
10625 incr ngrowanc -1
10626 }
10627 lappend xl $v
10628 }
10629 }
10630 }
10631 }
10632 }
10633 }
10634 } elseif {$y eq $anc || !$dl($x)} {
10635 set dl($y) 0
10636 lappend anclist $y
10637 } else {
10638 set dl($y) 1
10639 lappend anclist $y
10640 incr nnh
10641 }
10642 }
10643 }
10644 }
10645 foreach x [array names growanc] {
10646 if {$dl($x)} {
10647 return 0
10648 }
10649 return 0
10650 }
10651 return 1
10652}
10653
10654proc validate_arctags {a} {
10655 global arctags idtags
10656
10657 set i -1
10658 set na $arctags($a)
10659 foreach id $arctags($a) {
10660 incr i
10661 if {![info exists idtags($id)]} {
10662 set na [lreplace $na $i $i]
10663 incr i -1
10664 }
10665 }
10666 set arctags($a) $na
10667}
10668
10669proc validate_archeads {a} {
10670 global archeads idheads
10671
10672 set i -1
10673 set na $archeads($a)
10674 foreach id $archeads($a) {
10675 incr i
10676 if {![info exists idheads($id)]} {
10677 set na [lreplace $na $i $i]
10678 incr i -1
10679 }
10680 }
10681 set archeads($a) $na
10682}
10683
10684# Return the list of IDs that have tags that are descendents of id,
10685# ignoring IDs that are descendents of IDs already reported.
10686proc desctags {id} {
10687 global arcnos arcstart arcids arctags idtags allparents
10688 global growing cached_dtags
10689
10690 if {![info exists allparents($id)]} {
10691 return {}
10692 }
10693 set t1 [clock clicks -milliseconds]
10694 set argid $id
10695 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10696 # part-way along an arc; check that arc first
10697 set a [lindex $arcnos($id) 0]
10698 if {$arctags($a) ne {}} {
10699 validate_arctags $a
10700 set i [lsearch -exact $arcids($a) $id]
10701 set tid {}
10702 foreach t $arctags($a) {
10703 set j [lsearch -exact $arcids($a) $t]
10704 if {$j >= $i} break
10705 set tid $t
10706 }
10707 if {$tid ne {}} {
10708 return $tid
10709 }
10710 }
10711 set id $arcstart($a)
10712 if {[info exists idtags($id)]} {
10713 return $id
10714 }
10715 }
10716 if {[info exists cached_dtags($id)]} {
10717 return $cached_dtags($id)
10718 }
10719
10720 set origid $id
10721 set todo [list $id]
10722 set queued($id) 1
10723 set nc 1
10724 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10725 set id [lindex $todo $i]
10726 set done($id) 1
10727 set ta [info exists hastaggedancestor($id)]
10728 if {!$ta} {
10729 incr nc -1
10730 }
10731 # ignore tags on starting node
10732 if {!$ta && $i > 0} {
10733 if {[info exists idtags($id)]} {
10734 set tagloc($id) $id
10735 set ta 1
10736 } elseif {[info exists cached_dtags($id)]} {
10737 set tagloc($id) $cached_dtags($id)
10738 set ta 1
10739 }
10740 }
10741 foreach a $arcnos($id) {
10742 set d $arcstart($a)
10743 if {!$ta && $arctags($a) ne {}} {
10744 validate_arctags $a
10745 if {$arctags($a) ne {}} {
10746 lappend tagloc($id) [lindex $arctags($a) end]
10747 }
10748 }
10749 if {$ta || $arctags($a) ne {}} {
10750 set tomark [list $d]
10751 for {set j 0} {$j < [llength $tomark]} {incr j} {
10752 set dd [lindex $tomark $j]
10753 if {![info exists hastaggedancestor($dd)]} {
10754 if {[info exists done($dd)]} {
10755 foreach b $arcnos($dd) {
10756 lappend tomark $arcstart($b)
10757 }
10758 if {[info exists tagloc($dd)]} {
10759 unset tagloc($dd)
10760 }
10761 } elseif {[info exists queued($dd)]} {
10762 incr nc -1
10763 }
10764 set hastaggedancestor($dd) 1
10765 }
10766 }
10767 }
10768 if {![info exists queued($d)]} {
10769 lappend todo $d
10770 set queued($d) 1
10771 if {![info exists hastaggedancestor($d)]} {
10772 incr nc
10773 }
10774 }
10775 }
10776 }
10777 set tags {}
10778 foreach id [array names tagloc] {
10779 if {![info exists hastaggedancestor($id)]} {
10780 foreach t $tagloc($id) {
10781 if {[lsearch -exact $tags $t] < 0} {
10782 lappend tags $t
10783 }
10784 }
10785 }
10786 }
10787 set t2 [clock clicks -milliseconds]
10788 set loopix $i
10789
10790 # remove tags that are descendents of other tags
10791 for {set i 0} {$i < [llength $tags]} {incr i} {
10792 set a [lindex $tags $i]
10793 for {set j 0} {$j < $i} {incr j} {
10794 set b [lindex $tags $j]
10795 set r [anc_or_desc $a $b]
10796 if {$r == 1} {
10797 set tags [lreplace $tags $j $j]
10798 incr j -1
10799 incr i -1
10800 } elseif {$r == -1} {
10801 set tags [lreplace $tags $i $i]
10802 incr i -1
10803 break
10804 }
10805 }
10806 }
10807
10808 if {[array names growing] ne {}} {
10809 # graph isn't finished, need to check if any tag could get
10810 # eclipsed by another tag coming later. Simply ignore any
10811 # tags that could later get eclipsed.
10812 set ctags {}
10813 foreach t $tags {
10814 if {[is_certain $t $origid]} {
10815 lappend ctags $t
10816 }
10817 }
10818 if {$tags eq $ctags} {
10819 set cached_dtags($origid) $tags
10820 } else {
10821 set tags $ctags
10822 }
10823 } else {
10824 set cached_dtags($origid) $tags
10825 }
10826 set t3 [clock clicks -milliseconds]
10827 if {0 && $t3 - $t1 >= 100} {
10828 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10829 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10830 }
10831 return $tags
10832}
10833
10834proc anctags {id} {
10835 global arcnos arcids arcout arcend arctags idtags allparents
10836 global growing cached_atags
10837
10838 if {![info exists allparents($id)]} {
10839 return {}
10840 }
10841 set t1 [clock clicks -milliseconds]
10842 set argid $id
10843 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10844 # part-way along an arc; check that arc first
10845 set a [lindex $arcnos($id) 0]
10846 if {$arctags($a) ne {}} {
10847 validate_arctags $a
10848 set i [lsearch -exact $arcids($a) $id]
10849 foreach t $arctags($a) {
10850 set j [lsearch -exact $arcids($a) $t]
10851 if {$j > $i} {
10852 return $t
10853 }
10854 }
10855 }
10856 if {![info exists arcend($a)]} {
10857 return {}
10858 }
10859 set id $arcend($a)
10860 if {[info exists idtags($id)]} {
10861 return $id
10862 }
10863 }
10864 if {[info exists cached_atags($id)]} {
10865 return $cached_atags($id)
10866 }
10867
10868 set origid $id
10869 set todo [list $id]
10870 set queued($id) 1
10871 set taglist {}
10872 set nc 1
10873 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10874 set id [lindex $todo $i]
10875 set done($id) 1
10876 set td [info exists hastaggeddescendent($id)]
10877 if {!$td} {
10878 incr nc -1
10879 }
10880 # ignore tags on starting node
10881 if {!$td && $i > 0} {
10882 if {[info exists idtags($id)]} {
10883 set tagloc($id) $id
10884 set td 1
10885 } elseif {[info exists cached_atags($id)]} {
10886 set tagloc($id) $cached_atags($id)
10887 set td 1
10888 }
10889 }
10890 foreach a $arcout($id) {
10891 if {!$td && $arctags($a) ne {}} {
10892 validate_arctags $a
10893 if {$arctags($a) ne {}} {
10894 lappend tagloc($id) [lindex $arctags($a) 0]
10895 }
10896 }
10897 if {![info exists arcend($a)]} continue
10898 set d $arcend($a)
10899 if {$td || $arctags($a) ne {}} {
10900 set tomark [list $d]
10901 for {set j 0} {$j < [llength $tomark]} {incr j} {
10902 set dd [lindex $tomark $j]
10903 if {![info exists hastaggeddescendent($dd)]} {
10904 if {[info exists done($dd)]} {
10905 foreach b $arcout($dd) {
10906 if {[info exists arcend($b)]} {
10907 lappend tomark $arcend($b)
10908 }
10909 }
10910 if {[info exists tagloc($dd)]} {
10911 unset tagloc($dd)
10912 }
10913 } elseif {[info exists queued($dd)]} {
10914 incr nc -1
10915 }
10916 set hastaggeddescendent($dd) 1
10917 }
10918 }
10919 }
10920 if {![info exists queued($d)]} {
10921 lappend todo $d
10922 set queued($d) 1
10923 if {![info exists hastaggeddescendent($d)]} {
10924 incr nc
10925 }
10926 }
10927 }
10928 }
10929 set t2 [clock clicks -milliseconds]
10930 set loopix $i
10931 set tags {}
10932 foreach id [array names tagloc] {
10933 if {![info exists hastaggeddescendent($id)]} {
10934 foreach t $tagloc($id) {
10935 if {[lsearch -exact $tags $t] < 0} {
10936 lappend tags $t
10937 }
10938 }
10939 }
10940 }
10941
10942 # remove tags that are ancestors of other tags
10943 for {set i 0} {$i < [llength $tags]} {incr i} {
10944 set a [lindex $tags $i]
10945 for {set j 0} {$j < $i} {incr j} {
10946 set b [lindex $tags $j]
10947 set r [anc_or_desc $a $b]
10948 if {$r == -1} {
10949 set tags [lreplace $tags $j $j]
10950 incr j -1
10951 incr i -1
10952 } elseif {$r == 1} {
10953 set tags [lreplace $tags $i $i]
10954 incr i -1
10955 break
10956 }
10957 }
10958 }
10959
10960 if {[array names growing] ne {}} {
10961 # graph isn't finished, need to check if any tag could get
10962 # eclipsed by another tag coming later. Simply ignore any
10963 # tags that could later get eclipsed.
10964 set ctags {}
10965 foreach t $tags {
10966 if {[is_certain $origid $t]} {
10967 lappend ctags $t
10968 }
10969 }
10970 if {$tags eq $ctags} {
10971 set cached_atags($origid) $tags
10972 } else {
10973 set tags $ctags
10974 }
10975 } else {
10976 set cached_atags($origid) $tags
10977 }
10978 set t3 [clock clicks -milliseconds]
10979 if {0 && $t3 - $t1 >= 100} {
10980 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10981 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10982 }
10983 return $tags
10984}
10985
10986# Return the list of IDs that have heads that are descendents of id,
10987# including id itself if it has a head.
10988proc descheads {id} {
10989 global arcnos arcstart arcids archeads idheads cached_dheads
10990 global allparents arcout
10991
10992 if {![info exists allparents($id)]} {
10993 return {}
10994 }
10995 set aret {}
10996 if {![info exists arcout($id)]} {
10997 # part-way along an arc; check it first
10998 set a [lindex $arcnos($id) 0]
10999 if {$archeads($a) ne {}} {
11000 validate_archeads $a
11001 set i [lsearch -exact $arcids($a) $id]
11002 foreach t $archeads($a) {
11003 set j [lsearch -exact $arcids($a) $t]
11004 if {$j > $i} break
11005 lappend aret $t
11006 }
11007 }
11008 set id $arcstart($a)
11009 }
11010 set origid $id
11011 set todo [list $id]
11012 set seen($id) 1
11013 set ret {}
11014 for {set i 0} {$i < [llength $todo]} {incr i} {
11015 set id [lindex $todo $i]
11016 if {[info exists cached_dheads($id)]} {
11017 set ret [concat $ret $cached_dheads($id)]
11018 } else {
11019 if {[info exists idheads($id)]} {
11020 lappend ret $id
11021 }
11022 foreach a $arcnos($id) {
11023 if {$archeads($a) ne {}} {
11024 validate_archeads $a
11025 if {$archeads($a) ne {}} {
11026 set ret [concat $ret $archeads($a)]
11027 }
11028 }
11029 set d $arcstart($a)
11030 if {![info exists seen($d)]} {
11031 lappend todo $d
11032 set seen($d) 1
11033 }
11034 }
11035 }
11036 }
11037 set ret [lsort -unique $ret]
11038 set cached_dheads($origid) $ret
11039 return [concat $ret $aret]
11040}
11041
11042proc addedtag {id} {
11043 global arcnos arcout cached_dtags cached_atags
11044
11045 if {![info exists arcnos($id)]} return
11046 if {![info exists arcout($id)]} {
11047 recalcarc [lindex $arcnos($id) 0]
11048 }
11049 unset -nocomplain cached_dtags
11050 unset -nocomplain cached_atags
11051}
11052
11053proc addedhead {hid head} {
11054 global arcnos arcout cached_dheads
11055
11056 if {![info exists arcnos($hid)]} return
11057 if {![info exists arcout($hid)]} {
11058 recalcarc [lindex $arcnos($hid) 0]
11059 }
11060 unset -nocomplain cached_dheads
11061}
11062
11063proc removedhead {hid head} {
11064 global cached_dheads
11065
11066 unset -nocomplain cached_dheads
11067}
11068
11069proc movedhead {hid head} {
11070 global arcnos arcout cached_dheads
11071
11072 if {![info exists arcnos($hid)]} return
11073 if {![info exists arcout($hid)]} {
11074 recalcarc [lindex $arcnos($hid) 0]
11075 }
11076 unset -nocomplain cached_dheads
11077}
11078
11079proc changedrefs {} {
11080 global cached_dheads cached_dtags cached_atags cached_tagcontent
11081 global arctags archeads arcnos arcout idheads idtags
11082
11083 foreach id [concat [array names idheads] [array names idtags]] {
11084 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11085 set a [lindex $arcnos($id) 0]
11086 if {![info exists donearc($a)]} {
11087 recalcarc $a
11088 set donearc($a) 1
11089 }
11090 }
11091 }
11092 unset -nocomplain cached_tagcontent
11093 unset -nocomplain cached_dtags
11094 unset -nocomplain cached_atags
11095 unset -nocomplain cached_dheads
11096}
11097
11098proc rereadrefs {} {
11099 global idtags idheads idotherrefs mainheadid
11100
11101 set refids [concat [array names idtags] \
11102 [array names idheads] [array names idotherrefs]]
11103 foreach id $refids {
11104 if {![info exists ref($id)]} {
11105 set ref($id) [listrefs $id]
11106 }
11107 }
11108 set oldmainhead $mainheadid
11109 readrefs
11110 changedrefs
11111 set refids [lsort -unique [concat $refids [array names idtags] \
11112 [array names idheads] [array names idotherrefs]]]
11113 foreach id $refids {
11114 set v [listrefs $id]
11115 if {![info exists ref($id)] || $ref($id) != $v} {
11116 redrawtags $id
11117 }
11118 }
11119 if {$oldmainhead ne $mainheadid} {
11120 redrawtags $oldmainhead
11121 redrawtags $mainheadid
11122 }
11123 run refill_reflist
11124}
11125
11126proc listrefs {id} {
11127 global idtags idheads idotherrefs
11128
11129 set x {}
11130 if {[info exists idtags($id)]} {
11131 set x $idtags($id)
11132 }
11133 set y {}
11134 if {[info exists idheads($id)]} {
11135 set y $idheads($id)
11136 }
11137 set z {}
11138 if {[info exists idotherrefs($id)]} {
11139 set z $idotherrefs($id)
11140 }
11141 return [list $x $y $z]
11142}
11143
11144proc add_tag_ctext {tag} {
11145 global ctext cached_tagcontent tagids
11146
11147 if {![info exists cached_tagcontent($tag)]} {
11148 catch {
11149 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11150 }
11151 }
11152 $ctext insert end "[mc "Tag"]: $tag\n" bold
11153 if {[info exists cached_tagcontent($tag)]} {
11154 set text $cached_tagcontent($tag)
11155 } else {
11156 set text "[mc "Id"]: $tagids($tag)"
11157 }
11158 appendwithlinks $text {}
11159}
11160
11161proc showtag {tag isnew} {
11162 global ctext cached_tagcontent tagids linknum tagobjid
11163
11164 if {$isnew} {
11165 addtohistory [list showtag $tag 0] savectextpos
11166 }
11167 $ctext conf -state normal
11168 clear_ctext
11169 settabs 0
11170 set linknum 0
11171 add_tag_ctext $tag
11172 maybe_scroll_ctext 1
11173 $ctext conf -state disabled
11174 init_flist {}
11175}
11176
11177proc showtags {id isnew} {
11178 global idtags ctext linknum
11179
11180 if {$isnew} {
11181 addtohistory [list showtags $id 0] savectextpos
11182 }
11183 $ctext conf -state normal
11184 clear_ctext
11185 settabs 0
11186 set linknum 0
11187 set sep {}
11188 foreach tag $idtags($id) {
11189 $ctext insert end $sep
11190 add_tag_ctext $tag
11191 set sep "\n\n"
11192 }
11193 maybe_scroll_ctext 1
11194 $ctext conf -state disabled
11195 init_flist {}
11196}
11197
11198proc doquit {} {
11199 global stopped
11200 global gitktmpdir
11201
11202 set stopped 100
11203 savestuff .
11204 destroy .
11205
11206 if {[info exists gitktmpdir]} {
11207 catch {file delete -force $gitktmpdir}
11208 }
11209}
11210
11211proc mkfontdisp {font top which} {
11212 global fontattr fontpref $font NS use_ttk
11213
11214 set fontpref($font) [set $font]
11215 ${NS}::button $top.${font}but -text $which \
11216 -command [list choosefont $font $which]
11217 ${NS}::label $top.$font -relief flat -font $font \
11218 -text $fontattr($font,family) -justify left
11219 grid x $top.${font}but $top.$font -sticky w
11220}
11221
11222proc choosefont {font which} {
11223 global fontparam fontlist fonttop fontattr
11224 global prefstop NS
11225
11226 set fontparam(which) $which
11227 set fontparam(font) $font
11228 set fontparam(family) [font actual $font -family]
11229 set fontparam(size) $fontattr($font,size)
11230 set fontparam(weight) $fontattr($font,weight)
11231 set fontparam(slant) $fontattr($font,slant)
11232 set top .gitkfont
11233 set fonttop $top
11234 if {![winfo exists $top]} {
11235 font create sample
11236 eval font config sample [font actual $font]
11237 ttk_toplevel $top
11238 make_transient $top $prefstop
11239 wm title $top [mc "Gitk font chooser"]
11240 ${NS}::label $top.l -textvariable fontparam(which)
11241 pack $top.l -side top
11242 set fontlist [lsort [font families]]
11243 ${NS}::frame $top.f
11244 listbox $top.f.fam -listvariable fontlist \
11245 -yscrollcommand [list $top.f.sb set]
11246 bind $top.f.fam <<ListboxSelect>> selfontfam
11247 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11248 pack $top.f.sb -side right -fill y
11249 pack $top.f.fam -side left -fill both -expand 1
11250 pack $top.f -side top -fill both -expand 1
11251 ${NS}::frame $top.g
11252 spinbox $top.g.size -from 4 -to 40 -width 4 \
11253 -textvariable fontparam(size) \
11254 -validatecommand {string is integer -strict %s}
11255 checkbutton $top.g.bold -padx 5 \
11256 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11257 -variable fontparam(weight) -onvalue bold -offvalue normal
11258 checkbutton $top.g.ital -padx 5 \
11259 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11260 -variable fontparam(slant) -onvalue italic -offvalue roman
11261 pack $top.g.size $top.g.bold $top.g.ital -side left
11262 pack $top.g -side top
11263 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11264 -background white
11265 $top.c create text 100 25 -anchor center -text $which -font sample \
11266 -fill black -tags text
11267 bind $top.c <Configure> [list centertext $top.c]
11268 pack $top.c -side top -fill x
11269 ${NS}::frame $top.buts
11270 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11271 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11272 bind $top <Key-Return> fontok
11273 bind $top <Key-Escape> fontcan
11274 grid $top.buts.ok $top.buts.can
11275 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11276 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11277 pack $top.buts -side bottom -fill x
11278 trace add variable fontparam write chg_fontparam
11279 } else {
11280 raise $top
11281 $top.c itemconf text -text $which
11282 }
11283 set i [lsearch -exact $fontlist $fontparam(family)]
11284 if {$i >= 0} {
11285 $top.f.fam selection set $i
11286 $top.f.fam see $i
11287 }
11288}
11289
11290proc centertext {w} {
11291 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11292}
11293
11294proc fontok {} {
11295 global fontparam fontpref prefstop
11296
11297 set f $fontparam(font)
11298 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11299 if {$fontparam(weight) eq "bold"} {
11300 lappend fontpref($f) "bold"
11301 }
11302 if {$fontparam(slant) eq "italic"} {
11303 lappend fontpref($f) "italic"
11304 }
11305 set w $prefstop.notebook.fonts.$f
11306 $w conf -text $fontparam(family) -font $fontpref($f)
11307
11308 fontcan
11309}
11310
11311proc fontcan {} {
11312 global fonttop fontparam
11313
11314 if {[info exists fonttop]} {
11315 catch {destroy $fonttop}
11316 catch {font delete sample}
11317 unset fonttop
11318 unset fontparam
11319 }
11320}
11321
11322if {[package vsatisfies [package provide Tk] 8.6]} {
11323 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11324 # function to make use of it.
11325 proc choosefont {font which} {
11326 tk fontchooser configure -title $which -font $font \
11327 -command [list on_choosefont $font $which]
11328 tk fontchooser show
11329 }
11330 proc on_choosefont {font which newfont} {
11331 global fontparam
11332 puts stderr "$font $newfont"
11333 array set f [font actual $newfont]
11334 set fontparam(which) $which
11335 set fontparam(font) $font
11336 set fontparam(family) $f(-family)
11337 set fontparam(size) $f(-size)
11338 set fontparam(weight) $f(-weight)
11339 set fontparam(slant) $f(-slant)
11340 fontok
11341 }
11342}
11343
11344proc selfontfam {} {
11345 global fonttop fontparam
11346
11347 set i [$fonttop.f.fam curselection]
11348 if {$i ne {}} {
11349 set fontparam(family) [$fonttop.f.fam get $i]
11350 }
11351}
11352
11353proc chg_fontparam {v sub op} {
11354 global fontparam
11355
11356 font config sample -$sub $fontparam($sub)
11357}
11358
11359# Create a property sheet tab page
11360proc create_prefs_page {w} {
11361 global NS
11362 set parent [join [lrange [split $w .] 0 end-1] .]
11363 if {[winfo class $parent] eq "TNotebook"} {
11364 ${NS}::frame $w
11365 } else {
11366 ${NS}::labelframe $w
11367 }
11368}
11369
11370proc prefspage_general {notebook} {
11371 global NS maxwidth maxgraphpct showneartags showlocalchanges
11372 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11373 global hideremotes want_ttk have_ttk maxrefs
11374
11375 set page [create_prefs_page $notebook.general]
11376
11377 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11378 grid $page.ldisp - -sticky w -pady 10
11379 ${NS}::label $page.spacer -text " "
11380 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11381 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11382 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11383 #xgettext:no-tcl-format
11384 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11385 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11386 grid x $page.maxpctl $page.maxpct -sticky w
11387 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11388 -variable showlocalchanges
11389 grid x $page.showlocal -sticky w
11390 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11391 -variable autoselect
11392 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11393 grid x $page.autoselect $page.autosellen -sticky w
11394 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11395 -variable hideremotes
11396 grid x $page.hideremotes -sticky w
11397
11398 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11399 grid $page.ddisp - -sticky w -pady 10
11400 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11401 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11402 grid x $page.tabstopl $page.tabstop -sticky w
11403 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11404 -variable showneartags
11405 grid x $page.ntag -sticky w
11406 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11407 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11408 grid x $page.maxrefsl $page.maxrefs -sticky w
11409 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11410 -variable limitdiffs
11411 grid x $page.ldiff -sticky w
11412 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11413 -variable perfile_attrs
11414 grid x $page.lattr -sticky w
11415
11416 ${NS}::entry $page.extdifft -textvariable extdifftool
11417 ${NS}::frame $page.extdifff
11418 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11419 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11420 pack $page.extdifff.l $page.extdifff.b -side left
11421 pack configure $page.extdifff.l -padx 10
11422 grid x $page.extdifff $page.extdifft -sticky ew
11423
11424 ${NS}::label $page.lgen -text [mc "General options"]
11425 grid $page.lgen - -sticky w -pady 10
11426 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11427 -text [mc "Use themed widgets"]
11428 if {$have_ttk} {
11429 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11430 } else {
11431 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11432 }
11433 grid x $page.want_ttk $page.ttk_note -sticky w
11434 return $page
11435}
11436
11437proc prefspage_colors {notebook} {
11438 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11439
11440 set page [create_prefs_page $notebook.colors]
11441
11442 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11443 grid $page.cdisp - -sticky w -pady 10
11444 label $page.ui -padx 40 -relief sunk -background $uicolor
11445 ${NS}::button $page.uibut -text [mc "Interface"] \
11446 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11447 grid x $page.uibut $page.ui -sticky w
11448 label $page.bg -padx 40 -relief sunk -background $bgcolor
11449 ${NS}::button $page.bgbut -text [mc "Background"] \
11450 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11451 grid x $page.bgbut $page.bg -sticky w
11452 label $page.fg -padx 40 -relief sunk -background $fgcolor
11453 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11454 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11455 grid x $page.fgbut $page.fg -sticky w
11456 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11457 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11458 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11459 [list $ctext tag conf d0 -foreground]]
11460 grid x $page.diffoldbut $page.diffold -sticky w
11461 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11462 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11463 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11464 [list $ctext tag conf dresult -foreground]]
11465 grid x $page.diffnewbut $page.diffnew -sticky w
11466 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11467 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11468 -command [list choosecolor diffcolors 2 $page.hunksep \
11469 [mc "diff hunk header"] \
11470 [list $ctext tag conf hunksep -foreground]]
11471 grid x $page.hunksepbut $page.hunksep -sticky w
11472 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11473 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11474 -command [list choosecolor markbgcolor {} $page.markbgsep \
11475 [mc "marked line background"] \
11476 [list $ctext tag conf omark -background]]
11477 grid x $page.markbgbut $page.markbgsep -sticky w
11478 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11479 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11480 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11481 grid x $page.selbgbut $page.selbgsep -sticky w
11482 return $page
11483}
11484
11485proc prefspage_fonts {notebook} {
11486 global NS
11487 set page [create_prefs_page $notebook.fonts]
11488 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11489 grid $page.cfont - -sticky w -pady 10
11490 mkfontdisp mainfont $page [mc "Main font"]
11491 mkfontdisp textfont $page [mc "Diff display font"]
11492 mkfontdisp uifont $page [mc "User interface font"]
11493 return $page
11494}
11495
11496proc doprefs {} {
11497 global maxwidth maxgraphpct use_ttk NS
11498 global oldprefs prefstop showneartags showlocalchanges
11499 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11500 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11501 global hideremotes want_ttk have_ttk
11502
11503 set top .gitkprefs
11504 set prefstop $top
11505 if {[winfo exists $top]} {
11506 raise $top
11507 return
11508 }
11509 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11510 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11511 set oldprefs($v) [set $v]
11512 }
11513 ttk_toplevel $top
11514 wm title $top [mc "Gitk preferences"]
11515 make_transient $top .
11516
11517 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11518 set notebook [ttk::notebook $top.notebook]
11519 } else {
11520 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11521 }
11522
11523 lappend pages [prefspage_general $notebook] [mc "General"]
11524 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11525 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11526 set col 0
11527 foreach {page title} $pages {
11528 if {$use_notebook} {
11529 $notebook add $page -text $title
11530 } else {
11531 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11532 -text $title -command [list raise $page]]
11533 $page configure -text $title
11534 grid $btn -row 0 -column [incr col] -sticky w
11535 grid $page -row 1 -column 0 -sticky news -columnspan 100
11536 }
11537 }
11538
11539 if {!$use_notebook} {
11540 grid columnconfigure $notebook 0 -weight 1
11541 grid rowconfigure $notebook 1 -weight 1
11542 raise [lindex $pages 0]
11543 }
11544
11545 grid $notebook -sticky news -padx 2 -pady 2
11546 grid rowconfigure $top 0 -weight 1
11547 grid columnconfigure $top 0 -weight 1
11548
11549 ${NS}::frame $top.buts
11550 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11551 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11552 bind $top <Key-Return> prefsok
11553 bind $top <Key-Escape> prefscan
11554 grid $top.buts.ok $top.buts.can
11555 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11556 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11557 grid $top.buts - - -pady 10 -sticky ew
11558 grid columnconfigure $top 2 -weight 1
11559 bind $top <Visibility> [list focus $top.buts.ok]
11560}
11561
11562proc choose_extdiff {} {
11563 global extdifftool
11564
11565 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11566 if {$prog ne {}} {
11567 set extdifftool $prog
11568 }
11569}
11570
11571proc choosecolor {v vi w x cmd} {
11572 global $v
11573
11574 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11575 -title [mc "Gitk: choose color for %s" $x]]
11576 if {$c eq {}} return
11577 $w conf -background $c
11578 lset $v $vi $c
11579 eval $cmd $c
11580}
11581
11582proc setselbg {c} {
11583 global bglist cflist
11584 foreach w $bglist {
11585 if {[winfo exists $w]} {
11586 $w configure -selectbackground $c
11587 }
11588 }
11589 $cflist tag configure highlight \
11590 -background [$cflist cget -selectbackground]
11591 allcanvs itemconf secsel -fill $c
11592}
11593
11594# This sets the background color and the color scheme for the whole UI.
11595# For some reason, tk_setPalette chooses a nasty dark red for selectColor
11596# if we don't specify one ourselves, which makes the checkbuttons and
11597# radiobuttons look bad. This chooses white for selectColor if the
11598# background color is light, or black if it is dark.
11599proc setui {c} {
11600 if {[tk windowingsystem] eq "win32"} { return }
11601 set bg [winfo rgb . $c]
11602 set selc black
11603 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11604 set selc white
11605 }
11606 tk_setPalette background $c selectColor $selc
11607}
11608
11609proc setbg {c} {
11610 global bglist
11611
11612 foreach w $bglist {
11613 if {[winfo exists $w]} {
11614 $w conf -background $c
11615 }
11616 }
11617}
11618
11619proc setfg {c} {
11620 global fglist canv
11621
11622 foreach w $fglist {
11623 if {[winfo exists $w]} {
11624 $w conf -foreground $c
11625 }
11626 }
11627 allcanvs itemconf text -fill $c
11628 $canv itemconf circle -outline $c
11629 $canv itemconf markid -outline $c
11630}
11631
11632proc prefscan {} {
11633 global oldprefs prefstop
11634
11635 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11636 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11637 global $v
11638 set $v $oldprefs($v)
11639 }
11640 catch {destroy $prefstop}
11641 unset prefstop
11642 fontcan
11643}
11644
11645proc prefsok {} {
11646 global maxwidth maxgraphpct
11647 global oldprefs prefstop showneartags showlocalchanges
11648 global fontpref mainfont textfont uifont
11649 global limitdiffs treediffs perfile_attrs
11650 global hideremotes
11651
11652 catch {destroy $prefstop}
11653 unset prefstop
11654 fontcan
11655 set fontchanged 0
11656 if {$mainfont ne $fontpref(mainfont)} {
11657 set mainfont $fontpref(mainfont)
11658 parsefont mainfont $mainfont
11659 eval font configure mainfont [fontflags mainfont]
11660 eval font configure mainfontbold [fontflags mainfont 1]
11661 setcoords
11662 set fontchanged 1
11663 }
11664 if {$textfont ne $fontpref(textfont)} {
11665 set textfont $fontpref(textfont)
11666 parsefont textfont $textfont
11667 eval font configure textfont [fontflags textfont]
11668 eval font configure textfontbold [fontflags textfont 1]
11669 }
11670 if {$uifont ne $fontpref(uifont)} {
11671 set uifont $fontpref(uifont)
11672 parsefont uifont $uifont
11673 eval font configure uifont [fontflags uifont]
11674 }
11675 settabs
11676 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11677 if {$showlocalchanges} {
11678 doshowlocalchanges
11679 } else {
11680 dohidelocalchanges
11681 }
11682 }
11683 if {$limitdiffs != $oldprefs(limitdiffs) ||
11684 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11685 # treediffs elements are limited by path;
11686 # won't have encodings cached if perfile_attrs was just turned on
11687 unset -nocomplain treediffs
11688 }
11689 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11690 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11691 redisplay
11692 } elseif {$showneartags != $oldprefs(showneartags) ||
11693 $limitdiffs != $oldprefs(limitdiffs)} {
11694 reselectline
11695 }
11696 if {$hideremotes != $oldprefs(hideremotes)} {
11697 rereadrefs
11698 }
11699}
11700
11701proc formatdate {d} {
11702 global datetimeformat
11703 if {$d ne {}} {
11704 # If $datetimeformat includes a timezone, display in the
11705 # timezone of the argument. Otherwise, display in local time.
11706 if {[string match {*%[zZ]*} $datetimeformat]} {
11707 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11708 # Tcl < 8.5 does not support -timezone. Emulate it by
11709 # setting TZ (e.g. TZ=<-0430>+04:30).
11710 global env
11711 if {[info exists env(TZ)]} {
11712 set savedTZ $env(TZ)
11713 }
11714 set zone [lindex $d 1]
11715 set sign [string map {+ - - +} [string index $zone 0]]
11716 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11717 set d [clock format [lindex $d 0] -format $datetimeformat]
11718 if {[info exists savedTZ]} {
11719 set env(TZ) $savedTZ
11720 } else {
11721 unset env(TZ)
11722 }
11723 }
11724 } else {
11725 set d [clock format [lindex $d 0] -format $datetimeformat]
11726 }
11727 }
11728 return $d
11729}
11730
11731# This list of encoding names and aliases is distilled from
11732# http://www.iana.org/assignments/character-sets.
11733# Not all of them are supported by Tcl.
11734set encoding_aliases {
11735 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11736 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11737 { ISO-10646-UTF-1 csISO10646UTF1 }
11738 { ISO_646.basic:1983 ref csISO646basic1983 }
11739 { INVARIANT csINVARIANT }
11740 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11741 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11742 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11743 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11744 { NATS-DANO iso-ir-9-1 csNATSDANO }
11745 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11746 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11747 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11748 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11749 { ISO-2022-KR csISO2022KR }
11750 { EUC-KR csEUCKR }
11751 { ISO-2022-JP csISO2022JP }
11752 { ISO-2022-JP-2 csISO2022JP2 }
11753 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11754 csISO13JISC6220jp }
11755 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11756 { IT iso-ir-15 ISO646-IT csISO15Italian }
11757 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11758 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11759 { greek7-old iso-ir-18 csISO18Greek7Old }
11760 { latin-greek iso-ir-19 csISO19LatinGreek }
11761 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11762 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11763 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11764 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11765 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11766 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11767 { INIS iso-ir-49 csISO49INIS }
11768 { INIS-8 iso-ir-50 csISO50INIS8 }
11769 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11770 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11771 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11772 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11773 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11774 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11775 csISO60Norwegian1 }
11776 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11777 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11778 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11779 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11780 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11781 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11782 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11783 { greek7 iso-ir-88 csISO88Greek7 }
11784 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11785 { iso-ir-90 csISO90 }
11786 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11787 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11788 csISO92JISC62991984b }
11789 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11790 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11791 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11792 csISO95JIS62291984handadd }
11793 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11794 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11795 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11796 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11797 CP819 csISOLatin1 }
11798 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11799 { T.61-7bit iso-ir-102 csISO102T617bit }
11800 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11801 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11802 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11803 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11804 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11805 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11806 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11807 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11808 arabic csISOLatinArabic }
11809 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11810 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11811 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11812 greek greek8 csISOLatinGreek }
11813 { T.101-G2 iso-ir-128 csISO128T101G2 }
11814 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11815 csISOLatinHebrew }
11816 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11817 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11818 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11819 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11820 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11821 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11822 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11823 csISOLatinCyrillic }
11824 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11825 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11826 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11827 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11828 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11829 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11830 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11831 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11832 { ISO_10367-box iso-ir-155 csISO10367Box }
11833 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11834 { latin-lap lap iso-ir-158 csISO158Lap }
11835 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11836 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11837 { us-dk csUSDK }
11838 { dk-us csDKUS }
11839 { JIS_X0201 X0201 csHalfWidthKatakana }
11840 { KSC5636 ISO646-KR csKSC5636 }
11841 { ISO-10646-UCS-2 csUnicode }
11842 { ISO-10646-UCS-4 csUCS4 }
11843 { DEC-MCS dec csDECMCS }
11844 { hp-roman8 roman8 r8 csHPRoman8 }
11845 { macintosh mac csMacintosh }
11846 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11847 csIBM037 }
11848 { IBM038 EBCDIC-INT cp038 csIBM038 }
11849 { IBM273 CP273 csIBM273 }
11850 { IBM274 EBCDIC-BE CP274 csIBM274 }
11851 { IBM275 EBCDIC-BR cp275 csIBM275 }
11852 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11853 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11854 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11855 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11856 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11857 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11858 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11859 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11860 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11861 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11862 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11863 { IBM437 cp437 437 csPC8CodePage437 }
11864 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11865 { IBM775 cp775 csPC775Baltic }
11866 { IBM850 cp850 850 csPC850Multilingual }
11867 { IBM851 cp851 851 csIBM851 }
11868 { IBM852 cp852 852 csPCp852 }
11869 { IBM855 cp855 855 csIBM855 }
11870 { IBM857 cp857 857 csIBM857 }
11871 { IBM860 cp860 860 csIBM860 }
11872 { IBM861 cp861 861 cp-is csIBM861 }
11873 { IBM862 cp862 862 csPC862LatinHebrew }
11874 { IBM863 cp863 863 csIBM863 }
11875 { IBM864 cp864 csIBM864 }
11876 { IBM865 cp865 865 csIBM865 }
11877 { IBM866 cp866 866 csIBM866 }
11878 { IBM868 CP868 cp-ar csIBM868 }
11879 { IBM869 cp869 869 cp-gr csIBM869 }
11880 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11881 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11882 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11883 { IBM891 cp891 csIBM891 }
11884 { IBM903 cp903 csIBM903 }
11885 { IBM904 cp904 904 csIBBM904 }
11886 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11887 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11888 { IBM1026 CP1026 csIBM1026 }
11889 { EBCDIC-AT-DE csIBMEBCDICATDE }
11890 { EBCDIC-AT-DE-A csEBCDICATDEA }
11891 { EBCDIC-CA-FR csEBCDICCAFR }
11892 { EBCDIC-DK-NO csEBCDICDKNO }
11893 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11894 { EBCDIC-FI-SE csEBCDICFISE }
11895 { EBCDIC-FI-SE-A csEBCDICFISEA }
11896 { EBCDIC-FR csEBCDICFR }
11897 { EBCDIC-IT csEBCDICIT }
11898 { EBCDIC-PT csEBCDICPT }
11899 { EBCDIC-ES csEBCDICES }
11900 { EBCDIC-ES-A csEBCDICESA }
11901 { EBCDIC-ES-S csEBCDICESS }
11902 { EBCDIC-UK csEBCDICUK }
11903 { EBCDIC-US csEBCDICUS }
11904 { UNKNOWN-8BIT csUnknown8BiT }
11905 { MNEMONIC csMnemonic }
11906 { MNEM csMnem }
11907 { VISCII csVISCII }
11908 { VIQR csVIQR }
11909 { KOI8-R csKOI8R }
11910 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11911 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11912 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11913 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11914 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11915 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11916 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11917 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11918 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11919 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11920 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11921 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11922 { IBM1047 IBM-1047 }
11923 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11924 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11925 { UNICODE-1-1 csUnicode11 }
11926 { CESU-8 csCESU-8 }
11927 { BOCU-1 csBOCU-1 }
11928 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11929 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11930 l8 }
11931 { ISO-8859-15 ISO_8859-15 Latin-9 }
11932 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11933 { GBK CP936 MS936 windows-936 }
11934 { JIS_Encoding csJISEncoding }
11935 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11936 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11937 EUC-JP }
11938 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11939 { ISO-10646-UCS-Basic csUnicodeASCII }
11940 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11941 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11942 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11943 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11944 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11945 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11946 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11947 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11948 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11949 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11950 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11951 { Ventura-US csVenturaUS }
11952 { Ventura-International csVenturaInternational }
11953 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11954 { PC8-Turkish csPC8Turkish }
11955 { IBM-Symbols csIBMSymbols }
11956 { IBM-Thai csIBMThai }
11957 { HP-Legal csHPLegal }
11958 { HP-Pi-font csHPPiFont }
11959 { HP-Math8 csHPMath8 }
11960 { Adobe-Symbol-Encoding csHPPSMath }
11961 { HP-DeskTop csHPDesktop }
11962 { Ventura-Math csVenturaMath }
11963 { Microsoft-Publishing csMicrosoftPublishing }
11964 { Windows-31J csWindows31J }
11965 { GB2312 csGB2312 }
11966 { Big5 csBig5 }
11967}
11968
11969proc tcl_encoding {enc} {
11970 global encoding_aliases tcl_encoding_cache
11971 if {[info exists tcl_encoding_cache($enc)]} {
11972 return $tcl_encoding_cache($enc)
11973 }
11974 set names [encoding names]
11975 set lcnames [string tolower $names]
11976 set enc [string tolower $enc]
11977 set i [lsearch -exact $lcnames $enc]
11978 if {$i < 0} {
11979 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11980 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11981 set i [lsearch -exact $lcnames $encx]
11982 }
11983 }
11984 if {$i < 0} {
11985 foreach l $encoding_aliases {
11986 set ll [string tolower $l]
11987 if {[lsearch -exact $ll $enc] < 0} continue
11988 # look through the aliases for one that tcl knows about
11989 foreach e $ll {
11990 set i [lsearch -exact $lcnames $e]
11991 if {$i < 0} {
11992 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11993 set i [lsearch -exact $lcnames $ex]
11994 }
11995 }
11996 if {$i >= 0} break
11997 }
11998 break
11999 }
12000 }
12001 set tclenc {}
12002 if {$i >= 0} {
12003 set tclenc [lindex $names $i]
12004 }
12005 set tcl_encoding_cache($enc) $tclenc
12006 return $tclenc
12007}
12008
12009proc gitattr {path attr default} {
12010 global path_attr_cache
12011 if {[info exists path_attr_cache($attr,$path)]} {
12012 set r $path_attr_cache($attr,$path)
12013 } else {
12014 set r "unspecified"
12015 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12016 regexp "(.*): $attr: (.*)" $line m f r
12017 }
12018 set path_attr_cache($attr,$path) $r
12019 }
12020 if {$r eq "unspecified"} {
12021 return $default
12022 }
12023 return $r
12024}
12025
12026proc cache_gitattr {attr pathlist} {
12027 global path_attr_cache
12028 set newlist {}
12029 foreach path $pathlist {
12030 if {![info exists path_attr_cache($attr,$path)]} {
12031 lappend newlist $path
12032 }
12033 }
12034 set lim 1000
12035 if {[tk windowingsystem] == "win32"} {
12036 # windows has a 32k limit on the arguments to a command...
12037 set lim 30
12038 }
12039 while {$newlist ne {}} {
12040 set head [lrange $newlist 0 [expr {$lim - 1}]]
12041 set newlist [lrange $newlist $lim end]
12042 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12043 foreach row [split $rlist "\n"] {
12044 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12045 if {[string index $path 0] eq "\""} {
12046 set path [encoding convertfrom [lindex $path 0]]
12047 }
12048 set path_attr_cache($attr,$path) $value
12049 }
12050 }
12051 }
12052 }
12053}
12054
12055proc get_path_encoding {path} {
12056 global gui_encoding perfile_attrs
12057 set tcl_enc $gui_encoding
12058 if {$path ne {} && $perfile_attrs} {
12059 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12060 if {$enc2 ne {}} {
12061 set tcl_enc $enc2
12062 }
12063 }
12064 return $tcl_enc
12065}
12066
12067## For msgcat loading, first locate the installation location.
12068if { [info exists ::env(GITK_MSGSDIR)] } {
12069 ## Msgsdir was manually set in the environment.
12070 set gitk_msgsdir $::env(GITK_MSGSDIR)
12071} else {
12072 ## Let's guess the prefix from argv0.
12073 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12074 set gitk_libdir [file join $gitk_prefix share gitk lib]
12075 set gitk_msgsdir [file join $gitk_libdir msgs]
12076 unset gitk_prefix
12077}
12078
12079## Internationalization (i18n) through msgcat and gettext. See
12080## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12081package require msgcat
12082namespace import ::msgcat::mc
12083## And eventually load the actual message catalog
12084::msgcat::mcload $gitk_msgsdir
12085
12086# First check that Tcl/Tk is recent enough
12087if {[catch {package require Tk 8.4} err]} {
12088 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12089 Gitk requires at least Tcl/Tk 8.4."]
12090 exit 1
12091}
12092
12093# on OSX bring the current Wish process window to front
12094if {[tk windowingsystem] eq "aqua"} {
12095 exec osascript -e [format {
12096 tell application "System Events"
12097 set frontmost of processes whose unix id is %d to true
12098 end tell
12099 } [pid] ]
12100}
12101
12102# Unset GIT_TRACE var if set
12103if { [info exists ::env(GIT_TRACE)] } {
12104 unset ::env(GIT_TRACE)
12105}
12106
12107# defaults...
12108set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12109
12110set gitencoding {}
12111catch {
12112 set gitencoding [exec git config --get i18n.commitencoding]
12113}
12114catch {
12115 set gitencoding [exec git config --get i18n.logoutputencoding]
12116}
12117if {$gitencoding == ""} {
12118 set gitencoding "utf-8"
12119}
12120set tclencoding [tcl_encoding $gitencoding]
12121if {$tclencoding == {}} {
12122 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12123}
12124
12125set gui_encoding [encoding system]
12126catch {
12127 set enc [exec git config --get gui.encoding]
12128 if {$enc ne {}} {
12129 set tclenc [tcl_encoding $enc]
12130 if {$tclenc ne {}} {
12131 set gui_encoding $tclenc
12132 } else {
12133 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12134 }
12135 }
12136}
12137
12138set log_showroot true
12139catch {
12140 set log_showroot [exec git config --bool --get log.showroot]
12141}
12142
12143if {[tk windowingsystem] eq "aqua"} {
12144 set mainfont {{Lucida Grande} 9}
12145 set textfont {Monaco 9}
12146 set uifont {{Lucida Grande} 9 bold}
12147} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12148 # fontconfig!
12149 set mainfont {sans 9}
12150 set textfont {monospace 9}
12151 set uifont {sans 9 bold}
12152} else {
12153 set mainfont {Helvetica 9}
12154 set textfont {Courier 9}
12155 set uifont {Helvetica 9 bold}
12156}
12157set tabstop 8
12158set findmergefiles 0
12159set maxgraphpct 50
12160set maxwidth 16
12161set revlistorder 0
12162set fastdate 0
12163set uparrowlen 5
12164set downarrowlen 5
12165set mingaplen 100
12166set cmitmode "patch"
12167set wrapcomment "none"
12168set showneartags 1
12169set hideremotes 0
12170set maxrefs 20
12171set visiblerefs {"master"}
12172set maxlinelen 200
12173set showlocalchanges 1
12174set limitdiffs 1
12175set datetimeformat "%Y-%m-%d %H:%M:%S"
12176set autoselect 1
12177set autosellen 40
12178set perfile_attrs 0
12179set want_ttk 1
12180
12181if {[tk windowingsystem] eq "aqua"} {
12182 set extdifftool "opendiff"
12183} else {
12184 set extdifftool "meld"
12185}
12186
12187set colors {green red blue magenta darkgrey brown orange}
12188if {[tk windowingsystem] eq "win32"} {
12189 set uicolor SystemButtonFace
12190 set uifgcolor SystemButtonText
12191 set uifgdisabledcolor SystemDisabledText
12192 set bgcolor SystemWindow
12193 set fgcolor SystemWindowText
12194 set selectbgcolor SystemHighlight
12195} else {
12196 set uicolor grey85
12197 set uifgcolor black
12198 set uifgdisabledcolor "#999"
12199 set bgcolor white
12200 set fgcolor black
12201 set selectbgcolor gray85
12202}
12203set diffcolors {red "#00a000" blue}
12204set diffcontext 3
12205set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12206set ignorespace 0
12207set worddiff ""
12208set markbgcolor "#e0e0ff"
12209
12210set headbgcolor green
12211set headfgcolor black
12212set headoutlinecolor black
12213set remotebgcolor #ffddaa
12214set tagbgcolor yellow
12215set tagfgcolor black
12216set tagoutlinecolor black
12217set reflinecolor black
12218set filesepbgcolor #aaaaaa
12219set filesepfgcolor black
12220set linehoverbgcolor #ffff80
12221set linehoverfgcolor black
12222set linehoveroutlinecolor black
12223set mainheadcirclecolor yellow
12224set workingfilescirclecolor red
12225set indexcirclecolor green
12226set circlecolors {white blue gray blue blue}
12227set linkfgcolor blue
12228set circleoutlinecolor $fgcolor
12229set foundbgcolor yellow
12230set currentsearchhitbgcolor orange
12231
12232# button for popping up context menus
12233if {[tk windowingsystem] eq "aqua"} {
12234 set ctxbut <Button-2>
12235} else {
12236 set ctxbut <Button-3>
12237}
12238
12239catch {
12240 # follow the XDG base directory specification by default. See
12241 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12242 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12243 # XDG_CONFIG_HOME environment variable is set
12244 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12245 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12246 } else {
12247 # default XDG_CONFIG_HOME
12248 set config_file "~/.config/git/gitk"
12249 set config_file_tmp "~/.config/git/gitk-tmp"
12250 }
12251 if {![file exists $config_file]} {
12252 # for backward compatibility use the old config file if it exists
12253 if {[file exists "~/.gitk"]} {
12254 set config_file "~/.gitk"
12255 set config_file_tmp "~/.gitk-tmp"
12256 } elseif {![file exists [file dirname $config_file]]} {
12257 file mkdir [file dirname $config_file]
12258 }
12259 }
12260 source $config_file
12261}
12262config_check_tmp_exists 50
12263
12264set config_variables {
12265 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12266 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12267 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12268 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12269 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12270 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12271 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12272 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12273 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12274 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12275}
12276foreach var $config_variables {
12277 config_init_trace $var
12278 trace add variable $var write config_variable_change_cb
12279}
12280
12281parsefont mainfont $mainfont
12282eval font create mainfont [fontflags mainfont]
12283eval font create mainfontbold [fontflags mainfont 1]
12284
12285parsefont textfont $textfont
12286eval font create textfont [fontflags textfont]
12287eval font create textfontbold [fontflags textfont 1]
12288
12289parsefont uifont $uifont
12290eval font create uifont [fontflags uifont]
12291
12292setui $uicolor
12293
12294setoptions
12295
12296# check that we can find a .git directory somewhere...
12297if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12298 show_error {} . [mc "Cannot find a git repository here."]
12299 exit 1
12300}
12301
12302set selecthead {}
12303set selectheadid {}
12304
12305set revtreeargs {}
12306set cmdline_files {}
12307set i 0
12308set revtreeargscmd {}
12309foreach arg $argv {
12310 switch -glob -- $arg {
12311 "" { }
12312 "--" {
12313 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12314 break
12315 }
12316 "--select-commit=*" {
12317 set selecthead [string range $arg 16 end]
12318 }
12319 "--argscmd=*" {
12320 set revtreeargscmd [string range $arg 10 end]
12321 }
12322 default {
12323 lappend revtreeargs $arg
12324 }
12325 }
12326 incr i
12327}
12328
12329if {$selecthead eq "HEAD"} {
12330 set selecthead {}
12331}
12332
12333if {$i >= [llength $argv] && $revtreeargs ne {}} {
12334 # no -- on command line, but some arguments (other than --argscmd)
12335 if {[catch {
12336 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12337 set cmdline_files [split $f "\n"]
12338 set n [llength $cmdline_files]
12339 set revtreeargs [lrange $revtreeargs 0 end-$n]
12340 # Unfortunately git rev-parse doesn't produce an error when
12341 # something is both a revision and a filename. To be consistent
12342 # with git log and git rev-list, check revtreeargs for filenames.
12343 foreach arg $revtreeargs {
12344 if {[file exists $arg]} {
12345 show_error {} . [mc "Ambiguous argument '%s': both revision\
12346 and filename" $arg]
12347 exit 1
12348 }
12349 }
12350 } err]} {
12351 # unfortunately we get both stdout and stderr in $err,
12352 # so look for "fatal:".
12353 set i [string first "fatal:" $err]
12354 if {$i > 0} {
12355 set err [string range $err [expr {$i + 6}] end]
12356 }
12357 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12358 exit 1
12359 }
12360}
12361
12362set nullid "0000000000000000000000000000000000000000"
12363set nullid2 "0000000000000000000000000000000000000001"
12364set nullfile "/dev/null"
12365
12366set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12367if {![info exists have_ttk]} {
12368 set have_ttk [llength [info commands ::ttk::style]]
12369}
12370set use_ttk [expr {$have_ttk && $want_ttk}]
12371set NS [expr {$use_ttk ? "ttk" : ""}]
12372
12373if {$use_ttk} {
12374 setttkstyle
12375}
12376
12377regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12378
12379set show_notes {}
12380if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12381 set show_notes "--show-notes"
12382}
12383
12384set appname "gitk"
12385
12386set runq {}
12387set history {}
12388set historyindex 0
12389set fh_serial 0
12390set nhl_names {}
12391set highlight_paths {}
12392set findpattern {}
12393set searchdirn -forwards
12394set boldids {}
12395set boldnameids {}
12396set diffelide {0 0}
12397set markingmatches 0
12398set linkentercount 0
12399set need_redisplay 0
12400set nrows_drawn 0
12401set firsttabstop 0
12402
12403set nextviewnum 1
12404set curview 0
12405set selectedview 0
12406set selectedhlview [mc "None"]
12407set highlight_related [mc "None"]
12408set highlight_files {}
12409set viewfiles(0) {}
12410set viewperm(0) 0
12411set viewchanged(0) 0
12412set viewargs(0) {}
12413set viewargscmd(0) {}
12414
12415set selectedline {}
12416set numcommits 0
12417set loginstance 0
12418set cmdlineok 0
12419set stopped 0
12420set stuffsaved 0
12421set patchnum 0
12422set lserial 0
12423set hasworktree [hasworktree]
12424set cdup {}
12425if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12426 set cdup [exec git rev-parse --show-cdup]
12427}
12428set worktree [exec git rev-parse --show-toplevel]
12429setcoords
12430makewindow
12431catch {
12432 image create photo gitlogo -width 16 -height 16
12433
12434 image create photo gitlogominus -width 4 -height 2
12435 gitlogominus put #C00000 -to 0 0 4 2
12436 gitlogo copy gitlogominus -to 1 5
12437 gitlogo copy gitlogominus -to 6 5
12438 gitlogo copy gitlogominus -to 11 5
12439 image delete gitlogominus
12440
12441 image create photo gitlogoplus -width 4 -height 4
12442 gitlogoplus put #008000 -to 1 0 3 4
12443 gitlogoplus put #008000 -to 0 1 4 3
12444 gitlogo copy gitlogoplus -to 1 9
12445 gitlogo copy gitlogoplus -to 6 9
12446 gitlogo copy gitlogoplus -to 11 9
12447 image delete gitlogoplus
12448
12449 image create photo gitlogo32 -width 32 -height 32
12450 gitlogo32 copy gitlogo -zoom 2 2
12451
12452 wm iconphoto . -default gitlogo gitlogo32
12453}
12454# wait for the window to become visible
12455tkwait visibility .
12456set_window_title
12457update
12458readrefs
12459
12460if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12461 # create a view for the files/dirs specified on the command line
12462 set curview 1
12463 set selectedview 1
12464 set nextviewnum 2
12465 set viewname(1) [mc "Command line"]
12466 set viewfiles(1) $cmdline_files
12467 set viewargs(1) $revtreeargs
12468 set viewargscmd(1) $revtreeargscmd
12469 set viewperm(1) 0
12470 set viewchanged(1) 0
12471 set vdatemode(1) 0
12472 addviewmenu 1
12473 .bar.view entryconf [mca "&Edit view..."] -state normal
12474 .bar.view entryconf [mca "&Delete view"] -state normal
12475}
12476
12477if {[info exists permviews]} {
12478 foreach v $permviews {
12479 set n $nextviewnum
12480 incr nextviewnum
12481 set viewname($n) [lindex $v 0]
12482 set viewfiles($n) [lindex $v 1]
12483 set viewargs($n) [lindex $v 2]
12484 set viewargscmd($n) [lindex $v 3]
12485 set viewperm($n) 1
12486 set viewchanged($n) 0
12487 addviewmenu $n
12488 }
12489}
12490
12491if {[tk windowingsystem] eq "win32"} {
12492 focus -force .
12493}
12494
12495getcommits {}
12496
12497# Local variables:
12498# mode: tcl
12499# indent-tabs-mode: t
12500# tab-width: 8
12501# End: