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