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