1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
5# Copyright © 2005-2014 Paul Mackerras. All rights reserved.
6# This program is free software; it may be used, copied, modified
7# and distributed under the terms of the GNU General Public Licence,
8# either version 2, or (at your option) any later version.
9
10package require Tk
11
12proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
15}
16
17proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
22 }
23 return [file tail $n]
24}
25
26proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
30 }
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
40 }
41 }
42 }
43 return $_gitworktree
44}
45
46# A simple scheduler for compute-intensive stuff.
47# The aim is to make sure that event handlers for GUI actions can
48# run at least every 50-100 ms. Unfortunately fileevent handlers are
49# run before X event handlers, so reading from a fast source can
50# make the GUI completely unresponsive.
51proc run args {
52 global isonrunq runq currunq
53
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
58 }
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
61}
62
63proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
65}
66
67proc filereadable {fd script} {
68 global runq currunq
69
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
73 }
74 lappend runq [list $fd $script]
75}
76
77proc nukefile {fd} {
78 global runq
79
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
85 }
86 }
87}
88
89proc dorunq {} {
90 global isonrunq runq currunq
91
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
110 }
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
113 }
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
116 }
117 if {$runq ne {}} {
118 after idle dorunq
119 }
120}
121
122proc reg_instance {fd} {
123 global commfd leftover loginstance
124
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
129}
130
131proc unmerged_files {files} {
132 global nr_unmerged
133
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
142 }
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
151 }
152 }
153 catch {close $fd}
154 return $mlist
155}
156
157proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
161
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
179 }
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
187 }
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
197 }
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
207 }
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
213 }
214 }
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
218 }
219 }
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
226 }
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
237 }
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
245 }
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
252 }
253 "--not" - "--all" {
254 lappend revargs $arg
255 }
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
260 }
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
263 }
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
272 }
273 lappend glflags $arg
274 }
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
279 }
280 lappend revargs $arg
281 }
282 }
283 }
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
290}
291
292proc parseviewrevs {view revs} {
293 global vposids vnegids
294
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
299 }
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
315 }
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
318 }
319 break
320 }
321 lappend badrev $line
322 }
323 }
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
326 }
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
339 }
340 }
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
347 }
348 lappend pos $id
349 }
350 incr sdm -1
351 }
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
355}
356
357# Start off a git log process and arrange to read its output
358proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
367
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
374
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
382 }
383 set args [concat $args [split $str "\n"]]
384 }
385 set vcanopt($view) [parseviewargs $view $args]
386
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
398 }
399 return 0
400 }
401 }
402 set vfilelimit($view) $files
403
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
408 }
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
412 }
413
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
420 }
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
427 }
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
430 }
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
434 }
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
440}
441
442proc stop_instance {inst} {
443 global commfd leftover
444
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
448
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
453 }
454 }
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
459}
460
461proc stop_backends {} {
462 global commfd
463
464 foreach inst [array names commfd] {
465 stop_instance $inst
466 }
467}
468
469proc stop_rev_list {view} {
470 global viewinstances
471
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
474 }
475 set viewinstances($view) {}
476}
477
478proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
480
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
487 }
488}
489
490proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
492
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
500 }
501}
502
503proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
511
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
518 }
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
523 }
524 }
525 if {$showlocalchanges} {
526 doshowlocalchanges
527 }
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
534 }
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
549 }
550 } else {
551 lappend $newrevs $rev
552 }
553 }
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
557 }
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
561 }
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
568 }
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
571 }
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
577 }
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
585 }
586}
587
588proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
592
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
596 }
597
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
600 }
601 resetvarcs $curview
602 set selectedline {}
603 unset -nocomplain currentid
604 unset -nocomplain thickerline
605 unset -nocomplain treediffs
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
610 }
611 clear_display
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
618}
619
620# This makes a string representation of a positive integer which
621# sorts as a string in numerical order
622proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
629 }
630 return [format "z%.8x" $n]
631}
632
633# Procedures used in reordering commits from git log (without
634# --topo-order) into the order for display.
635
636proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
639
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
652}
653
654proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
657
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
662 }
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
665 }
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
669 }
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
672 }
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
675 }
676 unset -nocomplain ordertok
677}
678
679# returns a list of the commits with no children
680proc seeds {v} {
681 global vdownptr vleftptr varcstart
682
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
688 }
689 return $ret
690}
691
692proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
696
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
702 }
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
706 }
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
709 }
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
715 }
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
724 }
725 }
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
730 }
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
737 }
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
741 }
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
748 }
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
754 }
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
763}
764
765proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
768
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
785 }
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
795 }
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
798 }
799}
800
801proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
804
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
817 }
818 }
819 }
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
827 }
828 }
829 set a $b
830 }
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
837 }
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
843 }
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
852 }
853 }
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
858 }
859 if {$tok eq $oldtok} {
860 continue
861 }
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
868 }
869 }
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
875 }
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
878 }
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
885 }
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
888 }
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
891 }
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
900 }
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
905 }
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
912 }
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
916 }
917 lset vlastins($v) $ka $a
918 }
919 }
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
924 }
925 }
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
928}
929
930# Fix up the graph after we have found out that in view $v,
931# $p (a commit that we have already seen) is actually the parent
932# of the last commit in arc $a.
933proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
935
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
940 }
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
946 }
947}
948
949proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
953
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
964 }
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
970 }
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
979 }
980 }
981 }
982}
983
984proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
987
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
994 }
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1007 }
1008 }
1009 setcanvscroll
1010 drawvisible
1011}
1012
1013proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1017
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1022 }
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1029 }
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1039 }
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1044 }
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1047 }
1048 setcanvscroll
1049 drawvisible
1050}
1051
1052proc real_children {vp} {
1053 global children nullid nullid2
1054
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1059 }
1060 }
1061 return $kids
1062}
1063
1064proc first_real_child {vp} {
1065 global children nullid nullid2
1066
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1070 }
1071 }
1072 return {}
1073}
1074
1075proc last_real_child {vp} {
1076 global children nullid nullid2
1077
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1083 }
1084 }
1085 return {}
1086}
1087
1088proc vtokcmp {v a b} {
1089 global varctok varcid
1090
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1093}
1094
1095# This assumes that if lim is not given, the caller has checked that
1096# arc a's token is less than $vtokmod($v)
1097proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1099
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1106 }
1107 }
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1114 }
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1119 }
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1121 }
1122 set vrowmod($v) $r
1123 undolayout $r
1124 }
1125}
1126
1127proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1132
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1138 }
1139 unset -nocomplain cached_commitrow
1140 }
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1147 }
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1162 }
1163 set row [lindex $varcrow($v) $a]
1164 }
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1176 }
1177 if {$a == 0} break
1178 }
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1185 }
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1191 }
1192}
1193
1194# Test whether view $v contains commit $id
1195proc commitinview {id v} {
1196 global varcid
1197
1198 return [info exists varcid($v,$id)]
1199}
1200
1201# Return the row number for commit $id in the current view
1202proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1205
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1210 }
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1214 }
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1217 }
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1222 }
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1226}
1227
1228# Returns 1 if a is on an earlier row than b, otherwise 0
1229proc comes_before {a b} {
1230 global varcid varctok curview
1231
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1236 }
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1240 }
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1242}
1243
1244proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1247 }
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1259 }
1260 }
1261 return $lo
1262}
1263
1264# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1269
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1272 }
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1288 }
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1292 }
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1299 }
1300 }
1301 incr r $al
1302 }
1303}
1304
1305proc commitonrow {row} {
1306 global displayorder
1307
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1312 }
1313 return $id
1314}
1315
1316proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1319
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1336 }
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1340 }
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1344 }
1345 }
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1349 }
1350 }
1351}
1352
1353# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354# Assumes we already have an arc for $rwid.
1355proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1357
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1363 }
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1369 }
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1376 }
1377}
1378
1379# Mechanism for registering a command to be executed when we come
1380# across a particular commit. To handle the case when only the
1381# prefix of the commit is known, the commitinterest array is now
1382# indexed by the first 4 characters of the ID. Each element is a
1383# list of id, cmd pairs.
1384proc interestedin {id cmd} {
1385 global commitinterest
1386
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1388}
1389
1390proc check_interest {id scripts} {
1391 global commitinterest
1392
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1401 }
1402 }
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1407 }
1408 }
1409 return $scripts
1410}
1411
1412proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1418
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1423 }
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1427 }
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1434 }
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1441 }
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq "Command line"} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1449 }
1450 } else {
1451 set err "Error reading commits$fv: $err"
1452 }
1453 error_popup $err
1454 }
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1461 }
1462 if {$view == $curview} {
1463 run chewcommits
1464 }
1465 return 0
1466 }
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1475 }
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1482 }
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1495 }
1496 set ids [string range $ids 1 end]
1497 }
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1503 }
1504 }
1505 }
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1510 }
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1513 }
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1516
1517 lappend vshortids($view,[string range $id 0 3]) $id
1518
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1534 }
1535 }
1536 }
1537
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1542 }
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1547 }
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1559 }
1560 }
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1564 }
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1567 }
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1572 }
1573
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 unset -nocomplain ordertok
1583 }
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1586 }
1587 }
1588 incr i
1589 }
1590
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1593 }
1594 if {$gotsome} {
1595 global numcommits hlview
1596
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1600 }
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1604 }
1605 foreach s $scripts {
1606 eval $s
1607 }
1608 }
1609 return 2
1610}
1611
1612proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1615
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1620
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1624
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1630 }
1631 }
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1638 }
1639 notbusy layout
1640 }
1641 return 0
1642}
1643
1644proc do_readcommit {id} {
1645 global tclencoding
1646
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1653 }
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1658
1659 return $contents
1660}
1661
1662proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1665}
1666
1667proc parsecommit {id contents listed} {
1668 global commitinfo
1669
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1681 }
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1693 }
1694 }
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1701 }
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1706 }
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1715 }
1716 set comment $newcomment
1717 }
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1727 }
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1730}
1731
1732proc getcommit {id} {
1733 global commitdata commitinfo
1734
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1741 }
1742 }
1743 return 1
1744}
1745
1746# Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747# and are present in the current view.
1748# This is fairly slow...
1749proc longid {prefix} {
1750 global varcid curview vshortids
1751
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1761 }
1762 }
1763 }
1764 }
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1769 }
1770 }
1771 return $ids
1772}
1773
1774proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1779
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 unset -nocomplain $v
1782 }
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1794 }
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1807 }
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1813 }
1814 }
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1823 }
1824 }
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1829 }
1830 }
1831}
1832
1833# skip over fake commits
1834proc first_real_row {} {
1835 global nullid nullid2 numcommits
1836
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1841 }
1842 }
1843 return $row
1844}
1845
1846# update things for a head moved to a child of its previous location
1847proc movehead {id name} {
1848 global headids idheads
1849
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1853}
1854
1855# update things when a head has been removed
1856proc removehead {id name} {
1857 global headids idheads
1858
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1865 }
1866 }
1867 unset headids($name)
1868}
1869
1870proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1875 }
1876 return $w
1877}
1878
1879proc make_transient {window origin} {
1880 global have_tk85
1881
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1887
1888 wm transient $window $origin
1889
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1894 }
1895}
1896
1897proc show_error {w top msg} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1910}
1911
1912proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1921 }
1922}
1923
1924proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1943}
1944
1945proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1951 }
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1954 }
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1966}
1967
1968# Make a menu and submenus.
1969# m is the window name for the menu, items is the list of menu items to add.
1970# Each item is a list {mc label type description options...}
1971# mc is ignored; it's so we can put mc there to alert xgettext
1972# label is the string that appears in the menu
1973# type is cascade, command or radiobutton (should add checkbutton)
1974# description depends on type; it's the sublist for cascade, the
1975# command to invoke for command, or {variable value} for radiobutton
1976proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1982 }
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1993 }
1994 }
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
1999 }
2000 "command" {
2001 lappend params -command $thing
2002 }
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2006 }
2007 }
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2013 }
2014 }
2015}
2016
2017# translate string and remove ampersands
2018proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2020}
2021
2022proc cleardropsel {w} {
2023 $w selection clear
2024}
2025proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2032 }
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2039 }
2040 return $gm
2041}
2042
2043proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2064
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "File" cascade {
2069 {mc "Update" command updatecommits -accelerator F5}
2070 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread references" command rereadrefs}
2072 {mc "List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "Quit" command doquit -accelerator Meta1-Q}
2077 }}
2078 set edit {
2079 mc "Edit" cascade {
2080 {mc "Preferences" command doprefs}
2081 }}
2082 set view {
2083 mc "View" cascade {
2084 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2089 }}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "Help" cascade {
2093 {mc "About gitk" command about}
2094 {mc "Key bindings" command keys}
2095 }}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "Apple" cascade {
2103 {mc "About gitk" command about}
2104 {xx "" separator}
2105 }}
2106 set help {
2107 mc "Help" cascade {
2108 {mc "Key bindings" command keys}
2109 }}
2110 set bar [list $apple $file $view $help]
2111 }
2112 makemenu .bar $bar
2113 . configure -menu .bar
2114
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2118 }
2119
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2122
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2131 }
2132
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2139 }
2140
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2164 }
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2168 }
2169
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2177
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2181
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2192
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2200 }
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2208 }
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2213
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2219 }
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2226 }
2227 pack .tf.bar.rightbut -side left -fill y
2228
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2240 }
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2243
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2257 }
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2265
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2268
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2277 }
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2281
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2290 }
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2294
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2296
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2307
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2324
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2333 }
2334
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2337
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2345 }
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2349
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2377
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2384 }
2385
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2393 }
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2406
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2436
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2440 }
2441
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2469
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2472
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2478 }
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2481 }
2482 wm geometry . "${w}x$h"
2483 }
2484 }
2485
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2488 }
2489
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2496 }
2497
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2502 }
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2506 }
2507 }
2508
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 bind $ctext <Button> {
2520 if {"%b" eq 6} {
2521 $ctext xview scroll -5 units
2522 } elseif {"%b" eq 7} {
2523 $ctext xview scroll 5 units
2524 }
2525 }
2526 if {[tk windowingsystem] eq "aqua"} {
2527 bindall <MouseWheel> {
2528 set delta [expr {- (%D)}]
2529 allcanvs yview scroll $delta units
2530 }
2531 bindall <Shift-MouseWheel> {
2532 set delta [expr {- (%D)}]
2533 $canv xview scroll $delta units
2534 }
2535 }
2536 }
2537 bindall <$::BM> "canvscan mark %W %x %y"
2538 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540 bind . <$M1B-Key-w> doquit
2541 bindkey <Home> selfirstline
2542 bindkey <End> sellastline
2543 bind . <Key-Up> "selnextline -1"
2544 bind . <Key-Down> "selnextline 1"
2545 bind . <Shift-Key-Up> "dofind -1 0"
2546 bind . <Shift-Key-Down> "dofind 1 0"
2547 bindkey <Key-Right> "goforw"
2548 bindkey <Key-Left> "goback"
2549 bind . <Key-Prior> "selnextpage -1"
2550 bind . <Key-Next> "selnextpage 1"
2551 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559 bindkey <Key-space> "$ctext yview scroll 1 pages"
2560 bindkey p "selnextline -1"
2561 bindkey n "selnextline 1"
2562 bindkey z "goback"
2563 bindkey x "goforw"
2564 bindkey k "selnextline -1"
2565 bindkey j "selnextline 1"
2566 bindkey h "goback"
2567 bindkey l "goforw"
2568 bindkey b prevfile
2569 bindkey d "$ctext yview scroll 18 units"
2570 bindkey u "$ctext yview scroll -18 units"
2571 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2572 bindkey / {focus $fstring}
2573 bindkey <Key-KP_Divide> {focus $fstring}
2574 bindkey <Key-Return> {dofind 1 1}
2575 bindkey ? {dofind -1 1}
2576 bindkey f nextfile
2577 bind . <F5> updatecommits
2578 bindmodfunctionkey Shift 5 reloadcommits
2579 bind . <F2> showrefs
2580 bindmodfunctionkey Shift 4 {newview 0}
2581 bind . <F4> edit_or_newview
2582 bind . <$M1B-q> doquit
2583 bind . <$M1B-f> {dofind 1 1}
2584 bind . <$M1B-g> {dofind 1 0}
2585 bind . <$M1B-r> dosearchback
2586 bind . <$M1B-s> dosearch
2587 bind . <$M1B-equal> {incrfont 1}
2588 bind . <$M1B-plus> {incrfont 1}
2589 bind . <$M1B-KP_Add> {incrfont 1}
2590 bind . <$M1B-minus> {incrfont -1}
2591 bind . <$M1B-KP_Subtract> {incrfont -1}
2592 wm protocol . WM_DELETE_WINDOW doquit
2593 bind . <Destroy> {stop_backends}
2594 bind . <Button-1> "click %W"
2595 bind $fstring <Key-Return> {dofind 1 1}
2596 bind $sha1entry <Key-Return> {gotocommit; break}
2597 bind $sha1entry <<PasteSelection>> clearsha1
2598 bind $sha1entry <<Paste>> clearsha1
2599 bind $cflist <1> {sel_flist %W %x %y; break}
2600 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2601 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2602 global ctxbut
2603 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2604 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2605 bind $ctext <Button-1> {focus %W}
2606 bind $ctext <<Selection>> rehighlight_search_results
2607 for {set i 1} {$i < 10} {incr i} {
2608 bind . <$M1B-Key-$i> [list go_to_parent $i]
2609 }
2610
2611 set maincursor [. cget -cursor]
2612 set textcursor [$ctext cget -cursor]
2613 set curtextcursor $textcursor
2614
2615 set rowctxmenu .rowctxmenu
2616 makemenu $rowctxmenu {
2617 {mc "Diff this -> selected" command {diffvssel 0}}
2618 {mc "Diff selected -> this" command {diffvssel 1}}
2619 {mc "Make patch" command mkpatch}
2620 {mc "Create tag" command mktag}
2621 {mc "Write commit to file" command writecommit}
2622 {mc "Create new branch" command mkbranch}
2623 {mc "Cherry-pick this commit" command cherrypick}
2624 {mc "Reset HEAD branch to here" command resethead}
2625 {mc "Mark this commit" command markhere}
2626 {mc "Return to mark" command gotomark}
2627 {mc "Find descendant of this and mark" command find_common_desc}
2628 {mc "Compare with marked commit" command compare_commits}
2629 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2630 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2631 {mc "Revert this commit" command revert}
2632 }
2633 $rowctxmenu configure -tearoff 0
2634
2635 set fakerowmenu .fakerowmenu
2636 makemenu $fakerowmenu {
2637 {mc "Diff this -> selected" command {diffvssel 0}}
2638 {mc "Diff selected -> this" command {diffvssel 1}}
2639 {mc "Make patch" command mkpatch}
2640 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2641 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2642 }
2643 $fakerowmenu configure -tearoff 0
2644
2645 set headctxmenu .headctxmenu
2646 makemenu $headctxmenu {
2647 {mc "Check out this branch" command cobranch}
2648 {mc "Remove this branch" command rmbranch}
2649 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2650 }
2651 $headctxmenu configure -tearoff 0
2652
2653 global flist_menu
2654 set flist_menu .flistctxmenu
2655 makemenu $flist_menu {
2656 {mc "Highlight this too" command {flist_hl 0}}
2657 {mc "Highlight this only" command {flist_hl 1}}
2658 {mc "External diff" command {external_diff}}
2659 {mc "Blame parent commit" command {external_blame 1}}
2660 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2661 }
2662 $flist_menu configure -tearoff 0
2663
2664 global diff_menu
2665 set diff_menu .diffctxmenu
2666 makemenu $diff_menu {
2667 {mc "Show origin of this line" command show_line_source}
2668 {mc "Run git gui blame on this line" command {external_blame_diff}}
2669 }
2670 $diff_menu configure -tearoff 0
2671}
2672
2673# Windows sends all mouse wheel events to the current focused window, not
2674# the one where the mouse hovers, so bind those events here and redirect
2675# to the correct window
2676proc windows_mousewheel_redirector {W X Y D} {
2677 global canv canv2 canv3
2678 set w [winfo containing -displayof $W $X $Y]
2679 if {$w ne ""} {
2680 set u [expr {$D < 0 ? 5 : -5}]
2681 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2682 allcanvs yview scroll $u units
2683 } else {
2684 catch {
2685 $w yview scroll $u units
2686 }
2687 }
2688 }
2689}
2690
2691# Update row number label when selectedline changes
2692proc selectedline_change {n1 n2 op} {
2693 global selectedline rownumsel
2694
2695 if {$selectedline eq {}} {
2696 set rownumsel {}
2697 } else {
2698 set rownumsel [expr {$selectedline + 1}]
2699 }
2700}
2701
2702# mouse-2 makes all windows scan vertically, but only the one
2703# the cursor is in scans horizontally
2704proc canvscan {op w x y} {
2705 global canv canv2 canv3
2706 foreach c [list $canv $canv2 $canv3] {
2707 if {$c == $w} {
2708 $c scan $op $x $y
2709 } else {
2710 $c scan $op 0 $y
2711 }
2712 }
2713}
2714
2715proc scrollcanv {cscroll f0 f1} {
2716 $cscroll set $f0 $f1
2717 drawvisible
2718 flushhighlights
2719}
2720
2721# when we make a key binding for the toplevel, make sure
2722# it doesn't get triggered when that key is pressed in the
2723# find string entry widget.
2724proc bindkey {ev script} {
2725 global entries
2726 bind . $ev $script
2727 set escript [bind Entry $ev]
2728 if {$escript == {}} {
2729 set escript [bind Entry <Key>]
2730 }
2731 foreach e $entries {
2732 bind $e $ev "$escript; break"
2733 }
2734}
2735
2736proc bindmodfunctionkey {mod n script} {
2737 bind . <$mod-F$n> $script
2738 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2739}
2740
2741# set the focus back to the toplevel for any click outside
2742# the entry widgets
2743proc click {w} {
2744 global ctext entries
2745 foreach e [concat $entries $ctext] {
2746 if {$w == $e} return
2747 }
2748 focus .
2749}
2750
2751# Adjust the progress bar for a change in requested extent or canvas size
2752proc adjustprogress {} {
2753 global progresscanv progressitem progresscoords
2754 global fprogitem fprogcoord lastprogupdate progupdatepending
2755 global rprogitem rprogcoord use_ttk
2756
2757 if {$use_ttk} {
2758 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2759 return
2760 }
2761
2762 set w [expr {[winfo width $progresscanv] - 4}]
2763 set x0 [expr {$w * [lindex $progresscoords 0]}]
2764 set x1 [expr {$w * [lindex $progresscoords 1]}]
2765 set h [winfo height $progresscanv]
2766 $progresscanv coords $progressitem $x0 0 $x1 $h
2767 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2768 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2769 set now [clock clicks -milliseconds]
2770 if {$now >= $lastprogupdate + 100} {
2771 set progupdatepending 0
2772 update
2773 } elseif {!$progupdatepending} {
2774 set progupdatepending 1
2775 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2776 }
2777}
2778
2779proc doprogupdate {} {
2780 global lastprogupdate progupdatepending
2781
2782 if {$progupdatepending} {
2783 set progupdatepending 0
2784 set lastprogupdate [clock clicks -milliseconds]
2785 update
2786 }
2787}
2788
2789proc config_check_tmp_exists {tries_left} {
2790 global config_file_tmp
2791
2792 if {[file exists $config_file_tmp]} {
2793 incr tries_left -1
2794 if {$tries_left > 0} {
2795 after 100 [list config_check_tmp_exists $tries_left]
2796 } else {
2797 error_popup "There appears to be a stale $config_file_tmp\
2798 file, which will prevent gitk from saving its configuration on exit.\
2799 Please remove it if it is not being used by any existing gitk process."
2800 }
2801 }
2802}
2803
2804proc config_init_trace {name} {
2805 global config_variable_changed config_variable_original
2806
2807 upvar #0 $name var
2808 set config_variable_changed($name) 0
2809 set config_variable_original($name) $var
2810}
2811
2812proc config_variable_change_cb {name name2 op} {
2813 global config_variable_changed config_variable_original
2814
2815 upvar #0 $name var
2816 if {$op eq "write" &&
2817 (![info exists config_variable_original($name)] ||
2818 $config_variable_original($name) ne $var)} {
2819 set config_variable_changed($name) 1
2820 }
2821}
2822
2823proc savestuff {w} {
2824 global stuffsaved
2825 global config_file config_file_tmp
2826 global config_variables config_variable_changed
2827 global viewchanged
2828
2829 upvar #0 viewname current_viewname
2830 upvar #0 viewfiles current_viewfiles
2831 upvar #0 viewargs current_viewargs
2832 upvar #0 viewargscmd current_viewargscmd
2833 upvar #0 viewperm current_viewperm
2834 upvar #0 nextviewnum current_nextviewnum
2835 upvar #0 use_ttk current_use_ttk
2836
2837 if {$stuffsaved} return
2838 if {![winfo viewable .]} return
2839 set remove_tmp 0
2840 if {[catch {
2841 set try_count 0
2842 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2843 if {[incr try_count] > 50} {
2844 error "Unable to write config file: $config_file_tmp exists"
2845 }
2846 after 100
2847 }
2848 set remove_tmp 1
2849 if {$::tcl_platform(platform) eq {windows}} {
2850 file attributes $config_file_tmp -hidden true
2851 }
2852 if {[file exists $config_file]} {
2853 source $config_file
2854 }
2855 foreach var_name $config_variables {
2856 upvar #0 $var_name var
2857 upvar 0 $var_name old_var
2858 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2859 puts $f [list set $var_name $old_var]
2860 } else {
2861 puts $f [list set $var_name $var]
2862 }
2863 }
2864
2865 puts $f "set geometry(main) [wm geometry .]"
2866 puts $f "set geometry(state) [wm state .]"
2867 puts $f "set geometry(topwidth) [winfo width .tf]"
2868 puts $f "set geometry(topheight) [winfo height .tf]"
2869 if {$current_use_ttk} {
2870 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2871 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2872 } else {
2873 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2874 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2875 }
2876 puts $f "set geometry(botwidth) [winfo width .bleft]"
2877 puts $f "set geometry(botheight) [winfo height .bleft]"
2878
2879 array set view_save {}
2880 array set views {}
2881 if {![info exists permviews]} { set permviews {} }
2882 foreach view $permviews {
2883 set view_save([lindex $view 0]) 1
2884 set views([lindex $view 0]) $view
2885 }
2886 puts -nonewline $f "set permviews {"
2887 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2888 if {$viewchanged($v)} {
2889 if {$current_viewperm($v)} {
2890 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2891 } else {
2892 set view_save($current_viewname($v)) 0
2893 }
2894 }
2895 }
2896 # write old and updated view to their places and append remaining to the end
2897 foreach view $permviews {
2898 set view_name [lindex $view 0]
2899 if {$view_save($view_name)} {
2900 puts $f "{$views($view_name)}"
2901 }
2902 unset views($view_name)
2903 }
2904 foreach view_name [array names views] {
2905 puts $f "{$views($view_name)}"
2906 }
2907 puts $f "}"
2908 close $f
2909 file rename -force $config_file_tmp $config_file
2910 set remove_tmp 0
2911 } err]} {
2912 puts "Error saving config: $err"
2913 }
2914 if {$remove_tmp} {
2915 file delete -force $config_file_tmp
2916 }
2917 set stuffsaved 1
2918}
2919
2920proc resizeclistpanes {win w} {
2921 global oldwidth use_ttk
2922 if {[info exists oldwidth($win)]} {
2923 if {$use_ttk} {
2924 set s0 [$win sashpos 0]
2925 set s1 [$win sashpos 1]
2926 } else {
2927 set s0 [$win sash coord 0]
2928 set s1 [$win sash coord 1]
2929 }
2930 if {$w < 60} {
2931 set sash0 [expr {int($w/2 - 2)}]
2932 set sash1 [expr {int($w*5/6 - 2)}]
2933 } else {
2934 set factor [expr {1.0 * $w / $oldwidth($win)}]
2935 set sash0 [expr {int($factor * [lindex $s0 0])}]
2936 set sash1 [expr {int($factor * [lindex $s1 0])}]
2937 if {$sash0 < 30} {
2938 set sash0 30
2939 }
2940 if {$sash1 < $sash0 + 20} {
2941 set sash1 [expr {$sash0 + 20}]
2942 }
2943 if {$sash1 > $w - 10} {
2944 set sash1 [expr {$w - 10}]
2945 if {$sash0 > $sash1 - 20} {
2946 set sash0 [expr {$sash1 - 20}]
2947 }
2948 }
2949 }
2950 if {$use_ttk} {
2951 $win sashpos 0 $sash0
2952 $win sashpos 1 $sash1
2953 } else {
2954 $win sash place 0 $sash0 [lindex $s0 1]
2955 $win sash place 1 $sash1 [lindex $s1 1]
2956 }
2957 }
2958 set oldwidth($win) $w
2959}
2960
2961proc resizecdetpanes {win w} {
2962 global oldwidth use_ttk
2963 if {[info exists oldwidth($win)]} {
2964 if {$use_ttk} {
2965 set s0 [$win sashpos 0]
2966 } else {
2967 set s0 [$win sash coord 0]
2968 }
2969 if {$w < 60} {
2970 set sash0 [expr {int($w*3/4 - 2)}]
2971 } else {
2972 set factor [expr {1.0 * $w / $oldwidth($win)}]
2973 set sash0 [expr {int($factor * [lindex $s0 0])}]
2974 if {$sash0 < 45} {
2975 set sash0 45
2976 }
2977 if {$sash0 > $w - 15} {
2978 set sash0 [expr {$w - 15}]
2979 }
2980 }
2981 if {$use_ttk} {
2982 $win sashpos 0 $sash0
2983 } else {
2984 $win sash place 0 $sash0 [lindex $s0 1]
2985 }
2986 }
2987 set oldwidth($win) $w
2988}
2989
2990proc allcanvs args {
2991 global canv canv2 canv3
2992 eval $canv $args
2993 eval $canv2 $args
2994 eval $canv3 $args
2995}
2996
2997proc bindall {event action} {
2998 global canv canv2 canv3
2999 bind $canv $event $action
3000 bind $canv2 $event $action
3001 bind $canv3 $event $action
3002}
3003
3004proc about {} {
3005 global uifont NS
3006 set w .about
3007 if {[winfo exists $w]} {
3008 raise $w
3009 return
3010 }
3011 ttk_toplevel $w
3012 wm title $w [mc "About gitk"]
3013 make_transient $w .
3014 message $w.m -text [mc "
3015Gitk - a commit viewer for git
3016
3017Copyright \u00a9 2005-2014 Paul Mackerras
3018
3019Use and redistribute under the terms of the GNU General Public License"] \
3020 -justify center -aspect 400 -border 2 -bg white -relief groove
3021 pack $w.m -side top -fill x -padx 2 -pady 2
3022 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3023 pack $w.ok -side bottom
3024 bind $w <Visibility> "focus $w.ok"
3025 bind $w <Key-Escape> "destroy $w"
3026 bind $w <Key-Return> "destroy $w"
3027 tk::PlaceWindow $w widget .
3028}
3029
3030proc keys {} {
3031 global NS
3032 set w .keys
3033 if {[winfo exists $w]} {
3034 raise $w
3035 return
3036 }
3037 if {[tk windowingsystem] eq {aqua}} {
3038 set M1T Cmd
3039 } else {
3040 set M1T Ctrl
3041 }
3042 ttk_toplevel $w
3043 wm title $w [mc "Gitk key bindings"]
3044 make_transient $w .
3045 message $w.m -text "
3046[mc "Gitk key bindings:"]
3047
3048[mc "<%s-Q> Quit" $M1T]
3049[mc "<%s-W> Close window" $M1T]
3050[mc "<Home> Move to first commit"]
3051[mc "<End> Move to last commit"]
3052[mc "<Up>, p, k Move up one commit"]
3053[mc "<Down>, n, j Move down one commit"]
3054[mc "<Left>, z, h Go back in history list"]
3055[mc "<Right>, x, l Go forward in history list"]
3056[mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3057[mc "<PageUp> Move up one page in commit list"]
3058[mc "<PageDown> Move down one page in commit list"]
3059[mc "<%s-Home> Scroll to top of commit list" $M1T]
3060[mc "<%s-End> Scroll to bottom of commit list" $M1T]
3061[mc "<%s-Up> Scroll commit list up one line" $M1T]
3062[mc "<%s-Down> Scroll commit list down one line" $M1T]
3063[mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3064[mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3065[mc "<Shift-Up> Find backwards (upwards, later commits)"]
3066[mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3067[mc "<Delete>, b Scroll diff view up one page"]
3068[mc "<Backspace> Scroll diff view up one page"]
3069[mc "<Space> Scroll diff view down one page"]
3070[mc "u Scroll diff view up 18 lines"]
3071[mc "d Scroll diff view down 18 lines"]
3072[mc "<%s-F> Find" $M1T]
3073[mc "<%s-G> Move to next find hit" $M1T]
3074[mc "<Return> Move to next find hit"]
3075[mc "g Go to commit"]
3076[mc "/ Focus the search box"]
3077[mc "? Move to previous find hit"]
3078[mc "f Scroll diff view to next file"]
3079[mc "<%s-S> Search for next hit in diff view" $M1T]
3080[mc "<%s-R> Search for previous hit in diff view" $M1T]
3081[mc "<%s-KP+> Increase font size" $M1T]
3082[mc "<%s-plus> Increase font size" $M1T]
3083[mc "<%s-KP-> Decrease font size" $M1T]
3084[mc "<%s-minus> Decrease font size" $M1T]
3085[mc "<F5> Update"]
3086" \
3087 -justify left -bg white -border 2 -relief groove
3088 pack $w.m -side top -fill both -padx 2 -pady 2
3089 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3090 bind $w <Key-Escape> [list destroy $w]
3091 pack $w.ok -side bottom
3092 bind $w <Visibility> "focus $w.ok"
3093 bind $w <Key-Escape> "destroy $w"
3094 bind $w <Key-Return> "destroy $w"
3095}
3096
3097# Procedures for manipulating the file list window at the
3098# bottom right of the overall window.
3099
3100proc treeview {w l openlevs} {
3101 global treecontents treediropen treeheight treeparent treeindex
3102
3103 set ix 0
3104 set treeindex() 0
3105 set lev 0
3106 set prefix {}
3107 set prefixend -1
3108 set prefendstack {}
3109 set htstack {}
3110 set ht 0
3111 set treecontents() {}
3112 $w conf -state normal
3113 foreach f $l {
3114 while {[string range $f 0 $prefixend] ne $prefix} {
3115 if {$lev <= $openlevs} {
3116 $w mark set e:$treeindex($prefix) "end -1c"
3117 $w mark gravity e:$treeindex($prefix) left
3118 }
3119 set treeheight($prefix) $ht
3120 incr ht [lindex $htstack end]
3121 set htstack [lreplace $htstack end end]
3122 set prefixend [lindex $prefendstack end]
3123 set prefendstack [lreplace $prefendstack end end]
3124 set prefix [string range $prefix 0 $prefixend]
3125 incr lev -1
3126 }
3127 set tail [string range $f [expr {$prefixend+1}] end]
3128 while {[set slash [string first "/" $tail]] >= 0} {
3129 lappend htstack $ht
3130 set ht 0
3131 lappend prefendstack $prefixend
3132 incr prefixend [expr {$slash + 1}]
3133 set d [string range $tail 0 $slash]
3134 lappend treecontents($prefix) $d
3135 set oldprefix $prefix
3136 append prefix $d
3137 set treecontents($prefix) {}
3138 set treeindex($prefix) [incr ix]
3139 set treeparent($prefix) $oldprefix
3140 set tail [string range $tail [expr {$slash+1}] end]
3141 if {$lev <= $openlevs} {
3142 set ht 1
3143 set treediropen($prefix) [expr {$lev < $openlevs}]
3144 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3145 $w mark set d:$ix "end -1c"
3146 $w mark gravity d:$ix left
3147 set str "\n"
3148 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3149 $w insert end $str
3150 $w image create end -align center -image $bm -padx 1 \
3151 -name a:$ix
3152 $w insert end $d [highlight_tag $prefix]
3153 $w mark set s:$ix "end -1c"
3154 $w mark gravity s:$ix left
3155 }
3156 incr lev
3157 }
3158 if {$tail ne {}} {
3159 if {$lev <= $openlevs} {
3160 incr ht
3161 set str "\n"
3162 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3163 $w insert end $str
3164 $w insert end $tail [highlight_tag $f]
3165 }
3166 lappend treecontents($prefix) $tail
3167 }
3168 }
3169 while {$htstack ne {}} {
3170 set treeheight($prefix) $ht
3171 incr ht [lindex $htstack end]
3172 set htstack [lreplace $htstack end end]
3173 set prefixend [lindex $prefendstack end]
3174 set prefendstack [lreplace $prefendstack end end]
3175 set prefix [string range $prefix 0 $prefixend]
3176 }
3177 $w conf -state disabled
3178}
3179
3180proc linetoelt {l} {
3181 global treeheight treecontents
3182
3183 set y 2
3184 set prefix {}
3185 while {1} {
3186 foreach e $treecontents($prefix) {
3187 if {$y == $l} {
3188 return "$prefix$e"
3189 }
3190 set n 1
3191 if {[string index $e end] eq "/"} {
3192 set n $treeheight($prefix$e)
3193 if {$y + $n > $l} {
3194 append prefix $e
3195 incr y
3196 break
3197 }
3198 }
3199 incr y $n
3200 }
3201 }
3202}
3203
3204proc highlight_tree {y prefix} {
3205 global treeheight treecontents cflist
3206
3207 foreach e $treecontents($prefix) {
3208 set path $prefix$e
3209 if {[highlight_tag $path] ne {}} {
3210 $cflist tag add bold $y.0 "$y.0 lineend"
3211 }
3212 incr y
3213 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3214 set y [highlight_tree $y $path]
3215 }
3216 }
3217 return $y
3218}
3219
3220proc treeclosedir {w dir} {
3221 global treediropen treeheight treeparent treeindex
3222
3223 set ix $treeindex($dir)
3224 $w conf -state normal
3225 $w delete s:$ix e:$ix
3226 set treediropen($dir) 0
3227 $w image configure a:$ix -image tri-rt
3228 $w conf -state disabled
3229 set n [expr {1 - $treeheight($dir)}]
3230 while {$dir ne {}} {
3231 incr treeheight($dir) $n
3232 set dir $treeparent($dir)
3233 }
3234}
3235
3236proc treeopendir {w dir} {
3237 global treediropen treeheight treeparent treecontents treeindex
3238
3239 set ix $treeindex($dir)
3240 $w conf -state normal
3241 $w image configure a:$ix -image tri-dn
3242 $w mark set e:$ix s:$ix
3243 $w mark gravity e:$ix right
3244 set lev 0
3245 set str "\n"
3246 set n [llength $treecontents($dir)]
3247 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3248 incr lev
3249 append str "\t"
3250 incr treeheight($x) $n
3251 }
3252 foreach e $treecontents($dir) {
3253 set de $dir$e
3254 if {[string index $e end] eq "/"} {
3255 set iy $treeindex($de)
3256 $w mark set d:$iy e:$ix
3257 $w mark gravity d:$iy left
3258 $w insert e:$ix $str
3259 set treediropen($de) 0
3260 $w image create e:$ix -align center -image tri-rt -padx 1 \
3261 -name a:$iy
3262 $w insert e:$ix $e [highlight_tag $de]
3263 $w mark set s:$iy e:$ix
3264 $w mark gravity s:$iy left
3265 set treeheight($de) 1
3266 } else {
3267 $w insert e:$ix $str
3268 $w insert e:$ix $e [highlight_tag $de]
3269 }
3270 }
3271 $w mark gravity e:$ix right
3272 $w conf -state disabled
3273 set treediropen($dir) 1
3274 set top [lindex [split [$w index @0,0] .] 0]
3275 set ht [$w cget -height]
3276 set l [lindex [split [$w index s:$ix] .] 0]
3277 if {$l < $top} {
3278 $w yview $l.0
3279 } elseif {$l + $n + 1 > $top + $ht} {
3280 set top [expr {$l + $n + 2 - $ht}]
3281 if {$l < $top} {
3282 set top $l
3283 }
3284 $w yview $top.0
3285 }
3286}
3287
3288proc treeclick {w x y} {
3289 global treediropen cmitmode ctext cflist cflist_top
3290
3291 if {$cmitmode ne "tree"} return
3292 if {![info exists cflist_top]} return
3293 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3294 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3295 $cflist tag add highlight $l.0 "$l.0 lineend"
3296 set cflist_top $l
3297 if {$l == 1} {
3298 $ctext yview 1.0
3299 return
3300 }
3301 set e [linetoelt $l]
3302 if {[string index $e end] ne "/"} {
3303 showfile $e
3304 } elseif {$treediropen($e)} {
3305 treeclosedir $w $e
3306 } else {
3307 treeopendir $w $e
3308 }
3309}
3310
3311proc setfilelist {id} {
3312 global treefilelist cflist jump_to_here
3313
3314 treeview $cflist $treefilelist($id) 0
3315 if {$jump_to_here ne {}} {
3316 set f [lindex $jump_to_here 0]
3317 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3318 showfile $f
3319 }
3320 }
3321}
3322
3323image create bitmap tri-rt -background black -foreground blue -data {
3324 #define tri-rt_width 13
3325 #define tri-rt_height 13
3326 static unsigned char tri-rt_bits[] = {
3327 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3328 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3329 0x00, 0x00};
3330} -maskdata {
3331 #define tri-rt-mask_width 13
3332 #define tri-rt-mask_height 13
3333 static unsigned char tri-rt-mask_bits[] = {
3334 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3335 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3336 0x08, 0x00};
3337}
3338image create bitmap tri-dn -background black -foreground blue -data {
3339 #define tri-dn_width 13
3340 #define tri-dn_height 13
3341 static unsigned char tri-dn_bits[] = {
3342 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3343 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3344 0x00, 0x00};
3345} -maskdata {
3346 #define tri-dn-mask_width 13
3347 #define tri-dn-mask_height 13
3348 static unsigned char tri-dn-mask_bits[] = {
3349 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3350 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3351 0x00, 0x00};
3352}
3353
3354image create bitmap reficon-T -background black -foreground yellow -data {
3355 #define tagicon_width 13
3356 #define tagicon_height 9
3357 static unsigned char tagicon_bits[] = {
3358 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3359 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3360} -maskdata {
3361 #define tagicon-mask_width 13
3362 #define tagicon-mask_height 9
3363 static unsigned char tagicon-mask_bits[] = {
3364 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3365 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3366}
3367set rectdata {
3368 #define headicon_width 13
3369 #define headicon_height 9
3370 static unsigned char headicon_bits[] = {
3371 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3372 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3373}
3374set rectmask {
3375 #define headicon-mask_width 13
3376 #define headicon-mask_height 9
3377 static unsigned char headicon-mask_bits[] = {
3378 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3379 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3380}
3381image create bitmap reficon-H -background black -foreground green \
3382 -data $rectdata -maskdata $rectmask
3383image create bitmap reficon-o -background black -foreground "#ddddff" \
3384 -data $rectdata -maskdata $rectmask
3385
3386proc init_flist {first} {
3387 global cflist cflist_top difffilestart
3388
3389 $cflist conf -state normal
3390 $cflist delete 0.0 end
3391 if {$first ne {}} {
3392 $cflist insert end $first
3393 set cflist_top 1
3394 $cflist tag add highlight 1.0 "1.0 lineend"
3395 } else {
3396 unset -nocomplain cflist_top
3397 }
3398 $cflist conf -state disabled
3399 set difffilestart {}
3400}
3401
3402proc highlight_tag {f} {
3403 global highlight_paths
3404
3405 foreach p $highlight_paths {
3406 if {[string match $p $f]} {
3407 return "bold"
3408 }
3409 }
3410 return {}
3411}
3412
3413proc highlight_filelist {} {
3414 global cmitmode cflist
3415
3416 $cflist conf -state normal
3417 if {$cmitmode ne "tree"} {
3418 set end [lindex [split [$cflist index end] .] 0]
3419 for {set l 2} {$l < $end} {incr l} {
3420 set line [$cflist get $l.0 "$l.0 lineend"]
3421 if {[highlight_tag $line] ne {}} {
3422 $cflist tag add bold $l.0 "$l.0 lineend"
3423 }
3424 }
3425 } else {
3426 highlight_tree 2 {}
3427 }
3428 $cflist conf -state disabled
3429}
3430
3431proc unhighlight_filelist {} {
3432 global cflist
3433
3434 $cflist conf -state normal
3435 $cflist tag remove bold 1.0 end
3436 $cflist conf -state disabled
3437}
3438
3439proc add_flist {fl} {
3440 global cflist
3441
3442 $cflist conf -state normal
3443 foreach f $fl {
3444 $cflist insert end "\n"
3445 $cflist insert end $f [highlight_tag $f]
3446 }
3447 $cflist conf -state disabled
3448}
3449
3450proc sel_flist {w x y} {
3451 global ctext difffilestart cflist cflist_top cmitmode
3452
3453 if {$cmitmode eq "tree"} return
3454 if {![info exists cflist_top]} return
3455 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3456 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3457 $cflist tag add highlight $l.0 "$l.0 lineend"
3458 set cflist_top $l
3459 if {$l == 1} {
3460 $ctext yview 1.0
3461 } else {
3462 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3463 }
3464 suppress_highlighting_file_for_current_scrollpos
3465}
3466
3467proc pop_flist_menu {w X Y x y} {
3468 global ctext cflist cmitmode flist_menu flist_menu_file
3469 global treediffs diffids
3470
3471 stopfinding
3472 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3473 if {$l <= 1} return
3474 if {$cmitmode eq "tree"} {
3475 set e [linetoelt $l]
3476 if {[string index $e end] eq "/"} return
3477 } else {
3478 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3479 }
3480 set flist_menu_file $e
3481 set xdiffstate "normal"
3482 if {$cmitmode eq "tree"} {
3483 set xdiffstate "disabled"
3484 }
3485 # Disable "External diff" item in tree mode
3486 $flist_menu entryconf 2 -state $xdiffstate
3487 tk_popup $flist_menu $X $Y
3488}
3489
3490proc find_ctext_fileinfo {line} {
3491 global ctext_file_names ctext_file_lines
3492
3493 set ok [bsearch $ctext_file_lines $line]
3494 set tline [lindex $ctext_file_lines $ok]
3495
3496 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3497 return {}
3498 } else {
3499 return [list [lindex $ctext_file_names $ok] $tline]
3500 }
3501}
3502
3503proc pop_diff_menu {w X Y x y} {
3504 global ctext diff_menu flist_menu_file
3505 global diff_menu_txtpos diff_menu_line
3506 global diff_menu_filebase
3507
3508 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3509 set diff_menu_line [lindex $diff_menu_txtpos 0]
3510 # don't pop up the menu on hunk-separator or file-separator lines
3511 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3512 return
3513 }
3514 stopfinding
3515 set f [find_ctext_fileinfo $diff_menu_line]
3516 if {$f eq {}} return
3517 set flist_menu_file [lindex $f 0]
3518 set diff_menu_filebase [lindex $f 1]
3519 tk_popup $diff_menu $X $Y
3520}
3521
3522proc flist_hl {only} {
3523 global flist_menu_file findstring gdttype
3524
3525 set x [shellquote $flist_menu_file]
3526 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3527 set findstring $x
3528 } else {
3529 append findstring " " $x
3530 }
3531 set gdttype [mc "touching paths:"]
3532}
3533
3534proc gitknewtmpdir {} {
3535 global diffnum gitktmpdir gitdir env
3536
3537 if {![info exists gitktmpdir]} {
3538 if {[info exists env(GITK_TMPDIR)]} {
3539 set tmpdir $env(GITK_TMPDIR)
3540 } elseif {[info exists env(TMPDIR)]} {
3541 set tmpdir $env(TMPDIR)
3542 } else {
3543 set tmpdir $gitdir
3544 }
3545 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3546 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3547 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3548 }
3549 if {[catch {file mkdir $gitktmpdir} err]} {
3550 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3551 unset gitktmpdir
3552 return {}
3553 }
3554 set diffnum 0
3555 }
3556 incr diffnum
3557 set diffdir [file join $gitktmpdir $diffnum]
3558 if {[catch {file mkdir $diffdir} err]} {
3559 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3560 return {}
3561 }
3562 return $diffdir
3563}
3564
3565proc save_file_from_commit {filename output what} {
3566 global nullfile
3567
3568 if {[catch {exec git show $filename -- > $output} err]} {
3569 if {[string match "fatal: bad revision *" $err]} {
3570 return $nullfile
3571 }
3572 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3573 return {}
3574 }
3575 return $output
3576}
3577
3578proc external_diff_get_one_file {diffid filename diffdir} {
3579 global nullid nullid2 nullfile
3580 global worktree
3581
3582 if {$diffid == $nullid} {
3583 set difffile [file join $worktree $filename]
3584 if {[file exists $difffile]} {
3585 return $difffile
3586 }
3587 return $nullfile
3588 }
3589 if {$diffid == $nullid2} {
3590 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3591 return [save_file_from_commit :$filename $difffile index]
3592 }
3593 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3594 return [save_file_from_commit $diffid:$filename $difffile \
3595 "revision $diffid"]
3596}
3597
3598proc external_diff {} {
3599 global nullid nullid2
3600 global flist_menu_file
3601 global diffids
3602 global extdifftool
3603
3604 if {[llength $diffids] == 1} {
3605 # no reference commit given
3606 set diffidto [lindex $diffids 0]
3607 if {$diffidto eq $nullid} {
3608 # diffing working copy with index
3609 set diffidfrom $nullid2
3610 } elseif {$diffidto eq $nullid2} {
3611 # diffing index with HEAD
3612 set diffidfrom "HEAD"
3613 } else {
3614 # use first parent commit
3615 global parentlist selectedline
3616 set diffidfrom [lindex $parentlist $selectedline 0]
3617 }
3618 } else {
3619 set diffidfrom [lindex $diffids 0]
3620 set diffidto [lindex $diffids 1]
3621 }
3622
3623 # make sure that several diffs wont collide
3624 set diffdir [gitknewtmpdir]
3625 if {$diffdir eq {}} return
3626
3627 # gather files to diff
3628 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3629 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3630
3631 if {$difffromfile ne {} && $difftofile ne {}} {
3632 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3633 if {[catch {set fl [open |$cmd r]} err]} {
3634 file delete -force $diffdir
3635 error_popup "$extdifftool: [mc "command failed:"] $err"
3636 } else {
3637 fconfigure $fl -blocking 0
3638 filerun $fl [list delete_at_eof $fl $diffdir]
3639 }
3640 }
3641}
3642
3643proc find_hunk_blamespec {base line} {
3644 global ctext
3645
3646 # Find and parse the hunk header
3647 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3648 if {$s_lix eq {}} return
3649
3650 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3651 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3652 s_line old_specs osz osz1 new_line nsz]} {
3653 return
3654 }
3655
3656 # base lines for the parents
3657 set base_lines [list $new_line]
3658 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3659 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3660 old_spec old_line osz]} {
3661 return
3662 }
3663 lappend base_lines $old_line
3664 }
3665
3666 # Now scan the lines to determine offset within the hunk
3667 set max_parent [expr {[llength $base_lines]-2}]
3668 set dline 0
3669 set s_lno [lindex [split $s_lix "."] 0]
3670
3671 # Determine if the line is removed
3672 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3673 if {[string match {[-+ ]*} $chunk]} {
3674 set removed_idx [string first "-" $chunk]
3675 # Choose a parent index
3676 if {$removed_idx >= 0} {
3677 set parent $removed_idx
3678 } else {
3679 set unchanged_idx [string first " " $chunk]
3680 if {$unchanged_idx >= 0} {
3681 set parent $unchanged_idx
3682 } else {
3683 # blame the current commit
3684 set parent -1
3685 }
3686 }
3687 # then count other lines that belong to it
3688 for {set i $line} {[incr i -1] > $s_lno} {} {
3689 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3690 # Determine if the line is removed
3691 set removed_idx [string first "-" $chunk]
3692 if {$parent >= 0} {
3693 set code [string index $chunk $parent]
3694 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3695 incr dline
3696 }
3697 } else {
3698 if {$removed_idx < 0} {
3699 incr dline
3700 }
3701 }
3702 }
3703 incr parent
3704 } else {
3705 set parent 0
3706 }
3707
3708 incr dline [lindex $base_lines $parent]
3709 return [list $parent $dline]
3710}
3711
3712proc external_blame_diff {} {
3713 global currentid cmitmode
3714 global diff_menu_txtpos diff_menu_line
3715 global diff_menu_filebase flist_menu_file
3716
3717 if {$cmitmode eq "tree"} {
3718 set parent_idx 0
3719 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3720 } else {
3721 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3722 if {$hinfo ne {}} {
3723 set parent_idx [lindex $hinfo 0]
3724 set line [lindex $hinfo 1]
3725 } else {
3726 set parent_idx 0
3727 set line 0
3728 }
3729 }
3730
3731 external_blame $parent_idx $line
3732}
3733
3734# Find the SHA1 ID of the blob for file $fname in the index
3735# at stage 0 or 2
3736proc index_sha1 {fname} {
3737 set f [open [list | git ls-files -s $fname] r]
3738 while {[gets $f line] >= 0} {
3739 set info [lindex [split $line "\t"] 0]
3740 set stage [lindex $info 2]
3741 if {$stage eq "0" || $stage eq "2"} {
3742 close $f
3743 return [lindex $info 1]
3744 }
3745 }
3746 close $f
3747 return {}
3748}
3749
3750# Turn an absolute path into one relative to the current directory
3751proc make_relative {f} {
3752 if {[file pathtype $f] eq "relative"} {
3753 return $f
3754 }
3755 set elts [file split $f]
3756 set here [file split [pwd]]
3757 set ei 0
3758 set hi 0
3759 set res {}
3760 foreach d $here {
3761 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3762 lappend res ".."
3763 } else {
3764 incr ei
3765 }
3766 incr hi
3767 }
3768 set elts [concat $res [lrange $elts $ei end]]
3769 return [eval file join $elts]
3770}
3771
3772proc external_blame {parent_idx {line {}}} {
3773 global flist_menu_file cdup
3774 global nullid nullid2
3775 global parentlist selectedline currentid
3776
3777 if {$parent_idx > 0} {
3778 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3779 } else {
3780 set base_commit $currentid
3781 }
3782
3783 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3784 error_popup [mc "No such commit"]
3785 return
3786 }
3787
3788 set cmdline [list git gui blame]
3789 if {$line ne {} && $line > 1} {
3790 lappend cmdline "--line=$line"
3791 }
3792 set f [file join $cdup $flist_menu_file]
3793 # Unfortunately it seems git gui blame doesn't like
3794 # being given an absolute path...
3795 set f [make_relative $f]
3796 lappend cmdline $base_commit $f
3797 if {[catch {eval exec $cmdline &} err]} {
3798 error_popup "[mc "git gui blame: command failed:"] $err"
3799 }
3800}
3801
3802proc show_line_source {} {
3803 global cmitmode currentid parents curview blamestuff blameinst
3804 global diff_menu_line diff_menu_filebase flist_menu_file
3805 global nullid nullid2 gitdir cdup
3806
3807 set from_index {}
3808 if {$cmitmode eq "tree"} {
3809 set id $currentid
3810 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3811 } else {
3812 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3813 if {$h eq {}} return
3814 set pi [lindex $h 0]
3815 if {$pi == 0} {
3816 mark_ctext_line $diff_menu_line
3817 return
3818 }
3819 incr pi -1
3820 if {$currentid eq $nullid} {
3821 if {$pi > 0} {
3822 # must be a merge in progress...
3823 if {[catch {
3824 # get the last line from .git/MERGE_HEAD
3825 set f [open [file join $gitdir MERGE_HEAD] r]
3826 set id [lindex [split [read $f] "\n"] end-1]
3827 close $f
3828 } err]} {
3829 error_popup [mc "Couldn't read merge head: %s" $err]
3830 return
3831 }
3832 } elseif {$parents($curview,$currentid) eq $nullid2} {
3833 # need to do the blame from the index
3834 if {[catch {
3835 set from_index [index_sha1 $flist_menu_file]
3836 } err]} {
3837 error_popup [mc "Error reading index: %s" $err]
3838 return
3839 }
3840 } else {
3841 set id $parents($curview,$currentid)
3842 }
3843 } else {
3844 set id [lindex $parents($curview,$currentid) $pi]
3845 }
3846 set line [lindex $h 1]
3847 }
3848 set blameargs {}
3849 if {$from_index ne {}} {
3850 lappend blameargs | git cat-file blob $from_index
3851 }
3852 lappend blameargs | git blame -p -L$line,+1
3853 if {$from_index ne {}} {
3854 lappend blameargs --contents -
3855 } else {
3856 lappend blameargs $id
3857 }
3858 lappend blameargs -- [file join $cdup $flist_menu_file]
3859 if {[catch {
3860 set f [open $blameargs r]
3861 } err]} {
3862 error_popup [mc "Couldn't start git blame: %s" $err]
3863 return
3864 }
3865 nowbusy blaming [mc "Searching"]
3866 fconfigure $f -blocking 0
3867 set i [reg_instance $f]
3868 set blamestuff($i) {}
3869 set blameinst $i
3870 filerun $f [list read_line_source $f $i]
3871}
3872
3873proc stopblaming {} {
3874 global blameinst
3875
3876 if {[info exists blameinst]} {
3877 stop_instance $blameinst
3878 unset blameinst
3879 notbusy blaming
3880 }
3881}
3882
3883proc read_line_source {fd inst} {
3884 global blamestuff curview commfd blameinst nullid nullid2
3885
3886 while {[gets $fd line] >= 0} {
3887 lappend blamestuff($inst) $line
3888 }
3889 if {![eof $fd]} {
3890 return 1
3891 }
3892 unset commfd($inst)
3893 unset blameinst
3894 notbusy blaming
3895 fconfigure $fd -blocking 1
3896 if {[catch {close $fd} err]} {
3897 error_popup [mc "Error running git blame: %s" $err]
3898 return 0
3899 }
3900
3901 set fname {}
3902 set line [split [lindex $blamestuff($inst) 0] " "]
3903 set id [lindex $line 0]
3904 set lnum [lindex $line 1]
3905 if {[string length $id] == 40 && [string is xdigit $id] &&
3906 [string is digit -strict $lnum]} {
3907 # look for "filename" line
3908 foreach l $blamestuff($inst) {
3909 if {[string match "filename *" $l]} {
3910 set fname [string range $l 9 end]
3911 break
3912 }
3913 }
3914 }
3915 if {$fname ne {}} {
3916 # all looks good, select it
3917 if {$id eq $nullid} {
3918 # blame uses all-zeroes to mean not committed,
3919 # which would mean a change in the index
3920 set id $nullid2
3921 }
3922 if {[commitinview $id $curview]} {
3923 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3924 } else {
3925 error_popup [mc "That line comes from commit %s, \
3926 which is not in this view" [shortids $id]]
3927 }
3928 } else {
3929 puts "oops couldn't parse git blame output"
3930 }
3931 return 0
3932}
3933
3934# delete $dir when we see eof on $f (presumably because the child has exited)
3935proc delete_at_eof {f dir} {
3936 while {[gets $f line] >= 0} {}
3937 if {[eof $f]} {
3938 if {[catch {close $f} err]} {
3939 error_popup "[mc "External diff viewer failed:"] $err"
3940 }
3941 file delete -force $dir
3942 return 0
3943 }
3944 return 1
3945}
3946
3947# Functions for adding and removing shell-type quoting
3948
3949proc shellquote {str} {
3950 if {![string match "*\['\"\\ \t]*" $str]} {
3951 return $str
3952 }
3953 if {![string match "*\['\"\\]*" $str]} {
3954 return "\"$str\""
3955 }
3956 if {![string match "*'*" $str]} {
3957 return "'$str'"
3958 }
3959 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3960}
3961
3962proc shellarglist {l} {
3963 set str {}
3964 foreach a $l {
3965 if {$str ne {}} {
3966 append str " "
3967 }
3968 append str [shellquote $a]
3969 }
3970 return $str
3971}
3972
3973proc shelldequote {str} {
3974 set ret {}
3975 set used -1
3976 while {1} {
3977 incr used
3978 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3979 append ret [string range $str $used end]
3980 set used [string length $str]
3981 break
3982 }
3983 set first [lindex $first 0]
3984 set ch [string index $str $first]
3985 if {$first > $used} {
3986 append ret [string range $str $used [expr {$first - 1}]]
3987 set used $first
3988 }
3989 if {$ch eq " " || $ch eq "\t"} break
3990 incr used
3991 if {$ch eq "'"} {
3992 set first [string first "'" $str $used]
3993 if {$first < 0} {
3994 error "unmatched single-quote"
3995 }
3996 append ret [string range $str $used [expr {$first - 1}]]
3997 set used $first
3998 continue
3999 }
4000 if {$ch eq "\\"} {
4001 if {$used >= [string length $str]} {
4002 error "trailing backslash"
4003 }
4004 append ret [string index $str $used]
4005 continue
4006 }
4007 # here ch == "\""
4008 while {1} {
4009 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4010 error "unmatched double-quote"
4011 }
4012 set first [lindex $first 0]
4013 set ch [string index $str $first]
4014 if {$first > $used} {
4015 append ret [string range $str $used [expr {$first - 1}]]
4016 set used $first
4017 }
4018 if {$ch eq "\""} break
4019 incr used
4020 append ret [string index $str $used]
4021 incr used
4022 }
4023 }
4024 return [list $used $ret]
4025}
4026
4027proc shellsplit {str} {
4028 set l {}
4029 while {1} {
4030 set str [string trimleft $str]
4031 if {$str eq {}} break
4032 set dq [shelldequote $str]
4033 set n [lindex $dq 0]
4034 set word [lindex $dq 1]
4035 set str [string range $str $n end]
4036 lappend l $word
4037 }
4038 return $l
4039}
4040
4041proc set_window_title {} {
4042 global appname curview viewname vrevs
4043 set rev [mc "All files"]
4044 if {$curview ne 0} {
4045 if {$viewname($curview) eq [mc "Command line"]} {
4046 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4047 } else {
4048 set rev $viewname($curview)
4049 }
4050 }
4051 wm title . "[reponame]: $rev - $appname"
4052}
4053
4054# Code to implement multiple views
4055
4056proc newview {ishighlight} {
4057 global nextviewnum newviewname newishighlight
4058 global revtreeargs viewargscmd newviewopts curview
4059
4060 set newishighlight $ishighlight
4061 set top .gitkview
4062 if {[winfo exists $top]} {
4063 raise $top
4064 return
4065 }
4066 decode_view_opts $nextviewnum $revtreeargs
4067 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4068 set newviewopts($nextviewnum,perm) 0
4069 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4070 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4071}
4072
4073set known_view_options {
4074 {perm b . {} {mc "Remember this view"}}
4075 {reflabel l + {} {mc "References (space separated list):"}}
4076 {refs t15 .. {} {mc "Branches & tags:"}}
4077 {allrefs b *. "--all" {mc "All refs"}}
4078 {branches b . "--branches" {mc "All (local) branches"}}
4079 {tags b . "--tags" {mc "All tags"}}
4080 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4081 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4082 {author t15 .. "--author=*" {mc "Author:"}}
4083 {committer t15 . "--committer=*" {mc "Committer:"}}
4084 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4085 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4086 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4087 {changes_l l + {} {mc "Changes to Files:"}}
4088 {pickaxe_s r0 . {} {mc "Fixed String"}}
4089 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4090 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4091 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4092 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4093 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4094 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4095 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4096 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4097 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4098 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4099 {lright b . "--left-right" {mc "Mark branch sides"}}
4100 {first b . "--first-parent" {mc "Limit to first parent"}}
4101 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4102 {args t50 *. {} {mc "Additional arguments to git log:"}}
4103 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4104 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4105 }
4106
4107# Convert $newviewopts($n, ...) into args for git log.
4108proc encode_view_opts {n} {
4109 global known_view_options newviewopts
4110
4111 set rargs [list]
4112 foreach opt $known_view_options {
4113 set patterns [lindex $opt 3]
4114 if {$patterns eq {}} continue
4115 set pattern [lindex $patterns 0]
4116
4117 if {[lindex $opt 1] eq "b"} {
4118 set val $newviewopts($n,[lindex $opt 0])
4119 if {$val} {
4120 lappend rargs $pattern
4121 }
4122 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4123 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4124 set val $newviewopts($n,$button_id)
4125 if {$val eq $value} {
4126 lappend rargs $pattern
4127 }
4128 } else {
4129 set val $newviewopts($n,[lindex $opt 0])
4130 set val [string trim $val]
4131 if {$val ne {}} {
4132 set pfix [string range $pattern 0 end-1]
4133 lappend rargs $pfix$val
4134 }
4135 }
4136 }
4137 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4138 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4139}
4140
4141# Fill $newviewopts($n, ...) based on args for git log.
4142proc decode_view_opts {n view_args} {
4143 global known_view_options newviewopts
4144
4145 foreach opt $known_view_options {
4146 set id [lindex $opt 0]
4147 if {[lindex $opt 1] eq "b"} {
4148 # Checkboxes
4149 set val 0
4150 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4151 # Radiobuttons
4152 regexp {^(.*_)} $id uselessvar id
4153 set val 0
4154 } else {
4155 # Text fields
4156 set val {}
4157 }
4158 set newviewopts($n,$id) $val
4159 }
4160 set oargs [list]
4161 set refargs [list]
4162 foreach arg $view_args {
4163 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4164 && ![info exists found(limit)]} {
4165 set newviewopts($n,limit) $cnt
4166 set found(limit) 1
4167 continue
4168 }
4169 catch { unset val }
4170 foreach opt $known_view_options {
4171 set id [lindex $opt 0]
4172 if {[info exists found($id)]} continue
4173 foreach pattern [lindex $opt 3] {
4174 if {![string match $pattern $arg]} continue
4175 if {[lindex $opt 1] eq "b"} {
4176 # Check buttons
4177 set val 1
4178 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4179 # Radio buttons
4180 regexp {^(.*_)} $id uselessvar id
4181 set val $num
4182 } else {
4183 # Text input fields
4184 set size [string length $pattern]
4185 set val [string range $arg [expr {$size-1}] end]
4186 }
4187 set newviewopts($n,$id) $val
4188 set found($id) 1
4189 break
4190 }
4191 if {[info exists val]} break
4192 }
4193 if {[info exists val]} continue
4194 if {[regexp {^-} $arg]} {
4195 lappend oargs $arg
4196 } else {
4197 lappend refargs $arg
4198 }
4199 }
4200 set newviewopts($n,refs) [shellarglist $refargs]
4201 set newviewopts($n,args) [shellarglist $oargs]
4202}
4203
4204proc edit_or_newview {} {
4205 global curview
4206
4207 if {$curview > 0} {
4208 editview
4209 } else {
4210 newview 0
4211 }
4212}
4213
4214proc editview {} {
4215 global curview
4216 global viewname viewperm newviewname newviewopts
4217 global viewargs viewargscmd
4218
4219 set top .gitkvedit-$curview
4220 if {[winfo exists $top]} {
4221 raise $top
4222 return
4223 }
4224 decode_view_opts $curview $viewargs($curview)
4225 set newviewname($curview) $viewname($curview)
4226 set newviewopts($curview,perm) $viewperm($curview)
4227 set newviewopts($curview,cmd) $viewargscmd($curview)
4228 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4229}
4230
4231proc vieweditor {top n title} {
4232 global newviewname newviewopts viewfiles bgcolor
4233 global known_view_options NS
4234
4235 ttk_toplevel $top
4236 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4237 make_transient $top .
4238
4239 # View name
4240 ${NS}::frame $top.nfr
4241 ${NS}::label $top.nl -text [mc "View Name"]
4242 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4243 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4244 pack $top.nl -in $top.nfr -side left -padx {0 5}
4245 pack $top.name -in $top.nfr -side left -padx {0 25}
4246
4247 # View options
4248 set cframe $top.nfr
4249 set cexpand 0
4250 set cnt 0
4251 foreach opt $known_view_options {
4252 set id [lindex $opt 0]
4253 set type [lindex $opt 1]
4254 set flags [lindex $opt 2]
4255 set title [eval [lindex $opt 4]]
4256 set lxpad 0
4257
4258 if {$flags eq "+" || $flags eq "*"} {
4259 set cframe $top.fr$cnt
4260 incr cnt
4261 ${NS}::frame $cframe
4262 pack $cframe -in $top -fill x -pady 3 -padx 3
4263 set cexpand [expr {$flags eq "*"}]
4264 } elseif {$flags eq ".." || $flags eq "*."} {
4265 set cframe $top.fr$cnt
4266 incr cnt
4267 ${NS}::frame $cframe
4268 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4269 set cexpand [expr {$flags eq "*."}]
4270 } else {
4271 set lxpad 5
4272 }
4273
4274 if {$type eq "l"} {
4275 ${NS}::label $cframe.l_$id -text $title
4276 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4277 } elseif {$type eq "b"} {
4278 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4279 pack $cframe.c_$id -in $cframe -side left \
4280 -padx [list $lxpad 0] -expand $cexpand -anchor w
4281 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4282 regexp {^(.*_)} $id uselessvar button_id
4283 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4284 pack $cframe.c_$id -in $cframe -side left \
4285 -padx [list $lxpad 0] -expand $cexpand -anchor w
4286 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4287 ${NS}::label $cframe.l_$id -text $title
4288 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4289 -textvariable newviewopts($n,$id)
4290 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4291 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4292 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4293 ${NS}::label $cframe.l_$id -text $title
4294 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4295 -textvariable newviewopts($n,$id)
4296 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4297 pack $cframe.e_$id -in $cframe -side top -fill x
4298 } elseif {$type eq "path"} {
4299 ${NS}::label $top.l -text $title
4300 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4301 text $top.t -width 40 -height 5 -background $bgcolor
4302 if {[info exists viewfiles($n)]} {
4303 foreach f $viewfiles($n) {
4304 $top.t insert end $f
4305 $top.t insert end "\n"
4306 }
4307 $top.t delete {end - 1c} end
4308 $top.t mark set insert 0.0
4309 }
4310 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4311 }
4312 }
4313
4314 ${NS}::frame $top.buts
4315 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4316 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4317 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4318 bind $top <Control-Return> [list newviewok $top $n]
4319 bind $top <F5> [list newviewok $top $n 1]
4320 bind $top <Escape> [list destroy $top]
4321 grid $top.buts.ok $top.buts.apply $top.buts.can
4322 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4323 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4324 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4325 pack $top.buts -in $top -side top -fill x
4326 focus $top.t
4327}
4328
4329proc doviewmenu {m first cmd op argv} {
4330 set nmenu [$m index end]
4331 for {set i $first} {$i <= $nmenu} {incr i} {
4332 if {[$m entrycget $i -command] eq $cmd} {
4333 eval $m $op $i $argv
4334 break
4335 }
4336 }
4337}
4338
4339proc allviewmenus {n op args} {
4340 # global viewhlmenu
4341
4342 doviewmenu .bar.view 5 [list showview $n] $op $args
4343 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4344}
4345
4346proc newviewok {top n {apply 0}} {
4347 global nextviewnum newviewperm newviewname newishighlight
4348 global viewname viewfiles viewperm viewchanged selectedview curview
4349 global viewargs viewargscmd newviewopts viewhlmenu
4350
4351 if {[catch {
4352 set newargs [encode_view_opts $n]
4353 } err]} {
4354 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4355 return
4356 }
4357 set files {}
4358 foreach f [split [$top.t get 0.0 end] "\n"] {
4359 set ft [string trim $f]
4360 if {$ft ne {}} {
4361 lappend files $ft
4362 }
4363 }
4364 if {![info exists viewfiles($n)]} {
4365 # creating a new view
4366 incr nextviewnum
4367 set viewname($n) $newviewname($n)
4368 set viewperm($n) $newviewopts($n,perm)
4369 set viewchanged($n) 1
4370 set viewfiles($n) $files
4371 set viewargs($n) $newargs
4372 set viewargscmd($n) $newviewopts($n,cmd)
4373 addviewmenu $n
4374 if {!$newishighlight} {
4375 run showview $n
4376 } else {
4377 run addvhighlight $n
4378 }
4379 } else {
4380 # editing an existing view
4381 set viewperm($n) $newviewopts($n,perm)
4382 set viewchanged($n) 1
4383 if {$newviewname($n) ne $viewname($n)} {
4384 set viewname($n) $newviewname($n)
4385 doviewmenu .bar.view 5 [list showview $n] \
4386 entryconf [list -label $viewname($n)]
4387 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4388 # entryconf [list -label $viewname($n) -value $viewname($n)]
4389 }
4390 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4391 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4392 set viewfiles($n) $files
4393 set viewargs($n) $newargs
4394 set viewargscmd($n) $newviewopts($n,cmd)
4395 if {$curview == $n} {
4396 run reloadcommits
4397 }
4398 }
4399 }
4400 if {$apply} return
4401 catch {destroy $top}
4402}
4403
4404proc delview {} {
4405 global curview viewperm hlview selectedhlview viewchanged
4406
4407 if {$curview == 0} return
4408 if {[info exists hlview] && $hlview == $curview} {
4409 set selectedhlview [mc "None"]
4410 unset hlview
4411 }
4412 allviewmenus $curview delete
4413 set viewperm($curview) 0
4414 set viewchanged($curview) 1
4415 showview 0
4416}
4417
4418proc addviewmenu {n} {
4419 global viewname viewhlmenu
4420
4421 .bar.view add radiobutton -label $viewname($n) \
4422 -command [list showview $n] -variable selectedview -value $n
4423 #$viewhlmenu add radiobutton -label $viewname($n) \
4424 # -command [list addvhighlight $n] -variable selectedhlview
4425}
4426
4427proc showview {n} {
4428 global curview cached_commitrow ordertok
4429 global displayorder parentlist rowidlist rowisopt rowfinal
4430 global colormap rowtextx nextcolor canvxmax
4431 global numcommits viewcomplete
4432 global selectedline currentid canv canvy0
4433 global treediffs
4434 global pending_select mainheadid
4435 global commitidx
4436 global selectedview
4437 global hlview selectedhlview commitinterest
4438
4439 if {$n == $curview} return
4440 set selid {}
4441 set ymax [lindex [$canv cget -scrollregion] 3]
4442 set span [$canv yview]
4443 set ytop [expr {[lindex $span 0] * $ymax}]
4444 set ybot [expr {[lindex $span 1] * $ymax}]
4445 set yscreen [expr {($ybot - $ytop) / 2}]
4446 if {$selectedline ne {}} {
4447 set selid $currentid
4448 set y [yc $selectedline]
4449 if {$ytop < $y && $y < $ybot} {
4450 set yscreen [expr {$y - $ytop}]
4451 }
4452 } elseif {[info exists pending_select]} {
4453 set selid $pending_select
4454 unset pending_select
4455 }
4456 unselectline
4457 normalline
4458 unset -nocomplain treediffs
4459 clear_display
4460 if {[info exists hlview] && $hlview == $n} {
4461 unset hlview
4462 set selectedhlview [mc "None"]
4463 }
4464 unset -nocomplain commitinterest
4465 unset -nocomplain cached_commitrow
4466 unset -nocomplain ordertok
4467
4468 set curview $n
4469 set selectedview $n
4470 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4471 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4472
4473 run refill_reflist
4474 if {![info exists viewcomplete($n)]} {
4475 getcommits $selid
4476 return
4477 }
4478
4479 set displayorder {}
4480 set parentlist {}
4481 set rowidlist {}
4482 set rowisopt {}
4483 set rowfinal {}
4484 set numcommits $commitidx($n)
4485
4486 unset -nocomplain colormap
4487 unset -nocomplain rowtextx
4488 set nextcolor 0
4489 set canvxmax [$canv cget -width]
4490 set curview $n
4491 set row 0
4492 setcanvscroll
4493 set yf 0
4494 set row {}
4495 if {$selid ne {} && [commitinview $selid $n]} {
4496 set row [rowofcommit $selid]
4497 # try to get the selected row in the same position on the screen
4498 set ymax [lindex [$canv cget -scrollregion] 3]
4499 set ytop [expr {[yc $row] - $yscreen}]
4500 if {$ytop < 0} {
4501 set ytop 0
4502 }
4503 set yf [expr {$ytop * 1.0 / $ymax}]
4504 }
4505 allcanvs yview moveto $yf
4506 drawvisible
4507 if {$row ne {}} {
4508 selectline $row 0
4509 } elseif {!$viewcomplete($n)} {
4510 reset_pending_select $selid
4511 } else {
4512 reset_pending_select {}
4513
4514 if {[commitinview $pending_select $curview]} {
4515 selectline [rowofcommit $pending_select] 1
4516 } else {
4517 set row [first_real_row]
4518 if {$row < $numcommits} {
4519 selectline $row 0
4520 }
4521 }
4522 }
4523 if {!$viewcomplete($n)} {
4524 if {$numcommits == 0} {
4525 show_status [mc "Reading commits..."]
4526 }
4527 } elseif {$numcommits == 0} {
4528 show_status [mc "No commits selected"]
4529 }
4530 set_window_title
4531}
4532
4533# Stuff relating to the highlighting facility
4534
4535proc ishighlighted {id} {
4536 global vhighlights fhighlights nhighlights rhighlights
4537
4538 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4539 return $nhighlights($id)
4540 }
4541 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4542 return $vhighlights($id)
4543 }
4544 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4545 return $fhighlights($id)
4546 }
4547 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4548 return $rhighlights($id)
4549 }
4550 return 0
4551}
4552
4553proc bolden {id font} {
4554 global canv linehtag currentid boldids need_redisplay markedid
4555
4556 # need_redisplay = 1 means the display is stale and about to be redrawn
4557 if {$need_redisplay} return
4558 lappend boldids $id
4559 $canv itemconf $linehtag($id) -font $font
4560 if {[info exists currentid] && $id eq $currentid} {
4561 $canv delete secsel
4562 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4563 -outline {{}} -tags secsel \
4564 -fill [$canv cget -selectbackground]]
4565 $canv lower $t
4566 }
4567 if {[info exists markedid] && $id eq $markedid} {
4568 make_idmark $id
4569 }
4570}
4571
4572proc bolden_name {id font} {
4573 global canv2 linentag currentid boldnameids need_redisplay
4574
4575 if {$need_redisplay} return
4576 lappend boldnameids $id
4577 $canv2 itemconf $linentag($id) -font $font
4578 if {[info exists currentid] && $id eq $currentid} {
4579 $canv2 delete secsel
4580 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4581 -outline {{}} -tags secsel \
4582 -fill [$canv2 cget -selectbackground]]
4583 $canv2 lower $t
4584 }
4585}
4586
4587proc unbolden {} {
4588 global boldids
4589
4590 set stillbold {}
4591 foreach id $boldids {
4592 if {![ishighlighted $id]} {
4593 bolden $id mainfont
4594 } else {
4595 lappend stillbold $id
4596 }
4597 }
4598 set boldids $stillbold
4599}
4600
4601proc addvhighlight {n} {
4602 global hlview viewcomplete curview vhl_done commitidx
4603
4604 if {[info exists hlview]} {
4605 delvhighlight
4606 }
4607 set hlview $n
4608 if {$n != $curview && ![info exists viewcomplete($n)]} {
4609 start_rev_list $n
4610 }
4611 set vhl_done $commitidx($hlview)
4612 if {$vhl_done > 0} {
4613 drawvisible
4614 }
4615}
4616
4617proc delvhighlight {} {
4618 global hlview vhighlights
4619
4620 if {![info exists hlview]} return
4621 unset hlview
4622 unset -nocomplain vhighlights
4623 unbolden
4624}
4625
4626proc vhighlightmore {} {
4627 global hlview vhl_done commitidx vhighlights curview
4628
4629 set max $commitidx($hlview)
4630 set vr [visiblerows]
4631 set r0 [lindex $vr 0]
4632 set r1 [lindex $vr 1]
4633 for {set i $vhl_done} {$i < $max} {incr i} {
4634 set id [commitonrow $i $hlview]
4635 if {[commitinview $id $curview]} {
4636 set row [rowofcommit $id]
4637 if {$r0 <= $row && $row <= $r1} {
4638 if {![highlighted $row]} {
4639 bolden $id mainfontbold
4640 }
4641 set vhighlights($id) 1
4642 }
4643 }
4644 }
4645 set vhl_done $max
4646 return 0
4647}
4648
4649proc askvhighlight {row id} {
4650 global hlview vhighlights iddrawn
4651
4652 if {[commitinview $id $hlview]} {
4653 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4654 bolden $id mainfontbold
4655 }
4656 set vhighlights($id) 1
4657 } else {
4658 set vhighlights($id) 0
4659 }
4660}
4661
4662proc hfiles_change {} {
4663 global highlight_files filehighlight fhighlights fh_serial
4664 global highlight_paths
4665
4666 if {[info exists filehighlight]} {
4667 # delete previous highlights
4668 catch {close $filehighlight}
4669 unset filehighlight
4670 unset -nocomplain fhighlights
4671 unbolden
4672 unhighlight_filelist
4673 }
4674 set highlight_paths {}
4675 after cancel do_file_hl $fh_serial
4676 incr fh_serial
4677 if {$highlight_files ne {}} {
4678 after 300 do_file_hl $fh_serial
4679 }
4680}
4681
4682proc gdttype_change {name ix op} {
4683 global gdttype highlight_files findstring findpattern
4684
4685 stopfinding
4686 if {$findstring ne {}} {
4687 if {$gdttype eq [mc "containing:"]} {
4688 if {$highlight_files ne {}} {
4689 set highlight_files {}
4690 hfiles_change
4691 }
4692 findcom_change
4693 } else {
4694 if {$findpattern ne {}} {
4695 set findpattern {}
4696 findcom_change
4697 }
4698 set highlight_files $findstring
4699 hfiles_change
4700 }
4701 drawvisible
4702 }
4703 # enable/disable findtype/findloc menus too
4704}
4705
4706proc find_change {name ix op} {
4707 global gdttype findstring highlight_files
4708
4709 stopfinding
4710 if {$gdttype eq [mc "containing:"]} {
4711 findcom_change
4712 } else {
4713 if {$highlight_files ne $findstring} {
4714 set highlight_files $findstring
4715 hfiles_change
4716 }
4717 }
4718 drawvisible
4719}
4720
4721proc findcom_change args {
4722 global nhighlights boldnameids
4723 global findpattern findtype findstring gdttype
4724
4725 stopfinding
4726 # delete previous highlights, if any
4727 foreach id $boldnameids {
4728 bolden_name $id mainfont
4729 }
4730 set boldnameids {}
4731 unset -nocomplain nhighlights
4732 unbolden
4733 unmarkmatches
4734 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4735 set findpattern {}
4736 } elseif {$findtype eq [mc "Regexp"]} {
4737 set findpattern $findstring
4738 } else {
4739 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4740 $findstring]
4741 set findpattern "*$e*"
4742 }
4743}
4744
4745proc makepatterns {l} {
4746 set ret {}
4747 foreach e $l {
4748 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4749 if {[string index $ee end] eq "/"} {
4750 lappend ret "$ee*"
4751 } else {
4752 lappend ret $ee
4753 lappend ret "$ee/*"
4754 }
4755 }
4756 return $ret
4757}
4758
4759proc do_file_hl {serial} {
4760 global highlight_files filehighlight highlight_paths gdttype fhl_list
4761 global cdup findtype
4762
4763 if {$gdttype eq [mc "touching paths:"]} {
4764 # If "exact" match then convert backslashes to forward slashes.
4765 # Most useful to support Windows-flavoured file paths.
4766 if {$findtype eq [mc "Exact"]} {
4767 set highlight_files [string map {"\\" "/"} $highlight_files]
4768 }
4769 if {[catch {set paths [shellsplit $highlight_files]}]} return
4770 set highlight_paths [makepatterns $paths]
4771 highlight_filelist
4772 set relative_paths {}
4773 foreach path $paths {
4774 lappend relative_paths [file join $cdup $path]
4775 }
4776 set gdtargs [concat -- $relative_paths]
4777 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4778 set gdtargs [list "-S$highlight_files"]
4779 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4780 set gdtargs [list "-G$highlight_files"]
4781 } else {
4782 # must be "containing:", i.e. we're searching commit info
4783 return
4784 }
4785 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4786 set filehighlight [open $cmd r+]
4787 fconfigure $filehighlight -blocking 0
4788 filerun $filehighlight readfhighlight
4789 set fhl_list {}
4790 drawvisible
4791 flushhighlights
4792}
4793
4794proc flushhighlights {} {
4795 global filehighlight fhl_list
4796
4797 if {[info exists filehighlight]} {
4798 lappend fhl_list {}
4799 puts $filehighlight ""
4800 flush $filehighlight
4801 }
4802}
4803
4804proc askfilehighlight {row id} {
4805 global filehighlight fhighlights fhl_list
4806
4807 lappend fhl_list $id
4808 set fhighlights($id) -1
4809 puts $filehighlight $id
4810}
4811
4812proc readfhighlight {} {
4813 global filehighlight fhighlights curview iddrawn
4814 global fhl_list find_dirn
4815
4816 if {![info exists filehighlight]} {
4817 return 0
4818 }
4819 set nr 0
4820 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4821 set line [string trim $line]
4822 set i [lsearch -exact $fhl_list $line]
4823 if {$i < 0} continue
4824 for {set j 0} {$j < $i} {incr j} {
4825 set id [lindex $fhl_list $j]
4826 set fhighlights($id) 0
4827 }
4828 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4829 if {$line eq {}} continue
4830 if {![commitinview $line $curview]} continue
4831 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4832 bolden $line mainfontbold
4833 }
4834 set fhighlights($line) 1
4835 }
4836 if {[eof $filehighlight]} {
4837 # strange...
4838 puts "oops, git diff-tree died"
4839 catch {close $filehighlight}
4840 unset filehighlight
4841 return 0
4842 }
4843 if {[info exists find_dirn]} {
4844 run findmore
4845 }
4846 return 1
4847}
4848
4849proc doesmatch {f} {
4850 global findtype findpattern
4851
4852 if {$findtype eq [mc "Regexp"]} {
4853 return [regexp $findpattern $f]
4854 } elseif {$findtype eq [mc "IgnCase"]} {
4855 return [string match -nocase $findpattern $f]
4856 } else {
4857 return [string match $findpattern $f]
4858 }
4859}
4860
4861proc askfindhighlight {row id} {
4862 global nhighlights commitinfo iddrawn
4863 global findloc
4864 global markingmatches
4865
4866 if {![info exists commitinfo($id)]} {
4867 getcommit $id
4868 }
4869 set info $commitinfo($id)
4870 set isbold 0
4871 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4872 foreach f $info ty $fldtypes {
4873 if {$ty eq ""} continue
4874 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4875 [doesmatch $f]} {
4876 if {$ty eq [mc "Author"]} {
4877 set isbold 2
4878 break
4879 }
4880 set isbold 1
4881 }
4882 }
4883 if {$isbold && [info exists iddrawn($id)]} {
4884 if {![ishighlighted $id]} {
4885 bolden $id mainfontbold
4886 if {$isbold > 1} {
4887 bolden_name $id mainfontbold
4888 }
4889 }
4890 if {$markingmatches} {
4891 markrowmatches $row $id
4892 }
4893 }
4894 set nhighlights($id) $isbold
4895}
4896
4897proc markrowmatches {row id} {
4898 global canv canv2 linehtag linentag commitinfo findloc
4899
4900 set headline [lindex $commitinfo($id) 0]
4901 set author [lindex $commitinfo($id) 1]
4902 $canv delete match$row
4903 $canv2 delete match$row
4904 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4905 set m [findmatches $headline]
4906 if {$m ne {}} {
4907 markmatches $canv $row $headline $linehtag($id) $m \
4908 [$canv itemcget $linehtag($id) -font] $row
4909 }
4910 }
4911 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4912 set m [findmatches $author]
4913 if {$m ne {}} {
4914 markmatches $canv2 $row $author $linentag($id) $m \
4915 [$canv2 itemcget $linentag($id) -font] $row
4916 }
4917 }
4918}
4919
4920proc vrel_change {name ix op} {
4921 global highlight_related
4922
4923 rhighlight_none
4924 if {$highlight_related ne [mc "None"]} {
4925 run drawvisible
4926 }
4927}
4928
4929# prepare for testing whether commits are descendents or ancestors of a
4930proc rhighlight_sel {a} {
4931 global descendent desc_todo ancestor anc_todo
4932 global highlight_related
4933
4934 unset -nocomplain descendent
4935 set desc_todo [list $a]
4936 unset -nocomplain ancestor
4937 set anc_todo [list $a]
4938 if {$highlight_related ne [mc "None"]} {
4939 rhighlight_none
4940 run drawvisible
4941 }
4942}
4943
4944proc rhighlight_none {} {
4945 global rhighlights
4946
4947 unset -nocomplain rhighlights
4948 unbolden
4949}
4950
4951proc is_descendent {a} {
4952 global curview children descendent desc_todo
4953
4954 set v $curview
4955 set la [rowofcommit $a]
4956 set todo $desc_todo
4957 set leftover {}
4958 set done 0
4959 for {set i 0} {$i < [llength $todo]} {incr i} {
4960 set do [lindex $todo $i]
4961 if {[rowofcommit $do] < $la} {
4962 lappend leftover $do
4963 continue
4964 }
4965 foreach nk $children($v,$do) {
4966 if {![info exists descendent($nk)]} {
4967 set descendent($nk) 1
4968 lappend todo $nk
4969 if {$nk eq $a} {
4970 set done 1
4971 }
4972 }
4973 }
4974 if {$done} {
4975 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4976 return
4977 }
4978 }
4979 set descendent($a) 0
4980 set desc_todo $leftover
4981}
4982
4983proc is_ancestor {a} {
4984 global curview parents ancestor anc_todo
4985
4986 set v $curview
4987 set la [rowofcommit $a]
4988 set todo $anc_todo
4989 set leftover {}
4990 set done 0
4991 for {set i 0} {$i < [llength $todo]} {incr i} {
4992 set do [lindex $todo $i]
4993 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4994 lappend leftover $do
4995 continue
4996 }
4997 foreach np $parents($v,$do) {
4998 if {![info exists ancestor($np)]} {
4999 set ancestor($np) 1
5000 lappend todo $np
5001 if {$np eq $a} {
5002 set done 1
5003 }
5004 }
5005 }
5006 if {$done} {
5007 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5008 return
5009 }
5010 }
5011 set ancestor($a) 0
5012 set anc_todo $leftover
5013}
5014
5015proc askrelhighlight {row id} {
5016 global descendent highlight_related iddrawn rhighlights
5017 global selectedline ancestor
5018
5019 if {$selectedline eq {}} return
5020 set isbold 0
5021 if {$highlight_related eq [mc "Descendant"] ||
5022 $highlight_related eq [mc "Not descendant"]} {
5023 if {![info exists descendent($id)]} {
5024 is_descendent $id
5025 }
5026 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5027 set isbold 1
5028 }
5029 } elseif {$highlight_related eq [mc "Ancestor"] ||
5030 $highlight_related eq [mc "Not ancestor"]} {
5031 if {![info exists ancestor($id)]} {
5032 is_ancestor $id
5033 }
5034 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5035 set isbold 1
5036 }
5037 }
5038 if {[info exists iddrawn($id)]} {
5039 if {$isbold && ![ishighlighted $id]} {
5040 bolden $id mainfontbold
5041 }
5042 }
5043 set rhighlights($id) $isbold
5044}
5045
5046# Graph layout functions
5047
5048proc shortids {ids} {
5049 set res {}
5050 foreach id $ids {
5051 if {[llength $id] > 1} {
5052 lappend res [shortids $id]
5053 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5054 lappend res [string range $id 0 7]
5055 } else {
5056 lappend res $id
5057 }
5058 }
5059 return $res
5060}
5061
5062proc ntimes {n o} {
5063 set ret {}
5064 set o [list $o]
5065 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5066 if {($n & $mask) != 0} {
5067 set ret [concat $ret $o]
5068 }
5069 set o [concat $o $o]
5070 }
5071 return $ret
5072}
5073
5074proc ordertoken {id} {
5075 global ordertok curview varcid varcstart varctok curview parents children
5076 global nullid nullid2
5077
5078 if {[info exists ordertok($id)]} {
5079 return $ordertok($id)
5080 }
5081 set origid $id
5082 set todo {}
5083 while {1} {
5084 if {[info exists varcid($curview,$id)]} {
5085 set a $varcid($curview,$id)
5086 set p [lindex $varcstart($curview) $a]
5087 } else {
5088 set p [lindex $children($curview,$id) 0]
5089 }
5090 if {[info exists ordertok($p)]} {
5091 set tok $ordertok($p)
5092 break
5093 }
5094 set id [first_real_child $curview,$p]
5095 if {$id eq {}} {
5096 # it's a root
5097 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5098 break
5099 }
5100 if {[llength $parents($curview,$id)] == 1} {
5101 lappend todo [list $p {}]
5102 } else {
5103 set j [lsearch -exact $parents($curview,$id) $p]
5104 if {$j < 0} {
5105 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5106 }
5107 lappend todo [list $p [strrep $j]]
5108 }
5109 }
5110 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5111 set p [lindex $todo $i 0]
5112 append tok [lindex $todo $i 1]
5113 set ordertok($p) $tok
5114 }
5115 set ordertok($origid) $tok
5116 return $tok
5117}
5118
5119# Work out where id should go in idlist so that order-token
5120# values increase from left to right
5121proc idcol {idlist id {i 0}} {
5122 set t [ordertoken $id]
5123 if {$i < 0} {
5124 set i 0
5125 }
5126 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5127 if {$i > [llength $idlist]} {
5128 set i [llength $idlist]
5129 }
5130 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5131 incr i
5132 } else {
5133 if {$t > [ordertoken [lindex $idlist $i]]} {
5134 while {[incr i] < [llength $idlist] &&
5135 $t >= [ordertoken [lindex $idlist $i]]} {}
5136 }
5137 }
5138 return $i
5139}
5140
5141proc initlayout {} {
5142 global rowidlist rowisopt rowfinal displayorder parentlist
5143 global numcommits canvxmax canv
5144 global nextcolor
5145 global colormap rowtextx
5146
5147 set numcommits 0
5148 set displayorder {}
5149 set parentlist {}
5150 set nextcolor 0
5151 set rowidlist {}
5152 set rowisopt {}
5153 set rowfinal {}
5154 set canvxmax [$canv cget -width]
5155 unset -nocomplain colormap
5156 unset -nocomplain rowtextx
5157 setcanvscroll
5158}
5159
5160proc setcanvscroll {} {
5161 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5162 global lastscrollset lastscrollrows
5163
5164 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5165 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5166 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5167 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5168 set lastscrollset [clock clicks -milliseconds]
5169 set lastscrollrows $numcommits
5170}
5171
5172proc visiblerows {} {
5173 global canv numcommits linespc
5174
5175 set ymax [lindex [$canv cget -scrollregion] 3]
5176 if {$ymax eq {} || $ymax == 0} return
5177 set f [$canv yview]
5178 set y0 [expr {int([lindex $f 0] * $ymax)}]
5179 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5180 if {$r0 < 0} {
5181 set r0 0
5182 }
5183 set y1 [expr {int([lindex $f 1] * $ymax)}]
5184 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5185 if {$r1 >= $numcommits} {
5186 set r1 [expr {$numcommits - 1}]
5187 }
5188 return [list $r0 $r1]
5189}
5190
5191proc layoutmore {} {
5192 global commitidx viewcomplete curview
5193 global numcommits pending_select curview
5194 global lastscrollset lastscrollrows
5195
5196 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5197 [clock clicks -milliseconds] - $lastscrollset > 500} {
5198 setcanvscroll
5199 }
5200 if {[info exists pending_select] &&
5201 [commitinview $pending_select $curview]} {
5202 update
5203 selectline [rowofcommit $pending_select] 1
5204 }
5205 drawvisible
5206}
5207
5208# With path limiting, we mightn't get the actual HEAD commit,
5209# so ask git rev-list what is the first ancestor of HEAD that
5210# touches a file in the path limit.
5211proc get_viewmainhead {view} {
5212 global viewmainheadid vfilelimit viewinstances mainheadid
5213
5214 catch {
5215 set rfd [open [concat | git rev-list -1 $mainheadid \
5216 -- $vfilelimit($view)] r]
5217 set j [reg_instance $rfd]
5218 lappend viewinstances($view) $j
5219 fconfigure $rfd -blocking 0
5220 filerun $rfd [list getviewhead $rfd $j $view]
5221 set viewmainheadid($curview) {}
5222 }
5223}
5224
5225# git rev-list should give us just 1 line to use as viewmainheadid($view)
5226proc getviewhead {fd inst view} {
5227 global viewmainheadid commfd curview viewinstances showlocalchanges
5228
5229 set id {}
5230 if {[gets $fd line] < 0} {
5231 if {![eof $fd]} {
5232 return 1
5233 }
5234 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5235 set id $line
5236 }
5237 set viewmainheadid($view) $id
5238 close $fd
5239 unset commfd($inst)
5240 set i [lsearch -exact $viewinstances($view) $inst]
5241 if {$i >= 0} {
5242 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5243 }
5244 if {$showlocalchanges && $id ne {} && $view == $curview} {
5245 doshowlocalchanges
5246 }
5247 return 0
5248}
5249
5250proc doshowlocalchanges {} {
5251 global curview viewmainheadid
5252
5253 if {$viewmainheadid($curview) eq {}} return
5254 if {[commitinview $viewmainheadid($curview) $curview]} {
5255 dodiffindex
5256 } else {
5257 interestedin $viewmainheadid($curview) dodiffindex
5258 }
5259}
5260
5261proc dohidelocalchanges {} {
5262 global nullid nullid2 lserial curview
5263
5264 if {[commitinview $nullid $curview]} {
5265 removefakerow $nullid
5266 }
5267 if {[commitinview $nullid2 $curview]} {
5268 removefakerow $nullid2
5269 }
5270 incr lserial
5271}
5272
5273# spawn off a process to do git diff-index --cached HEAD
5274proc dodiffindex {} {
5275 global lserial showlocalchanges vfilelimit curview
5276 global hasworktree git_version
5277
5278 if {!$showlocalchanges || !$hasworktree} return
5279 incr lserial
5280 if {[package vcompare $git_version "1.7.2"] >= 0} {
5281 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5282 } else {
5283 set cmd "|git diff-index --cached HEAD"
5284 }
5285 if {$vfilelimit($curview) ne {}} {
5286 set cmd [concat $cmd -- $vfilelimit($curview)]
5287 }
5288 set fd [open $cmd r]
5289 fconfigure $fd -blocking 0
5290 set i [reg_instance $fd]
5291 filerun $fd [list readdiffindex $fd $lserial $i]
5292}
5293
5294proc readdiffindex {fd serial inst} {
5295 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5296 global vfilelimit
5297
5298 set isdiff 1
5299 if {[gets $fd line] < 0} {
5300 if {![eof $fd]} {
5301 return 1
5302 }
5303 set isdiff 0
5304 }
5305 # we only need to see one line and we don't really care what it says...
5306 stop_instance $inst
5307
5308 if {$serial != $lserial} {
5309 return 0
5310 }
5311
5312 # now see if there are any local changes not checked in to the index
5313 set cmd "|git diff-files"
5314 if {$vfilelimit($curview) ne {}} {
5315 set cmd [concat $cmd -- $vfilelimit($curview)]
5316 }
5317 set fd [open $cmd r]
5318 fconfigure $fd -blocking 0
5319 set i [reg_instance $fd]
5320 filerun $fd [list readdifffiles $fd $serial $i]
5321
5322 if {$isdiff && ![commitinview $nullid2 $curview]} {
5323 # add the line for the changes in the index to the graph
5324 set hl [mc "Local changes checked in to index but not committed"]
5325 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5326 set commitdata($nullid2) "\n $hl\n"
5327 if {[commitinview $nullid $curview]} {
5328 removefakerow $nullid
5329 }
5330 insertfakerow $nullid2 $viewmainheadid($curview)
5331 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5332 if {[commitinview $nullid $curview]} {
5333 removefakerow $nullid
5334 }
5335 removefakerow $nullid2
5336 }
5337 return 0
5338}
5339
5340proc readdifffiles {fd serial inst} {
5341 global viewmainheadid nullid nullid2 curview
5342 global commitinfo commitdata lserial
5343
5344 set isdiff 1
5345 if {[gets $fd line] < 0} {
5346 if {![eof $fd]} {
5347 return 1
5348 }
5349 set isdiff 0
5350 }
5351 # we only need to see one line and we don't really care what it says...
5352 stop_instance $inst
5353
5354 if {$serial != $lserial} {
5355 return 0
5356 }
5357
5358 if {$isdiff && ![commitinview $nullid $curview]} {
5359 # add the line for the local diff to the graph
5360 set hl [mc "Local uncommitted changes, not checked in to index"]
5361 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5362 set commitdata($nullid) "\n $hl\n"
5363 if {[commitinview $nullid2 $curview]} {
5364 set p $nullid2
5365 } else {
5366 set p $viewmainheadid($curview)
5367 }
5368 insertfakerow $nullid $p
5369 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5370 removefakerow $nullid
5371 }
5372 return 0
5373}
5374
5375proc nextuse {id row} {
5376 global curview children
5377
5378 if {[info exists children($curview,$id)]} {
5379 foreach kid $children($curview,$id) {
5380 if {![commitinview $kid $curview]} {
5381 return -1
5382 }
5383 if {[rowofcommit $kid] > $row} {
5384 return [rowofcommit $kid]
5385 }
5386 }
5387 }
5388 if {[commitinview $id $curview]} {
5389 return [rowofcommit $id]
5390 }
5391 return -1
5392}
5393
5394proc prevuse {id row} {
5395 global curview children
5396
5397 set ret -1
5398 if {[info exists children($curview,$id)]} {
5399 foreach kid $children($curview,$id) {
5400 if {![commitinview $kid $curview]} break
5401 if {[rowofcommit $kid] < $row} {
5402 set ret [rowofcommit $kid]
5403 }
5404 }
5405 }
5406 return $ret
5407}
5408
5409proc make_idlist {row} {
5410 global displayorder parentlist uparrowlen downarrowlen mingaplen
5411 global commitidx curview children
5412
5413 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5414 if {$r < 0} {
5415 set r 0
5416 }
5417 set ra [expr {$row - $downarrowlen}]
5418 if {$ra < 0} {
5419 set ra 0
5420 }
5421 set rb [expr {$row + $uparrowlen}]
5422 if {$rb > $commitidx($curview)} {
5423 set rb $commitidx($curview)
5424 }
5425 make_disporder $r [expr {$rb + 1}]
5426 set ids {}
5427 for {} {$r < $ra} {incr r} {
5428 set nextid [lindex $displayorder [expr {$r + 1}]]
5429 foreach p [lindex $parentlist $r] {
5430 if {$p eq $nextid} continue
5431 set rn [nextuse $p $r]
5432 if {$rn >= $row &&
5433 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5434 lappend ids [list [ordertoken $p] $p]
5435 }
5436 }
5437 }
5438 for {} {$r < $row} {incr r} {
5439 set nextid [lindex $displayorder [expr {$r + 1}]]
5440 foreach p [lindex $parentlist $r] {
5441 if {$p eq $nextid} continue
5442 set rn [nextuse $p $r]
5443 if {$rn < 0 || $rn >= $row} {
5444 lappend ids [list [ordertoken $p] $p]
5445 }
5446 }
5447 }
5448 set id [lindex $displayorder $row]
5449 lappend ids [list [ordertoken $id] $id]
5450 while {$r < $rb} {
5451 foreach p [lindex $parentlist $r] {
5452 set firstkid [lindex $children($curview,$p) 0]
5453 if {[rowofcommit $firstkid] < $row} {
5454 lappend ids [list [ordertoken $p] $p]
5455 }
5456 }
5457 incr r
5458 set id [lindex $displayorder $r]
5459 if {$id ne {}} {
5460 set firstkid [lindex $children($curview,$id) 0]
5461 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5462 lappend ids [list [ordertoken $id] $id]
5463 }
5464 }
5465 }
5466 set idlist {}
5467 foreach idx [lsort -unique $ids] {
5468 lappend idlist [lindex $idx 1]
5469 }
5470 return $idlist
5471}
5472
5473proc rowsequal {a b} {
5474 while {[set i [lsearch -exact $a {}]] >= 0} {
5475 set a [lreplace $a $i $i]
5476 }
5477 while {[set i [lsearch -exact $b {}]] >= 0} {
5478 set b [lreplace $b $i $i]
5479 }
5480 return [expr {$a eq $b}]
5481}
5482
5483proc makeupline {id row rend col} {
5484 global rowidlist uparrowlen downarrowlen mingaplen
5485
5486 for {set r $rend} {1} {set r $rstart} {
5487 set rstart [prevuse $id $r]
5488 if {$rstart < 0} return
5489 if {$rstart < $row} break
5490 }
5491 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5492 set rstart [expr {$rend - $uparrowlen - 1}]
5493 }
5494 for {set r $rstart} {[incr r] <= $row} {} {
5495 set idlist [lindex $rowidlist $r]
5496 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5497 set col [idcol $idlist $id $col]
5498 lset rowidlist $r [linsert $idlist $col $id]
5499 changedrow $r
5500 }
5501 }
5502}
5503
5504proc layoutrows {row endrow} {
5505 global rowidlist rowisopt rowfinal displayorder
5506 global uparrowlen downarrowlen maxwidth mingaplen
5507 global children parentlist
5508 global commitidx viewcomplete curview
5509
5510 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5511 set idlist {}
5512 if {$row > 0} {
5513 set rm1 [expr {$row - 1}]
5514 foreach id [lindex $rowidlist $rm1] {
5515 if {$id ne {}} {
5516 lappend idlist $id
5517 }
5518 }
5519 set final [lindex $rowfinal $rm1]
5520 }
5521 for {} {$row < $endrow} {incr row} {
5522 set rm1 [expr {$row - 1}]
5523 if {$rm1 < 0 || $idlist eq {}} {
5524 set idlist [make_idlist $row]
5525 set final 1
5526 } else {
5527 set id [lindex $displayorder $rm1]
5528 set col [lsearch -exact $idlist $id]
5529 set idlist [lreplace $idlist $col $col]
5530 foreach p [lindex $parentlist $rm1] {
5531 if {[lsearch -exact $idlist $p] < 0} {
5532 set col [idcol $idlist $p $col]
5533 set idlist [linsert $idlist $col $p]
5534 # if not the first child, we have to insert a line going up
5535 if {$id ne [lindex $children($curview,$p) 0]} {
5536 makeupline $p $rm1 $row $col
5537 }
5538 }
5539 }
5540 set id [lindex $displayorder $row]
5541 if {$row > $downarrowlen} {
5542 set termrow [expr {$row - $downarrowlen - 1}]
5543 foreach p [lindex $parentlist $termrow] {
5544 set i [lsearch -exact $idlist $p]
5545 if {$i < 0} continue
5546 set nr [nextuse $p $termrow]
5547 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5548 set idlist [lreplace $idlist $i $i]
5549 }
5550 }
5551 }
5552 set col [lsearch -exact $idlist $id]
5553 if {$col < 0} {
5554 set col [idcol $idlist $id]
5555 set idlist [linsert $idlist $col $id]
5556 if {$children($curview,$id) ne {}} {
5557 makeupline $id $rm1 $row $col
5558 }
5559 }
5560 set r [expr {$row + $uparrowlen - 1}]
5561 if {$r < $commitidx($curview)} {
5562 set x $col
5563 foreach p [lindex $parentlist $r] {
5564 if {[lsearch -exact $idlist $p] >= 0} continue
5565 set fk [lindex $children($curview,$p) 0]
5566 if {[rowofcommit $fk] < $row} {
5567 set x [idcol $idlist $p $x]
5568 set idlist [linsert $idlist $x $p]
5569 }
5570 }
5571 if {[incr r] < $commitidx($curview)} {
5572 set p [lindex $displayorder $r]
5573 if {[lsearch -exact $idlist $p] < 0} {
5574 set fk [lindex $children($curview,$p) 0]
5575 if {$fk ne {} && [rowofcommit $fk] < $row} {
5576 set x [idcol $idlist $p $x]
5577 set idlist [linsert $idlist $x $p]
5578 }
5579 }
5580 }
5581 }
5582 }
5583 if {$final && !$viewcomplete($curview) &&
5584 $row + $uparrowlen + $mingaplen + $downarrowlen
5585 >= $commitidx($curview)} {
5586 set final 0
5587 }
5588 set l [llength $rowidlist]
5589 if {$row == $l} {
5590 lappend rowidlist $idlist
5591 lappend rowisopt 0
5592 lappend rowfinal $final
5593 } elseif {$row < $l} {
5594 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5595 lset rowidlist $row $idlist
5596 changedrow $row
5597 }
5598 lset rowfinal $row $final
5599 } else {
5600 set pad [ntimes [expr {$row - $l}] {}]
5601 set rowidlist [concat $rowidlist $pad]
5602 lappend rowidlist $idlist
5603 set rowfinal [concat $rowfinal $pad]
5604 lappend rowfinal $final
5605 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5606 }
5607 }
5608 return $row
5609}
5610
5611proc changedrow {row} {
5612 global displayorder iddrawn rowisopt need_redisplay
5613
5614 set l [llength $rowisopt]
5615 if {$row < $l} {
5616 lset rowisopt $row 0
5617 if {$row + 1 < $l} {
5618 lset rowisopt [expr {$row + 1}] 0
5619 if {$row + 2 < $l} {
5620 lset rowisopt [expr {$row + 2}] 0
5621 }
5622 }
5623 }
5624 set id [lindex $displayorder $row]
5625 if {[info exists iddrawn($id)]} {
5626 set need_redisplay 1
5627 }
5628}
5629
5630proc insert_pad {row col npad} {
5631 global rowidlist
5632
5633 set pad [ntimes $npad {}]
5634 set idlist [lindex $rowidlist $row]
5635 set bef [lrange $idlist 0 [expr {$col - 1}]]
5636 set aft [lrange $idlist $col end]
5637 set i [lsearch -exact $aft {}]
5638 if {$i > 0} {
5639 set aft [lreplace $aft $i $i]
5640 }
5641 lset rowidlist $row [concat $bef $pad $aft]
5642 changedrow $row
5643}
5644
5645proc optimize_rows {row col endrow} {
5646 global rowidlist rowisopt displayorder curview children
5647
5648 if {$row < 1} {
5649 set row 1
5650 }
5651 for {} {$row < $endrow} {incr row; set col 0} {
5652 if {[lindex $rowisopt $row]} continue
5653 set haspad 0
5654 set y0 [expr {$row - 1}]
5655 set ym [expr {$row - 2}]
5656 set idlist [lindex $rowidlist $row]
5657 set previdlist [lindex $rowidlist $y0]
5658 if {$idlist eq {} || $previdlist eq {}} continue
5659 if {$ym >= 0} {
5660 set pprevidlist [lindex $rowidlist $ym]
5661 if {$pprevidlist eq {}} continue
5662 } else {
5663 set pprevidlist {}
5664 }
5665 set x0 -1
5666 set xm -1
5667 for {} {$col < [llength $idlist]} {incr col} {
5668 set id [lindex $idlist $col]
5669 if {[lindex $previdlist $col] eq $id} continue
5670 if {$id eq {}} {
5671 set haspad 1
5672 continue
5673 }
5674 set x0 [lsearch -exact $previdlist $id]
5675 if {$x0 < 0} continue
5676 set z [expr {$x0 - $col}]
5677 set isarrow 0
5678 set z0 {}
5679 if {$ym >= 0} {
5680 set xm [lsearch -exact $pprevidlist $id]
5681 if {$xm >= 0} {
5682 set z0 [expr {$xm - $x0}]
5683 }
5684 }
5685 if {$z0 eq {}} {
5686 # if row y0 is the first child of $id then it's not an arrow
5687 if {[lindex $children($curview,$id) 0] ne
5688 [lindex $displayorder $y0]} {
5689 set isarrow 1
5690 }
5691 }
5692 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5693 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5694 set isarrow 1
5695 }
5696 # Looking at lines from this row to the previous row,
5697 # make them go straight up if they end in an arrow on
5698 # the previous row; otherwise make them go straight up
5699 # or at 45 degrees.
5700 if {$z < -1 || ($z < 0 && $isarrow)} {
5701 # Line currently goes left too much;
5702 # insert pads in the previous row, then optimize it
5703 set npad [expr {-1 - $z + $isarrow}]
5704 insert_pad $y0 $x0 $npad
5705 if {$y0 > 0} {
5706 optimize_rows $y0 $x0 $row
5707 }
5708 set previdlist [lindex $rowidlist $y0]
5709 set x0 [lsearch -exact $previdlist $id]
5710 set z [expr {$x0 - $col}]
5711 if {$z0 ne {}} {
5712 set pprevidlist [lindex $rowidlist $ym]
5713 set xm [lsearch -exact $pprevidlist $id]
5714 set z0 [expr {$xm - $x0}]
5715 }
5716 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5717 # Line currently goes right too much;
5718 # insert pads in this line
5719 set npad [expr {$z - 1 + $isarrow}]
5720 insert_pad $row $col $npad
5721 set idlist [lindex $rowidlist $row]
5722 incr col $npad
5723 set z [expr {$x0 - $col}]
5724 set haspad 1
5725 }
5726 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5727 # this line links to its first child on row $row-2
5728 set id [lindex $displayorder $ym]
5729 set xc [lsearch -exact $pprevidlist $id]
5730 if {$xc >= 0} {
5731 set z0 [expr {$xc - $x0}]
5732 }
5733 }
5734 # avoid lines jigging left then immediately right
5735 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5736 insert_pad $y0 $x0 1
5737 incr x0
5738 optimize_rows $y0 $x0 $row
5739 set previdlist [lindex $rowidlist $y0]
5740 }
5741 }
5742 if {!$haspad} {
5743 # Find the first column that doesn't have a line going right
5744 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5745 set id [lindex $idlist $col]
5746 if {$id eq {}} break
5747 set x0 [lsearch -exact $previdlist $id]
5748 if {$x0 < 0} {
5749 # check if this is the link to the first child
5750 set kid [lindex $displayorder $y0]
5751 if {[lindex $children($curview,$id) 0] eq $kid} {
5752 # it is, work out offset to child
5753 set x0 [lsearch -exact $previdlist $kid]
5754 }
5755 }
5756 if {$x0 <= $col} break
5757 }
5758 # Insert a pad at that column as long as it has a line and
5759 # isn't the last column
5760 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5761 set idlist [linsert $idlist $col {}]
5762 lset rowidlist $row $idlist
5763 changedrow $row
5764 }
5765 }
5766 }
5767}
5768
5769proc xc {row col} {
5770 global canvx0 linespc
5771 return [expr {$canvx0 + $col * $linespc}]
5772}
5773
5774proc yc {row} {
5775 global canvy0 linespc
5776 return [expr {$canvy0 + $row * $linespc}]
5777}
5778
5779proc linewidth {id} {
5780 global thickerline lthickness
5781
5782 set wid $lthickness
5783 if {[info exists thickerline] && $id eq $thickerline} {
5784 set wid [expr {2 * $lthickness}]
5785 }
5786 return $wid
5787}
5788
5789proc rowranges {id} {
5790 global curview children uparrowlen downarrowlen
5791 global rowidlist
5792
5793 set kids $children($curview,$id)
5794 if {$kids eq {}} {
5795 return {}
5796 }
5797 set ret {}
5798 lappend kids $id
5799 foreach child $kids {
5800 if {![commitinview $child $curview]} break
5801 set row [rowofcommit $child]
5802 if {![info exists prev]} {
5803 lappend ret [expr {$row + 1}]
5804 } else {
5805 if {$row <= $prevrow} {
5806 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5807 }
5808 # see if the line extends the whole way from prevrow to row
5809 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5810 [lsearch -exact [lindex $rowidlist \
5811 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5812 # it doesn't, see where it ends
5813 set r [expr {$prevrow + $downarrowlen}]
5814 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5815 while {[incr r -1] > $prevrow &&
5816 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5817 } else {
5818 while {[incr r] <= $row &&
5819 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5820 incr r -1
5821 }
5822 lappend ret $r
5823 # see where it starts up again
5824 set r [expr {$row - $uparrowlen}]
5825 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5826 while {[incr r] < $row &&
5827 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5828 } else {
5829 while {[incr r -1] >= $prevrow &&
5830 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5831 incr r
5832 }
5833 lappend ret $r
5834 }
5835 }
5836 if {$child eq $id} {
5837 lappend ret $row
5838 }
5839 set prev $child
5840 set prevrow $row
5841 }
5842 return $ret
5843}
5844
5845proc drawlineseg {id row endrow arrowlow} {
5846 global rowidlist displayorder iddrawn linesegs
5847 global canv colormap linespc curview maxlinelen parentlist
5848
5849 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5850 set le [expr {$row + 1}]
5851 set arrowhigh 1
5852 while {1} {
5853 set c [lsearch -exact [lindex $rowidlist $le] $id]
5854 if {$c < 0} {
5855 incr le -1
5856 break
5857 }
5858 lappend cols $c
5859 set x [lindex $displayorder $le]
5860 if {$x eq $id} {
5861 set arrowhigh 0
5862 break
5863 }
5864 if {[info exists iddrawn($x)] || $le == $endrow} {
5865 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5866 if {$c >= 0} {
5867 lappend cols $c
5868 set arrowhigh 0
5869 }
5870 break
5871 }
5872 incr le
5873 }
5874 if {$le <= $row} {
5875 return $row
5876 }
5877
5878 set lines {}
5879 set i 0
5880 set joinhigh 0
5881 if {[info exists linesegs($id)]} {
5882 set lines $linesegs($id)
5883 foreach li $lines {
5884 set r0 [lindex $li 0]
5885 if {$r0 > $row} {
5886 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5887 set joinhigh 1
5888 }
5889 break
5890 }
5891 incr i
5892 }
5893 }
5894 set joinlow 0
5895 if {$i > 0} {
5896 set li [lindex $lines [expr {$i-1}]]
5897 set r1 [lindex $li 1]
5898 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5899 set joinlow 1
5900 }
5901 }
5902
5903 set x [lindex $cols [expr {$le - $row}]]
5904 set xp [lindex $cols [expr {$le - 1 - $row}]]
5905 set dir [expr {$xp - $x}]
5906 if {$joinhigh} {
5907 set ith [lindex $lines $i 2]
5908 set coords [$canv coords $ith]
5909 set ah [$canv itemcget $ith -arrow]
5910 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5911 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5912 if {$x2 ne {} && $x - $x2 == $dir} {
5913 set coords [lrange $coords 0 end-2]
5914 }
5915 } else {
5916 set coords [list [xc $le $x] [yc $le]]
5917 }
5918 if {$joinlow} {
5919 set itl [lindex $lines [expr {$i-1}] 2]
5920 set al [$canv itemcget $itl -arrow]
5921 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5922 } elseif {$arrowlow} {
5923 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5924 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5925 set arrowlow 0
5926 }
5927 }
5928 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5929 for {set y $le} {[incr y -1] > $row} {} {
5930 set x $xp
5931 set xp [lindex $cols [expr {$y - 1 - $row}]]
5932 set ndir [expr {$xp - $x}]
5933 if {$dir != $ndir || $xp < 0} {
5934 lappend coords [xc $y $x] [yc $y]
5935 }
5936 set dir $ndir
5937 }
5938 if {!$joinlow} {
5939 if {$xp < 0} {
5940 # join parent line to first child
5941 set ch [lindex $displayorder $row]
5942 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5943 if {$xc < 0} {
5944 puts "oops: drawlineseg: child $ch not on row $row"
5945 } elseif {$xc != $x} {
5946 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5947 set d [expr {int(0.5 * $linespc)}]
5948 set x1 [xc $row $x]
5949 if {$xc < $x} {
5950 set x2 [expr {$x1 - $d}]
5951 } else {
5952 set x2 [expr {$x1 + $d}]
5953 }
5954 set y2 [yc $row]
5955 set y1 [expr {$y2 + $d}]
5956 lappend coords $x1 $y1 $x2 $y2
5957 } elseif {$xc < $x - 1} {
5958 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5959 } elseif {$xc > $x + 1} {
5960 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5961 }
5962 set x $xc
5963 }
5964 lappend coords [xc $row $x] [yc $row]
5965 } else {
5966 set xn [xc $row $xp]
5967 set yn [yc $row]
5968 lappend coords $xn $yn
5969 }
5970 if {!$joinhigh} {
5971 assigncolor $id
5972 set t [$canv create line $coords -width [linewidth $id] \
5973 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5974 $canv lower $t
5975 bindline $t $id
5976 set lines [linsert $lines $i [list $row $le $t]]
5977 } else {
5978 $canv coords $ith $coords
5979 if {$arrow ne $ah} {
5980 $canv itemconf $ith -arrow $arrow
5981 }
5982 lset lines $i 0 $row
5983 }
5984 } else {
5985 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5986 set ndir [expr {$xo - $xp}]
5987 set clow [$canv coords $itl]
5988 if {$dir == $ndir} {
5989 set clow [lrange $clow 2 end]
5990 }
5991 set coords [concat $coords $clow]
5992 if {!$joinhigh} {
5993 lset lines [expr {$i-1}] 1 $le
5994 } else {
5995 # coalesce two pieces
5996 $canv delete $ith
5997 set b [lindex $lines [expr {$i-1}] 0]
5998 set e [lindex $lines $i 1]
5999 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6000 }
6001 $canv coords $itl $coords
6002 if {$arrow ne $al} {
6003 $canv itemconf $itl -arrow $arrow
6004 }
6005 }
6006
6007 set linesegs($id) $lines
6008 return $le
6009}
6010
6011proc drawparentlinks {id row} {
6012 global rowidlist canv colormap curview parentlist
6013 global idpos linespc
6014
6015 set rowids [lindex $rowidlist $row]
6016 set col [lsearch -exact $rowids $id]
6017 if {$col < 0} return
6018 set olds [lindex $parentlist $row]
6019 set row2 [expr {$row + 1}]
6020 set x [xc $row $col]
6021 set y [yc $row]
6022 set y2 [yc $row2]
6023 set d [expr {int(0.5 * $linespc)}]
6024 set ymid [expr {$y + $d}]
6025 set ids [lindex $rowidlist $row2]
6026 # rmx = right-most X coord used
6027 set rmx 0
6028 foreach p $olds {
6029 set i [lsearch -exact $ids $p]
6030 if {$i < 0} {
6031 puts "oops, parent $p of $id not in list"
6032 continue
6033 }
6034 set x2 [xc $row2 $i]
6035 if {$x2 > $rmx} {
6036 set rmx $x2
6037 }
6038 set j [lsearch -exact $rowids $p]
6039 if {$j < 0} {
6040 # drawlineseg will do this one for us
6041 continue
6042 }
6043 assigncolor $p
6044 # should handle duplicated parents here...
6045 set coords [list $x $y]
6046 if {$i != $col} {
6047 # if attaching to a vertical segment, draw a smaller
6048 # slant for visual distinctness
6049 if {$i == $j} {
6050 if {$i < $col} {
6051 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6052 } else {
6053 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6054 }
6055 } elseif {$i < $col && $i < $j} {
6056 # segment slants towards us already
6057 lappend coords [xc $row $j] $y
6058 } else {
6059 if {$i < $col - 1} {
6060 lappend coords [expr {$x2 + $linespc}] $y
6061 } elseif {$i > $col + 1} {
6062 lappend coords [expr {$x2 - $linespc}] $y
6063 }
6064 lappend coords $x2 $y2
6065 }
6066 } else {
6067 lappend coords $x2 $y2
6068 }
6069 set t [$canv create line $coords -width [linewidth $p] \
6070 -fill $colormap($p) -tags lines.$p]
6071 $canv lower $t
6072 bindline $t $p
6073 }
6074 if {$rmx > [lindex $idpos($id) 1]} {
6075 lset idpos($id) 1 $rmx
6076 redrawtags $id
6077 }
6078}
6079
6080proc drawlines {id} {
6081 global canv
6082
6083 $canv itemconf lines.$id -width [linewidth $id]
6084}
6085
6086proc drawcmittext {id row col} {
6087 global linespc canv canv2 canv3 fgcolor curview
6088 global cmitlisted commitinfo rowidlist parentlist
6089 global rowtextx idpos idtags idheads idotherrefs
6090 global linehtag linentag linedtag selectedline
6091 global canvxmax boldids boldnameids fgcolor markedid
6092 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6093 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6094 global circleoutlinecolor
6095
6096 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6097 set listed $cmitlisted($curview,$id)
6098 if {$id eq $nullid} {
6099 set ofill $workingfilescirclecolor
6100 } elseif {$id eq $nullid2} {
6101 set ofill $indexcirclecolor
6102 } elseif {$id eq $mainheadid} {
6103 set ofill $mainheadcirclecolor
6104 } else {
6105 set ofill [lindex $circlecolors $listed]
6106 }
6107 set x [xc $row $col]
6108 set y [yc $row]
6109 set orad [expr {$linespc / 3}]
6110 if {$listed <= 2} {
6111 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6112 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6113 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6114 } elseif {$listed == 3} {
6115 # triangle pointing left for left-side commits
6116 set t [$canv create polygon \
6117 [expr {$x - $orad}] $y \
6118 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6119 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6120 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6121 } else {
6122 # triangle pointing right for right-side commits
6123 set t [$canv create polygon \
6124 [expr {$x + $orad - 1}] $y \
6125 [expr {$x - $orad}] [expr {$y - $orad}] \
6126 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6127 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6128 }
6129 set circleitem($row) $t
6130 $canv raise $t
6131 $canv bind $t <1> {selcanvline {} %x %y}
6132 set rmx [llength [lindex $rowidlist $row]]
6133 set olds [lindex $parentlist $row]
6134 if {$olds ne {}} {
6135 set nextids [lindex $rowidlist [expr {$row + 1}]]
6136 foreach p $olds {
6137 set i [lsearch -exact $nextids $p]
6138 if {$i > $rmx} {
6139 set rmx $i
6140 }
6141 }
6142 }
6143 set xt [xc $row $rmx]
6144 set rowtextx($row) $xt
6145 set idpos($id) [list $x $xt $y]
6146 if {[info exists idtags($id)] || [info exists idheads($id)]
6147 || [info exists idotherrefs($id)]} {
6148 set xt [drawtags $id $x $xt $y]
6149 }
6150 if {[lindex $commitinfo($id) 6] > 0} {
6151 set xt [drawnotesign $xt $y]
6152 }
6153 set headline [lindex $commitinfo($id) 0]
6154 set name [lindex $commitinfo($id) 1]
6155 set date [lindex $commitinfo($id) 2]
6156 set date [formatdate $date]
6157 set font mainfont
6158 set nfont mainfont
6159 set isbold [ishighlighted $id]
6160 if {$isbold > 0} {
6161 lappend boldids $id
6162 set font mainfontbold
6163 if {$isbold > 1} {
6164 lappend boldnameids $id
6165 set nfont mainfontbold
6166 }
6167 }
6168 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6169 -text $headline -font $font -tags text]
6170 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6171 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6172 -text $name -font $nfont -tags text]
6173 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6174 -text $date -font mainfont -tags text]
6175 if {$selectedline == $row} {
6176 make_secsel $id
6177 }
6178 if {[info exists markedid] && $markedid eq $id} {
6179 make_idmark $id
6180 }
6181 set xr [expr {$xt + [font measure $font $headline]}]
6182 if {$xr > $canvxmax} {
6183 set canvxmax $xr
6184 setcanvscroll
6185 }
6186}
6187
6188proc drawcmitrow {row} {
6189 global displayorder rowidlist nrows_drawn
6190 global iddrawn markingmatches
6191 global commitinfo numcommits
6192 global filehighlight fhighlights findpattern nhighlights
6193 global hlview vhighlights
6194 global highlight_related rhighlights
6195
6196 if {$row >= $numcommits} return
6197
6198 set id [lindex $displayorder $row]
6199 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6200 askvhighlight $row $id
6201 }
6202 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6203 askfilehighlight $row $id
6204 }
6205 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6206 askfindhighlight $row $id
6207 }
6208 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6209 askrelhighlight $row $id
6210 }
6211 if {![info exists iddrawn($id)]} {
6212 set col [lsearch -exact [lindex $rowidlist $row] $id]
6213 if {$col < 0} {
6214 puts "oops, row $row id $id not in list"
6215 return
6216 }
6217 if {![info exists commitinfo($id)]} {
6218 getcommit $id
6219 }
6220 assigncolor $id
6221 drawcmittext $id $row $col
6222 set iddrawn($id) 1
6223 incr nrows_drawn
6224 }
6225 if {$markingmatches} {
6226 markrowmatches $row $id
6227 }
6228}
6229
6230proc drawcommits {row {endrow {}}} {
6231 global numcommits iddrawn displayorder curview need_redisplay
6232 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6233
6234 if {$row < 0} {
6235 set row 0
6236 }
6237 if {$endrow eq {}} {
6238 set endrow $row
6239 }
6240 if {$endrow >= $numcommits} {
6241 set endrow [expr {$numcommits - 1}]
6242 }
6243
6244 set rl1 [expr {$row - $downarrowlen - 3}]
6245 if {$rl1 < 0} {
6246 set rl1 0
6247 }
6248 set ro1 [expr {$row - 3}]
6249 if {$ro1 < 0} {
6250 set ro1 0
6251 }
6252 set r2 [expr {$endrow + $uparrowlen + 3}]
6253 if {$r2 > $numcommits} {
6254 set r2 $numcommits
6255 }
6256 for {set r $rl1} {$r < $r2} {incr r} {
6257 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6258 if {$rl1 < $r} {
6259 layoutrows $rl1 $r
6260 }
6261 set rl1 [expr {$r + 1}]
6262 }
6263 }
6264 if {$rl1 < $r} {
6265 layoutrows $rl1 $r
6266 }
6267 optimize_rows $ro1 0 $r2
6268 if {$need_redisplay || $nrows_drawn > 2000} {
6269 clear_display
6270 }
6271
6272 # make the lines join to already-drawn rows either side
6273 set r [expr {$row - 1}]
6274 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6275 set r $row
6276 }
6277 set er [expr {$endrow + 1}]
6278 if {$er >= $numcommits ||
6279 ![info exists iddrawn([lindex $displayorder $er])]} {
6280 set er $endrow
6281 }
6282 for {} {$r <= $er} {incr r} {
6283 set id [lindex $displayorder $r]
6284 set wasdrawn [info exists iddrawn($id)]
6285 drawcmitrow $r
6286 if {$r == $er} break
6287 set nextid [lindex $displayorder [expr {$r + 1}]]
6288 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6289 drawparentlinks $id $r
6290
6291 set rowids [lindex $rowidlist $r]
6292 foreach lid $rowids {
6293 if {$lid eq {}} continue
6294 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6295 if {$lid eq $id} {
6296 # see if this is the first child of any of its parents
6297 foreach p [lindex $parentlist $r] {
6298 if {[lsearch -exact $rowids $p] < 0} {
6299 # make this line extend up to the child
6300 set lineend($p) [drawlineseg $p $r $er 0]
6301 }
6302 }
6303 } else {
6304 set lineend($lid) [drawlineseg $lid $r $er 1]
6305 }
6306 }
6307 }
6308}
6309
6310proc undolayout {row} {
6311 global uparrowlen mingaplen downarrowlen
6312 global rowidlist rowisopt rowfinal need_redisplay
6313
6314 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6315 if {$r < 0} {
6316 set r 0
6317 }
6318 if {[llength $rowidlist] > $r} {
6319 incr r -1
6320 set rowidlist [lrange $rowidlist 0 $r]
6321 set rowfinal [lrange $rowfinal 0 $r]
6322 set rowisopt [lrange $rowisopt 0 $r]
6323 set need_redisplay 1
6324 run drawvisible
6325 }
6326}
6327
6328proc drawvisible {} {
6329 global canv linespc curview vrowmod selectedline targetrow targetid
6330 global need_redisplay cscroll numcommits
6331
6332 set fs [$canv yview]
6333 set ymax [lindex [$canv cget -scrollregion] 3]
6334 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6335 set f0 [lindex $fs 0]
6336 set f1 [lindex $fs 1]
6337 set y0 [expr {int($f0 * $ymax)}]
6338 set y1 [expr {int($f1 * $ymax)}]
6339
6340 if {[info exists targetid]} {
6341 if {[commitinview $targetid $curview]} {
6342 set r [rowofcommit $targetid]
6343 if {$r != $targetrow} {
6344 # Fix up the scrollregion and change the scrolling position
6345 # now that our target row has moved.
6346 set diff [expr {($r - $targetrow) * $linespc}]
6347 set targetrow $r
6348 setcanvscroll
6349 set ymax [lindex [$canv cget -scrollregion] 3]
6350 incr y0 $diff
6351 incr y1 $diff
6352 set f0 [expr {$y0 / $ymax}]
6353 set f1 [expr {$y1 / $ymax}]
6354 allcanvs yview moveto $f0
6355 $cscroll set $f0 $f1
6356 set need_redisplay 1
6357 }
6358 } else {
6359 unset targetid
6360 }
6361 }
6362
6363 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6364 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6365 if {$endrow >= $vrowmod($curview)} {
6366 update_arcrows $curview
6367 }
6368 if {$selectedline ne {} &&
6369 $row <= $selectedline && $selectedline <= $endrow} {
6370 set targetrow $selectedline
6371 } elseif {[info exists targetid]} {
6372 set targetrow [expr {int(($row + $endrow) / 2)}]
6373 }
6374 if {[info exists targetrow]} {
6375 if {$targetrow >= $numcommits} {
6376 set targetrow [expr {$numcommits - 1}]
6377 }
6378 set targetid [commitonrow $targetrow]
6379 }
6380 drawcommits $row $endrow
6381}
6382
6383proc clear_display {} {
6384 global iddrawn linesegs need_redisplay nrows_drawn
6385 global vhighlights fhighlights nhighlights rhighlights
6386 global linehtag linentag linedtag boldids boldnameids
6387
6388 allcanvs delete all
6389 unset -nocomplain iddrawn
6390 unset -nocomplain linesegs
6391 unset -nocomplain linehtag
6392 unset -nocomplain linentag
6393 unset -nocomplain linedtag
6394 set boldids {}
6395 set boldnameids {}
6396 unset -nocomplain vhighlights
6397 unset -nocomplain fhighlights
6398 unset -nocomplain nhighlights
6399 unset -nocomplain rhighlights
6400 set need_redisplay 0
6401 set nrows_drawn 0
6402}
6403
6404proc findcrossings {id} {
6405 global rowidlist parentlist numcommits displayorder
6406
6407 set cross {}
6408 set ccross {}
6409 foreach {s e} [rowranges $id] {
6410 if {$e >= $numcommits} {
6411 set e [expr {$numcommits - 1}]
6412 }
6413 if {$e <= $s} continue
6414 for {set row $e} {[incr row -1] >= $s} {} {
6415 set x [lsearch -exact [lindex $rowidlist $row] $id]
6416 if {$x < 0} break
6417 set olds [lindex $parentlist $row]
6418 set kid [lindex $displayorder $row]
6419 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6420 if {$kidx < 0} continue
6421 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6422 foreach p $olds {
6423 set px [lsearch -exact $nextrow $p]
6424 if {$px < 0} continue
6425 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6426 if {[lsearch -exact $ccross $p] >= 0} continue
6427 if {$x == $px + ($kidx < $px? -1: 1)} {
6428 lappend ccross $p
6429 } elseif {[lsearch -exact $cross $p] < 0} {
6430 lappend cross $p
6431 }
6432 }
6433 }
6434 }
6435 }
6436 return [concat $ccross {{}} $cross]
6437}
6438
6439proc assigncolor {id} {
6440 global colormap colors nextcolor
6441 global parents children children curview
6442
6443 if {[info exists colormap($id)]} return
6444 set ncolors [llength $colors]
6445 if {[info exists children($curview,$id)]} {
6446 set kids $children($curview,$id)
6447 } else {
6448 set kids {}
6449 }
6450 if {[llength $kids] == 1} {
6451 set child [lindex $kids 0]
6452 if {[info exists colormap($child)]
6453 && [llength $parents($curview,$child)] == 1} {
6454 set colormap($id) $colormap($child)
6455 return
6456 }
6457 }
6458 set badcolors {}
6459 set origbad {}
6460 foreach x [findcrossings $id] {
6461 if {$x eq {}} {
6462 # delimiter between corner crossings and other crossings
6463 if {[llength $badcolors] >= $ncolors - 1} break
6464 set origbad $badcolors
6465 }
6466 if {[info exists colormap($x)]
6467 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6468 lappend badcolors $colormap($x)
6469 }
6470 }
6471 if {[llength $badcolors] >= $ncolors} {
6472 set badcolors $origbad
6473 }
6474 set origbad $badcolors
6475 if {[llength $badcolors] < $ncolors - 1} {
6476 foreach child $kids {
6477 if {[info exists colormap($child)]
6478 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6479 lappend badcolors $colormap($child)
6480 }
6481 foreach p $parents($curview,$child) {
6482 if {[info exists colormap($p)]
6483 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6484 lappend badcolors $colormap($p)
6485 }
6486 }
6487 }
6488 if {[llength $badcolors] >= $ncolors} {
6489 set badcolors $origbad
6490 }
6491 }
6492 for {set i 0} {$i <= $ncolors} {incr i} {
6493 set c [lindex $colors $nextcolor]
6494 if {[incr nextcolor] >= $ncolors} {
6495 set nextcolor 0
6496 }
6497 if {[lsearch -exact $badcolors $c]} break
6498 }
6499 set colormap($id) $c
6500}
6501
6502proc bindline {t id} {
6503 global canv
6504
6505 $canv bind $t <Enter> "lineenter %x %y $id"
6506 $canv bind $t <Motion> "linemotion %x %y $id"
6507 $canv bind $t <Leave> "lineleave $id"
6508 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6509}
6510
6511proc graph_pane_width {} {
6512 global use_ttk
6513
6514 if {$use_ttk} {
6515 set g [.tf.histframe.pwclist sashpos 0]
6516 } else {
6517 set g [.tf.histframe.pwclist sash coord 0]
6518 }
6519 return [lindex $g 0]
6520}
6521
6522proc totalwidth {l font extra} {
6523 set tot 0
6524 foreach str $l {
6525 set tot [expr {$tot + [font measure $font $str] + $extra}]
6526 }
6527 return $tot
6528}
6529
6530proc drawtags {id x xt y1} {
6531 global idtags idheads idotherrefs mainhead
6532 global linespc lthickness
6533 global canv rowtextx curview fgcolor bgcolor ctxbut
6534 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6535 global tagbgcolor tagfgcolor tagoutlinecolor
6536 global reflinecolor
6537
6538 set marks {}
6539 set ntags 0
6540 set nheads 0
6541 set singletag 0
6542 set maxtags 3
6543 set maxtagpct 25
6544 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6545 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6546 set extra [expr {$delta + $lthickness + $linespc}]
6547
6548 if {[info exists idtags($id)]} {
6549 set marks $idtags($id)
6550 set ntags [llength $marks]
6551 if {$ntags > $maxtags ||
6552 [totalwidth $marks mainfont $extra] > $maxwidth} {
6553 # show just a single "n tags..." tag
6554 set singletag 1
6555 if {$ntags == 1} {
6556 set marks [list "tag..."]
6557 } else {
6558 set marks [list [format "%d tags..." $ntags]]
6559 }
6560 set ntags 1
6561 }
6562 }
6563 if {[info exists idheads($id)]} {
6564 set marks [concat $marks $idheads($id)]
6565 set nheads [llength $idheads($id)]
6566 }
6567 if {[info exists idotherrefs($id)]} {
6568 set marks [concat $marks $idotherrefs($id)]
6569 }
6570 if {$marks eq {}} {
6571 return $xt
6572 }
6573
6574 set yt [expr {$y1 - 0.5 * $linespc}]
6575 set yb [expr {$yt + $linespc - 1}]
6576 set xvals {}
6577 set wvals {}
6578 set i -1
6579 foreach tag $marks {
6580 incr i
6581 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6582 set wid [font measure mainfontbold $tag]
6583 } else {
6584 set wid [font measure mainfont $tag]
6585 }
6586 lappend xvals $xt
6587 lappend wvals $wid
6588 set xt [expr {$xt + $wid + $extra}]
6589 }
6590 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6591 -width $lthickness -fill $reflinecolor -tags tag.$id]
6592 $canv lower $t
6593 foreach tag $marks x $xvals wid $wvals {
6594 set tag_quoted [string map {% %%} $tag]
6595 set xl [expr {$x + $delta}]
6596 set xr [expr {$x + $delta + $wid + $lthickness}]
6597 set font mainfont
6598 if {[incr ntags -1] >= 0} {
6599 # draw a tag
6600 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6601 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6602 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6603 -tags tag.$id]
6604 if {$singletag} {
6605 set tagclick [list showtags $id 1]
6606 } else {
6607 set tagclick [list showtag $tag_quoted 1]
6608 }
6609 $canv bind $t <1> $tagclick
6610 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6611 } else {
6612 # draw a head or other ref
6613 if {[incr nheads -1] >= 0} {
6614 set col $headbgcolor
6615 if {$tag eq $mainhead} {
6616 set font mainfontbold
6617 }
6618 } else {
6619 set col "#ddddff"
6620 }
6621 set xl [expr {$xl - $delta/2}]
6622 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6623 -width 1 -outline black -fill $col -tags tag.$id
6624 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6625 set rwid [font measure mainfont $remoteprefix]
6626 set xi [expr {$x + 1}]
6627 set yti [expr {$yt + 1}]
6628 set xri [expr {$x + $rwid}]
6629 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6630 -width 0 -fill $remotebgcolor -tags tag.$id
6631 }
6632 }
6633 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6634 -font $font -tags [list tag.$id text]]
6635 if {$ntags >= 0} {
6636 $canv bind $t <1> $tagclick
6637 } elseif {$nheads >= 0} {
6638 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6639 }
6640 }
6641 return $xt
6642}
6643
6644proc drawnotesign {xt y} {
6645 global linespc canv fgcolor
6646
6647 set orad [expr {$linespc / 3}]
6648 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6649 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6650 -fill yellow -outline $fgcolor -width 1 -tags circle]
6651 set xt [expr {$xt + $orad * 3}]
6652 return $xt
6653}
6654
6655proc xcoord {i level ln} {
6656 global canvx0 xspc1 xspc2
6657
6658 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6659 if {$i > 0 && $i == $level} {
6660 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6661 } elseif {$i > $level} {
6662 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6663 }
6664 return $x
6665}
6666
6667proc show_status {msg} {
6668 global canv fgcolor
6669
6670 clear_display
6671 set_window_title
6672 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6673 -tags text -fill $fgcolor
6674}
6675
6676# Don't change the text pane cursor if it is currently the hand cursor,
6677# showing that we are over a sha1 ID link.
6678proc settextcursor {c} {
6679 global ctext curtextcursor
6680
6681 if {[$ctext cget -cursor] == $curtextcursor} {
6682 $ctext config -cursor $c
6683 }
6684 set curtextcursor $c
6685}
6686
6687proc nowbusy {what {name {}}} {
6688 global isbusy busyname statusw
6689
6690 if {[array names isbusy] eq {}} {
6691 . config -cursor watch
6692 settextcursor watch
6693 }
6694 set isbusy($what) 1
6695 set busyname($what) $name
6696 if {$name ne {}} {
6697 $statusw conf -text $name
6698 }
6699}
6700
6701proc notbusy {what} {
6702 global isbusy maincursor textcursor busyname statusw
6703
6704 catch {
6705 unset isbusy($what)
6706 if {$busyname($what) ne {} &&
6707 [$statusw cget -text] eq $busyname($what)} {
6708 $statusw conf -text {}
6709 }
6710 }
6711 if {[array names isbusy] eq {}} {
6712 . config -cursor $maincursor
6713 settextcursor $textcursor
6714 }
6715}
6716
6717proc findmatches {f} {
6718 global findtype findstring
6719 if {$findtype == [mc "Regexp"]} {
6720 set matches [regexp -indices -all -inline $findstring $f]
6721 } else {
6722 set fs $findstring
6723 if {$findtype == [mc "IgnCase"]} {
6724 set f [string tolower $f]
6725 set fs [string tolower $fs]
6726 }
6727 set matches {}
6728 set i 0
6729 set l [string length $fs]
6730 while {[set j [string first $fs $f $i]] >= 0} {
6731 lappend matches [list $j [expr {$j+$l-1}]]
6732 set i [expr {$j + $l}]
6733 }
6734 }
6735 return $matches
6736}
6737
6738proc dofind {{dirn 1} {wrap 1}} {
6739 global findstring findstartline findcurline selectedline numcommits
6740 global gdttype filehighlight fh_serial find_dirn findallowwrap
6741
6742 if {[info exists find_dirn]} {
6743 if {$find_dirn == $dirn} return
6744 stopfinding
6745 }
6746 focus .
6747 if {$findstring eq {} || $numcommits == 0} return
6748 if {$selectedline eq {}} {
6749 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6750 } else {
6751 set findstartline $selectedline
6752 }
6753 set findcurline $findstartline
6754 nowbusy finding [mc "Searching"]
6755 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6756 after cancel do_file_hl $fh_serial
6757 do_file_hl $fh_serial
6758 }
6759 set find_dirn $dirn
6760 set findallowwrap $wrap
6761 run findmore
6762}
6763
6764proc stopfinding {} {
6765 global find_dirn findcurline fprogcoord
6766
6767 if {[info exists find_dirn]} {
6768 unset find_dirn
6769 unset findcurline
6770 notbusy finding
6771 set fprogcoord 0
6772 adjustprogress
6773 }
6774 stopblaming
6775}
6776
6777proc findmore {} {
6778 global commitdata commitinfo numcommits findpattern findloc
6779 global findstartline findcurline findallowwrap
6780 global find_dirn gdttype fhighlights fprogcoord
6781 global curview varcorder vrownum varccommits vrowmod
6782
6783 if {![info exists find_dirn]} {
6784 return 0
6785 }
6786 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6787 set l $findcurline
6788 set moretodo 0
6789 if {$find_dirn > 0} {
6790 incr l
6791 if {$l >= $numcommits} {
6792 set l 0
6793 }
6794 if {$l <= $findstartline} {
6795 set lim [expr {$findstartline + 1}]
6796 } else {
6797 set lim $numcommits
6798 set moretodo $findallowwrap
6799 }
6800 } else {
6801 if {$l == 0} {
6802 set l $numcommits
6803 }
6804 incr l -1
6805 if {$l >= $findstartline} {
6806 set lim [expr {$findstartline - 1}]
6807 } else {
6808 set lim -1
6809 set moretodo $findallowwrap
6810 }
6811 }
6812 set n [expr {($lim - $l) * $find_dirn}]
6813 if {$n > 500} {
6814 set n 500
6815 set moretodo 1
6816 }
6817 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6818 update_arcrows $curview
6819 }
6820 set found 0
6821 set domore 1
6822 set ai [bsearch $vrownum($curview) $l]
6823 set a [lindex $varcorder($curview) $ai]
6824 set arow [lindex $vrownum($curview) $ai]
6825 set ids [lindex $varccommits($curview,$a)]
6826 set arowend [expr {$arow + [llength $ids]}]
6827 if {$gdttype eq [mc "containing:"]} {
6828 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6829 if {$l < $arow || $l >= $arowend} {
6830 incr ai $find_dirn
6831 set a [lindex $varcorder($curview) $ai]
6832 set arow [lindex $vrownum($curview) $ai]
6833 set ids [lindex $varccommits($curview,$a)]
6834 set arowend [expr {$arow + [llength $ids]}]
6835 }
6836 set id [lindex $ids [expr {$l - $arow}]]
6837 # shouldn't happen unless git log doesn't give all the commits...
6838 if {![info exists commitdata($id)] ||
6839 ![doesmatch $commitdata($id)]} {
6840 continue
6841 }
6842 if {![info exists commitinfo($id)]} {
6843 getcommit $id
6844 }
6845 set info $commitinfo($id)
6846 foreach f $info ty $fldtypes {
6847 if {$ty eq ""} continue
6848 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6849 [doesmatch $f]} {
6850 set found 1
6851 break
6852 }
6853 }
6854 if {$found} break
6855 }
6856 } else {
6857 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6858 if {$l < $arow || $l >= $arowend} {
6859 incr ai $find_dirn
6860 set a [lindex $varcorder($curview) $ai]
6861 set arow [lindex $vrownum($curview) $ai]
6862 set ids [lindex $varccommits($curview,$a)]
6863 set arowend [expr {$arow + [llength $ids]}]
6864 }
6865 set id [lindex $ids [expr {$l - $arow}]]
6866 if {![info exists fhighlights($id)]} {
6867 # this sets fhighlights($id) to -1
6868 askfilehighlight $l $id
6869 }
6870 if {$fhighlights($id) > 0} {
6871 set found $domore
6872 break
6873 }
6874 if {$fhighlights($id) < 0} {
6875 if {$domore} {
6876 set domore 0
6877 set findcurline [expr {$l - $find_dirn}]
6878 }
6879 }
6880 }
6881 }
6882 if {$found || ($domore && !$moretodo)} {
6883 unset findcurline
6884 unset find_dirn
6885 notbusy finding
6886 set fprogcoord 0
6887 adjustprogress
6888 if {$found} {
6889 findselectline $l
6890 } else {
6891 bell
6892 }
6893 return 0
6894 }
6895 if {!$domore} {
6896 flushhighlights
6897 } else {
6898 set findcurline [expr {$l - $find_dirn}]
6899 }
6900 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6901 if {$n < 0} {
6902 incr n $numcommits
6903 }
6904 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6905 adjustprogress
6906 return $domore
6907}
6908
6909proc findselectline {l} {
6910 global findloc commentend ctext findcurline markingmatches gdttype
6911
6912 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6913 set findcurline $l
6914 selectline $l 1
6915 if {$markingmatches &&
6916 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6917 # highlight the matches in the comments
6918 set f [$ctext get 1.0 $commentend]
6919 set matches [findmatches $f]
6920 foreach match $matches {
6921 set start [lindex $match 0]
6922 set end [expr {[lindex $match 1] + 1}]
6923 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6924 }
6925 }
6926 drawvisible
6927}
6928
6929# mark the bits of a headline or author that match a find string
6930proc markmatches {canv l str tag matches font row} {
6931 global selectedline
6932
6933 set bbox [$canv bbox $tag]
6934 set x0 [lindex $bbox 0]
6935 set y0 [lindex $bbox 1]
6936 set y1 [lindex $bbox 3]
6937 foreach match $matches {
6938 set start [lindex $match 0]
6939 set end [lindex $match 1]
6940 if {$start > $end} continue
6941 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6942 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6943 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6944 [expr {$x0+$xlen+2}] $y1 \
6945 -outline {} -tags [list match$l matches] -fill yellow]
6946 $canv lower $t
6947 if {$row == $selectedline} {
6948 $canv raise $t secsel
6949 }
6950 }
6951}
6952
6953proc unmarkmatches {} {
6954 global markingmatches
6955
6956 allcanvs delete matches
6957 set markingmatches 0
6958 stopfinding
6959}
6960
6961proc selcanvline {w x y} {
6962 global canv canvy0 ctext linespc
6963 global rowtextx
6964 set ymax [lindex [$canv cget -scrollregion] 3]
6965 if {$ymax == {}} return
6966 set yfrac [lindex [$canv yview] 0]
6967 set y [expr {$y + $yfrac * $ymax}]
6968 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6969 if {$l < 0} {
6970 set l 0
6971 }
6972 if {$w eq $canv} {
6973 set xmax [lindex [$canv cget -scrollregion] 2]
6974 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6975 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6976 }
6977 unmarkmatches
6978 selectline $l 1
6979}
6980
6981proc commit_descriptor {p} {
6982 global commitinfo
6983 if {![info exists commitinfo($p)]} {
6984 getcommit $p
6985 }
6986 set l "..."
6987 if {[llength $commitinfo($p)] > 1} {
6988 set l [lindex $commitinfo($p) 0]
6989 }
6990 return "$p ($l)\n"
6991}
6992
6993# append some text to the ctext widget, and make any SHA1 ID
6994# that we know about be a clickable link.
6995proc appendwithlinks {text tags} {
6996 global ctext linknum curview
6997
6998 set start [$ctext index "end - 1c"]
6999 $ctext insert end $text $tags
7000 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7001 foreach l $links {
7002 set s [lindex $l 0]
7003 set e [lindex $l 1]
7004 set linkid [string range $text $s $e]
7005 incr e
7006 $ctext tag delete link$linknum
7007 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7008 setlink $linkid link$linknum
7009 incr linknum
7010 }
7011}
7012
7013proc setlink {id lk} {
7014 global curview ctext pendinglinks
7015 global linkfgcolor
7016
7017 if {[string range $id 0 1] eq "-g"} {
7018 set id [string range $id 2 end]
7019 }
7020
7021 set known 0
7022 if {[string length $id] < 40} {
7023 set matches [longid $id]
7024 if {[llength $matches] > 0} {
7025 if {[llength $matches] > 1} return
7026 set known 1
7027 set id [lindex $matches 0]
7028 }
7029 } else {
7030 set known [commitinview $id $curview]
7031 }
7032 if {$known} {
7033 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7034 $ctext tag bind $lk <1> [list selbyid $id]
7035 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7036 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7037 } else {
7038 lappend pendinglinks($id) $lk
7039 interestedin $id {makelink %P}
7040 }
7041}
7042
7043proc appendshortlink {id {pre {}} {post {}}} {
7044 global ctext linknum
7045
7046 $ctext insert end $pre
7047 $ctext tag delete link$linknum
7048 $ctext insert end [string range $id 0 7] link$linknum
7049 $ctext insert end $post
7050 setlink $id link$linknum
7051 incr linknum
7052}
7053
7054proc makelink {id} {
7055 global pendinglinks
7056
7057 if {![info exists pendinglinks($id)]} return
7058 foreach lk $pendinglinks($id) {
7059 setlink $id $lk
7060 }
7061 unset pendinglinks($id)
7062}
7063
7064proc linkcursor {w inc} {
7065 global linkentercount curtextcursor
7066
7067 if {[incr linkentercount $inc] > 0} {
7068 $w configure -cursor hand2
7069 } else {
7070 $w configure -cursor $curtextcursor
7071 if {$linkentercount < 0} {
7072 set linkentercount 0
7073 }
7074 }
7075}
7076
7077proc viewnextline {dir} {
7078 global canv linespc
7079
7080 $canv delete hover
7081 set ymax [lindex [$canv cget -scrollregion] 3]
7082 set wnow [$canv yview]
7083 set wtop [expr {[lindex $wnow 0] * $ymax}]
7084 set newtop [expr {$wtop + $dir * $linespc}]
7085 if {$newtop < 0} {
7086 set newtop 0
7087 } elseif {$newtop > $ymax} {
7088 set newtop $ymax
7089 }
7090 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7091}
7092
7093# add a list of tag or branch names at position pos
7094# returns the number of names inserted
7095proc appendrefs {pos ids var} {
7096 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7097
7098 if {[catch {$ctext index $pos}]} {
7099 return 0
7100 }
7101 $ctext conf -state normal
7102 $ctext delete $pos "$pos lineend"
7103 set tags {}
7104 foreach id $ids {
7105 foreach tag [set $var\($id\)] {
7106 lappend tags [list $tag $id]
7107 }
7108 }
7109
7110 set sep {}
7111 set tags [lsort -index 0 -decreasing $tags]
7112 set nutags 0
7113
7114 if {[llength $tags] > $maxrefs} {
7115 # If we are displaying heads, and there are too many,
7116 # see if there are some important heads to display.
7117 # Currently that are the current head and heads listed in $visiblerefs option
7118 set itags {}
7119 if {$var eq "idheads"} {
7120 set utags {}
7121 foreach ti $tags {
7122 set hname [lindex $ti 0]
7123 set id [lindex $ti 1]
7124 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7125 [llength $itags] < $maxrefs} {
7126 lappend itags $ti
7127 } else {
7128 lappend utags $ti
7129 }
7130 }
7131 set tags $utags
7132 }
7133 if {$itags ne {}} {
7134 set str [mc "and many more"]
7135 set sep " "
7136 } else {
7137 set str [mc "many"]
7138 }
7139 $ctext insert $pos "$str ([llength $tags])"
7140 set nutags [llength $tags]
7141 set tags $itags
7142 }
7143
7144 foreach ti $tags {
7145 set id [lindex $ti 1]
7146 set lk link$linknum
7147 incr linknum
7148 $ctext tag delete $lk
7149 $ctext insert $pos $sep
7150 $ctext insert $pos [lindex $ti 0] $lk
7151 setlink $id $lk
7152 set sep ", "
7153 }
7154 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7155 $ctext conf -state disabled
7156 return [expr {[llength $tags] + $nutags}]
7157}
7158
7159# called when we have finished computing the nearby tags
7160proc dispneartags {delay} {
7161 global selectedline currentid showneartags tagphase
7162
7163 if {$selectedline eq {} || !$showneartags} return
7164 after cancel dispnexttag
7165 if {$delay} {
7166 after 200 dispnexttag
7167 set tagphase -1
7168 } else {
7169 after idle dispnexttag
7170 set tagphase 0
7171 }
7172}
7173
7174proc dispnexttag {} {
7175 global selectedline currentid showneartags tagphase ctext
7176
7177 if {$selectedline eq {} || !$showneartags} return
7178 switch -- $tagphase {
7179 0 {
7180 set dtags [desctags $currentid]
7181 if {$dtags ne {}} {
7182 appendrefs precedes $dtags idtags
7183 }
7184 }
7185 1 {
7186 set atags [anctags $currentid]
7187 if {$atags ne {}} {
7188 appendrefs follows $atags idtags
7189 }
7190 }
7191 2 {
7192 set dheads [descheads $currentid]
7193 if {$dheads ne {}} {
7194 if {[appendrefs branch $dheads idheads] > 1
7195 && [$ctext get "branch -3c"] eq "h"} {
7196 # turn "Branch" into "Branches"
7197 $ctext conf -state normal
7198 $ctext insert "branch -2c" "es"
7199 $ctext conf -state disabled
7200 }
7201 }
7202 }
7203 }
7204 if {[incr tagphase] <= 2} {
7205 after idle dispnexttag
7206 }
7207}
7208
7209proc make_secsel {id} {
7210 global linehtag linentag linedtag canv canv2 canv3
7211
7212 if {![info exists linehtag($id)]} return
7213 $canv delete secsel
7214 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7215 -tags secsel -fill [$canv cget -selectbackground]]
7216 $canv lower $t
7217 $canv2 delete secsel
7218 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7219 -tags secsel -fill [$canv2 cget -selectbackground]]
7220 $canv2 lower $t
7221 $canv3 delete secsel
7222 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7223 -tags secsel -fill [$canv3 cget -selectbackground]]
7224 $canv3 lower $t
7225}
7226
7227proc make_idmark {id} {
7228 global linehtag canv fgcolor
7229
7230 if {![info exists linehtag($id)]} return
7231 $canv delete markid
7232 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7233 -tags markid -outline $fgcolor]
7234 $canv raise $t
7235}
7236
7237proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7238 global canv ctext commitinfo selectedline
7239 global canvy0 linespc parents children curview
7240 global currentid sha1entry
7241 global commentend idtags linknum
7242 global mergemax numcommits pending_select
7243 global cmitmode showneartags allcommits
7244 global targetrow targetid lastscrollrows
7245 global autoselect autosellen jump_to_here
7246 global vinlinediff
7247
7248 unset -nocomplain pending_select
7249 $canv delete hover
7250 normalline
7251 unsel_reflist
7252 stopfinding
7253 if {$l < 0 || $l >= $numcommits} return
7254 set id [commitonrow $l]
7255 set targetid $id
7256 set targetrow $l
7257 set selectedline $l
7258 set currentid $id
7259 if {$lastscrollrows < $numcommits} {
7260 setcanvscroll
7261 }
7262
7263 if {$cmitmode ne "patch" && $switch_to_patch} {
7264 set cmitmode "patch"
7265 }
7266
7267 set y [expr {$canvy0 + $l * $linespc}]
7268 set ymax [lindex [$canv cget -scrollregion] 3]
7269 set ytop [expr {$y - $linespc - 1}]
7270 set ybot [expr {$y + $linespc + 1}]
7271 set wnow [$canv yview]
7272 set wtop [expr {[lindex $wnow 0] * $ymax}]
7273 set wbot [expr {[lindex $wnow 1] * $ymax}]
7274 set wh [expr {$wbot - $wtop}]
7275 set newtop $wtop
7276 if {$ytop < $wtop} {
7277 if {$ybot < $wtop} {
7278 set newtop [expr {$y - $wh / 2.0}]
7279 } else {
7280 set newtop $ytop
7281 if {$newtop > $wtop - $linespc} {
7282 set newtop [expr {$wtop - $linespc}]
7283 }
7284 }
7285 } elseif {$ybot > $wbot} {
7286 if {$ytop > $wbot} {
7287 set newtop [expr {$y - $wh / 2.0}]
7288 } else {
7289 set newtop [expr {$ybot - $wh}]
7290 if {$newtop < $wtop + $linespc} {
7291 set newtop [expr {$wtop + $linespc}]
7292 }
7293 }
7294 }
7295 if {$newtop != $wtop} {
7296 if {$newtop < 0} {
7297 set newtop 0
7298 }
7299 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7300 drawvisible
7301 }
7302
7303 make_secsel $id
7304
7305 if {$isnew} {
7306 addtohistory [list selbyid $id 0] savecmitpos
7307 }
7308
7309 $sha1entry delete 0 end
7310 $sha1entry insert 0 $id
7311 if {$autoselect} {
7312 $sha1entry selection range 0 $autosellen
7313 }
7314 rhighlight_sel $id
7315
7316 $ctext conf -state normal
7317 clear_ctext
7318 set linknum 0
7319 if {![info exists commitinfo($id)]} {
7320 getcommit $id
7321 }
7322 set info $commitinfo($id)
7323 set date [formatdate [lindex $info 2]]
7324 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7325 set date [formatdate [lindex $info 4]]
7326 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7327 if {[info exists idtags($id)]} {
7328 $ctext insert end [mc "Tags:"]
7329 foreach tag $idtags($id) {
7330 $ctext insert end " $tag"
7331 }
7332 $ctext insert end "\n"
7333 }
7334
7335 set headers {}
7336 set olds $parents($curview,$id)
7337 if {[llength $olds] > 1} {
7338 set np 0
7339 foreach p $olds {
7340 if {$np >= $mergemax} {
7341 set tag mmax
7342 } else {
7343 set tag m$np
7344 }
7345 $ctext insert end "[mc "Parent"]: " $tag
7346 appendwithlinks [commit_descriptor $p] {}
7347 incr np
7348 }
7349 } else {
7350 foreach p $olds {
7351 append headers "[mc "Parent"]: [commit_descriptor $p]"
7352 }
7353 }
7354
7355 foreach c $children($curview,$id) {
7356 append headers "[mc "Child"]: [commit_descriptor $c]"
7357 }
7358
7359 # make anything that looks like a SHA1 ID be a clickable link
7360 appendwithlinks $headers {}
7361 if {$showneartags} {
7362 if {![info exists allcommits]} {
7363 getallcommits
7364 }
7365 $ctext insert end "[mc "Branch"]: "
7366 $ctext mark set branch "end -1c"
7367 $ctext mark gravity branch left
7368 $ctext insert end "\n[mc "Follows"]: "
7369 $ctext mark set follows "end -1c"
7370 $ctext mark gravity follows left
7371 $ctext insert end "\n[mc "Precedes"]: "
7372 $ctext mark set precedes "end -1c"
7373 $ctext mark gravity precedes left
7374 $ctext insert end "\n"
7375 dispneartags 1
7376 }
7377 $ctext insert end "\n"
7378 set comment [lindex $info 5]
7379 if {[string first "\r" $comment] >= 0} {
7380 set comment [string map {"\r" "\n "} $comment]
7381 }
7382 appendwithlinks $comment {comment}
7383
7384 $ctext tag remove found 1.0 end
7385 $ctext conf -state disabled
7386 set commentend [$ctext index "end - 1c"]
7387
7388 set jump_to_here $desired_loc
7389 init_flist [mc "Comments"]
7390 if {$cmitmode eq "tree"} {
7391 gettree $id
7392 } elseif {$vinlinediff($curview) == 1} {
7393 showinlinediff $id
7394 } elseif {[llength $olds] <= 1} {
7395 startdiff $id
7396 } else {
7397 mergediff $id
7398 }
7399}
7400
7401proc selfirstline {} {
7402 unmarkmatches
7403 selectline 0 1
7404}
7405
7406proc sellastline {} {
7407 global numcommits
7408 unmarkmatches
7409 set l [expr {$numcommits - 1}]
7410 selectline $l 1
7411}
7412
7413proc selnextline {dir} {
7414 global selectedline
7415 focus .
7416 if {$selectedline eq {}} return
7417 set l [expr {$selectedline + $dir}]
7418 unmarkmatches
7419 selectline $l 1
7420}
7421
7422proc selnextpage {dir} {
7423 global canv linespc selectedline numcommits
7424
7425 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7426 if {$lpp < 1} {
7427 set lpp 1
7428 }
7429 allcanvs yview scroll [expr {$dir * $lpp}] units
7430 drawvisible
7431 if {$selectedline eq {}} return
7432 set l [expr {$selectedline + $dir * $lpp}]
7433 if {$l < 0} {
7434 set l 0
7435 } elseif {$l >= $numcommits} {
7436 set l [expr $numcommits - 1]
7437 }
7438 unmarkmatches
7439 selectline $l 1
7440}
7441
7442proc unselectline {} {
7443 global selectedline currentid
7444
7445 set selectedline {}
7446 unset -nocomplain currentid
7447 allcanvs delete secsel
7448 rhighlight_none
7449}
7450
7451proc reselectline {} {
7452 global selectedline
7453
7454 if {$selectedline ne {}} {
7455 selectline $selectedline 0
7456 }
7457}
7458
7459proc addtohistory {cmd {saveproc {}}} {
7460 global history historyindex curview
7461
7462 unset_posvars
7463 save_position
7464 set elt [list $curview $cmd $saveproc {}]
7465 if {$historyindex > 0
7466 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7467 return
7468 }
7469
7470 if {$historyindex < [llength $history]} {
7471 set history [lreplace $history $historyindex end $elt]
7472 } else {
7473 lappend history $elt
7474 }
7475 incr historyindex
7476 if {$historyindex > 1} {
7477 .tf.bar.leftbut conf -state normal
7478 } else {
7479 .tf.bar.leftbut conf -state disabled
7480 }
7481 .tf.bar.rightbut conf -state disabled
7482}
7483
7484# save the scrolling position of the diff display pane
7485proc save_position {} {
7486 global historyindex history
7487
7488 if {$historyindex < 1} return
7489 set hi [expr {$historyindex - 1}]
7490 set fn [lindex $history $hi 2]
7491 if {$fn ne {}} {
7492 lset history $hi 3 [eval $fn]
7493 }
7494}
7495
7496proc unset_posvars {} {
7497 global last_posvars
7498
7499 if {[info exists last_posvars]} {
7500 foreach {var val} $last_posvars {
7501 global $var
7502 unset -nocomplain $var
7503 }
7504 unset last_posvars
7505 }
7506}
7507
7508proc godo {elt} {
7509 global curview last_posvars
7510
7511 set view [lindex $elt 0]
7512 set cmd [lindex $elt 1]
7513 set pv [lindex $elt 3]
7514 if {$curview != $view} {
7515 showview $view
7516 }
7517 unset_posvars
7518 foreach {var val} $pv {
7519 global $var
7520 set $var $val
7521 }
7522 set last_posvars $pv
7523 eval $cmd
7524}
7525
7526proc goback {} {
7527 global history historyindex
7528 focus .
7529
7530 if {$historyindex > 1} {
7531 save_position
7532 incr historyindex -1
7533 godo [lindex $history [expr {$historyindex - 1}]]
7534 .tf.bar.rightbut conf -state normal
7535 }
7536 if {$historyindex <= 1} {
7537 .tf.bar.leftbut conf -state disabled
7538 }
7539}
7540
7541proc goforw {} {
7542 global history historyindex
7543 focus .
7544
7545 if {$historyindex < [llength $history]} {
7546 save_position
7547 set cmd [lindex $history $historyindex]
7548 incr historyindex
7549 godo $cmd
7550 .tf.bar.leftbut conf -state normal
7551 }
7552 if {$historyindex >= [llength $history]} {
7553 .tf.bar.rightbut conf -state disabled
7554 }
7555}
7556
7557proc go_to_parent {i} {
7558 global parents curview targetid
7559 set ps $parents($curview,$targetid)
7560 if {[llength $ps] >= $i} {
7561 selbyid [lindex $ps [expr $i - 1]]
7562 }
7563}
7564
7565proc gettree {id} {
7566 global treefilelist treeidlist diffids diffmergeid treepending
7567 global nullid nullid2
7568
7569 set diffids $id
7570 unset -nocomplain diffmergeid
7571 if {![info exists treefilelist($id)]} {
7572 if {![info exists treepending]} {
7573 if {$id eq $nullid} {
7574 set cmd [list | git ls-files]
7575 } elseif {$id eq $nullid2} {
7576 set cmd [list | git ls-files --stage -t]
7577 } else {
7578 set cmd [list | git ls-tree -r $id]
7579 }
7580 if {[catch {set gtf [open $cmd r]}]} {
7581 return
7582 }
7583 set treepending $id
7584 set treefilelist($id) {}
7585 set treeidlist($id) {}
7586 fconfigure $gtf -blocking 0 -encoding binary
7587 filerun $gtf [list gettreeline $gtf $id]
7588 }
7589 } else {
7590 setfilelist $id
7591 }
7592}
7593
7594proc gettreeline {gtf id} {
7595 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7596
7597 set nl 0
7598 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7599 if {$diffids eq $nullid} {
7600 set fname $line
7601 } else {
7602 set i [string first "\t" $line]
7603 if {$i < 0} continue
7604 set fname [string range $line [expr {$i+1}] end]
7605 set line [string range $line 0 [expr {$i-1}]]
7606 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7607 set sha1 [lindex $line 2]
7608 lappend treeidlist($id) $sha1
7609 }
7610 if {[string index $fname 0] eq "\""} {
7611 set fname [lindex $fname 0]
7612 }
7613 set fname [encoding convertfrom $fname]
7614 lappend treefilelist($id) $fname
7615 }
7616 if {![eof $gtf]} {
7617 return [expr {$nl >= 1000? 2: 1}]
7618 }
7619 close $gtf
7620 unset treepending
7621 if {$cmitmode ne "tree"} {
7622 if {![info exists diffmergeid]} {
7623 gettreediffs $diffids
7624 }
7625 } elseif {$id ne $diffids} {
7626 gettree $diffids
7627 } else {
7628 setfilelist $id
7629 }
7630 return 0
7631}
7632
7633proc showfile {f} {
7634 global treefilelist treeidlist diffids nullid nullid2
7635 global ctext_file_names ctext_file_lines
7636 global ctext commentend
7637
7638 set i [lsearch -exact $treefilelist($diffids) $f]
7639 if {$i < 0} {
7640 puts "oops, $f not in list for id $diffids"
7641 return
7642 }
7643 if {$diffids eq $nullid} {
7644 if {[catch {set bf [open $f r]} err]} {
7645 puts "oops, can't read $f: $err"
7646 return
7647 }
7648 } else {
7649 set blob [lindex $treeidlist($diffids) $i]
7650 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7651 puts "oops, error reading blob $blob: $err"
7652 return
7653 }
7654 }
7655 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7656 filerun $bf [list getblobline $bf $diffids]
7657 $ctext config -state normal
7658 clear_ctext $commentend
7659 lappend ctext_file_names $f
7660 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7661 $ctext insert end "\n"
7662 $ctext insert end "$f\n" filesep
7663 $ctext config -state disabled
7664 $ctext yview $commentend
7665 settabs 0
7666}
7667
7668proc getblobline {bf id} {
7669 global diffids cmitmode ctext
7670
7671 if {$id ne $diffids || $cmitmode ne "tree"} {
7672 catch {close $bf}
7673 return 0
7674 }
7675 $ctext config -state normal
7676 set nl 0
7677 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7678 $ctext insert end "$line\n"
7679 }
7680 if {[eof $bf]} {
7681 global jump_to_here ctext_file_names commentend
7682
7683 # delete last newline
7684 $ctext delete "end - 2c" "end - 1c"
7685 close $bf
7686 if {$jump_to_here ne {} &&
7687 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7688 set lnum [expr {[lindex $jump_to_here 1] +
7689 [lindex [split $commentend .] 0]}]
7690 mark_ctext_line $lnum
7691 }
7692 $ctext config -state disabled
7693 return 0
7694 }
7695 $ctext config -state disabled
7696 return [expr {$nl >= 1000? 2: 1}]
7697}
7698
7699proc mark_ctext_line {lnum} {
7700 global ctext markbgcolor
7701
7702 $ctext tag delete omark
7703 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7704 $ctext tag conf omark -background $markbgcolor
7705 $ctext see $lnum.0
7706}
7707
7708proc mergediff {id} {
7709 global diffmergeid
7710 global diffids treediffs
7711 global parents curview
7712
7713 set diffmergeid $id
7714 set diffids $id
7715 set treediffs($id) {}
7716 set np [llength $parents($curview,$id)]
7717 settabs $np
7718 getblobdiffs $id
7719}
7720
7721proc startdiff {ids} {
7722 global treediffs diffids treepending diffmergeid nullid nullid2
7723
7724 settabs 1
7725 set diffids $ids
7726 unset -nocomplain diffmergeid
7727 if {![info exists treediffs($ids)] ||
7728 [lsearch -exact $ids $nullid] >= 0 ||
7729 [lsearch -exact $ids $nullid2] >= 0} {
7730 if {![info exists treepending]} {
7731 gettreediffs $ids
7732 }
7733 } else {
7734 addtocflist $ids
7735 }
7736}
7737
7738proc showinlinediff {ids} {
7739 global commitinfo commitdata ctext
7740 global treediffs
7741
7742 set info $commitinfo($ids)
7743 set diff [lindex $info 7]
7744 set difflines [split $diff "\n"]
7745
7746 initblobdiffvars
7747 set treediff {}
7748
7749 set inhdr 0
7750 foreach line $difflines {
7751 if {![string compare -length 5 "diff " $line]} {
7752 set inhdr 1
7753 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7754 # offset also accounts for the b/ prefix
7755 lappend treediff [string range $line 6 end]
7756 set inhdr 0
7757 }
7758 }
7759
7760 set treediffs($ids) $treediff
7761 add_flist $treediff
7762
7763 $ctext conf -state normal
7764 foreach line $difflines {
7765 parseblobdiffline $ids $line
7766 }
7767 maybe_scroll_ctext 1
7768 $ctext conf -state disabled
7769}
7770
7771# If the filename (name) is under any of the passed filter paths
7772# then return true to include the file in the listing.
7773proc path_filter {filter name} {
7774 set worktree [gitworktree]
7775 foreach p $filter {
7776 set fq_p [file normalize $p]
7777 set fq_n [file normalize [file join $worktree $name]]
7778 if {[string match [file normalize $fq_p]* $fq_n]} {
7779 return 1
7780 }
7781 }
7782 return 0
7783}
7784
7785proc addtocflist {ids} {
7786 global treediffs
7787
7788 add_flist $treediffs($ids)
7789 getblobdiffs $ids
7790}
7791
7792proc diffcmd {ids flags} {
7793 global log_showroot nullid nullid2 git_version
7794
7795 set i [lsearch -exact $ids $nullid]
7796 set j [lsearch -exact $ids $nullid2]
7797 if {$i >= 0} {
7798 if {[llength $ids] > 1 && $j < 0} {
7799 # comparing working directory with some specific revision
7800 set cmd [concat | git diff-index $flags]
7801 if {$i == 0} {
7802 lappend cmd -R [lindex $ids 1]
7803 } else {
7804 lappend cmd [lindex $ids 0]
7805 }
7806 } else {
7807 # comparing working directory with index
7808 set cmd [concat | git diff-files $flags]
7809 if {$j == 1} {
7810 lappend cmd -R
7811 }
7812 }
7813 } elseif {$j >= 0} {
7814 if {[package vcompare $git_version "1.7.2"] >= 0} {
7815 set flags "$flags --ignore-submodules=dirty"
7816 }
7817 set cmd [concat | git diff-index --cached $flags]
7818 if {[llength $ids] > 1} {
7819 # comparing index with specific revision
7820 if {$j == 0} {
7821 lappend cmd -R [lindex $ids 1]
7822 } else {
7823 lappend cmd [lindex $ids 0]
7824 }
7825 } else {
7826 # comparing index with HEAD
7827 lappend cmd HEAD
7828 }
7829 } else {
7830 if {$log_showroot} {
7831 lappend flags --root
7832 }
7833 set cmd [concat | git diff-tree -r $flags $ids]
7834 }
7835 return $cmd
7836}
7837
7838proc gettreediffs {ids} {
7839 global treediff treepending limitdiffs vfilelimit curview
7840
7841 set cmd [diffcmd $ids {--no-commit-id}]
7842 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7843 set cmd [concat $cmd -- $vfilelimit($curview)]
7844 }
7845 if {[catch {set gdtf [open $cmd r]}]} return
7846
7847 set treepending $ids
7848 set treediff {}
7849 fconfigure $gdtf -blocking 0 -encoding binary
7850 filerun $gdtf [list gettreediffline $gdtf $ids]
7851}
7852
7853proc gettreediffline {gdtf ids} {
7854 global treediff treediffs treepending diffids diffmergeid
7855 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7856
7857 set nr 0
7858 set sublist {}
7859 set max 1000
7860 if {$perfile_attrs} {
7861 # cache_gitattr is slow, and even slower on win32 where we
7862 # have to invoke it for only about 30 paths at a time
7863 set max 500
7864 if {[tk windowingsystem] == "win32"} {
7865 set max 120
7866 }
7867 }
7868 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7869 set i [string first "\t" $line]
7870 if {$i >= 0} {
7871 set file [string range $line [expr {$i+1}] end]
7872 if {[string index $file 0] eq "\""} {
7873 set file [lindex $file 0]
7874 }
7875 set file [encoding convertfrom $file]
7876 if {$file ne [lindex $treediff end]} {
7877 lappend treediff $file
7878 lappend sublist $file
7879 }
7880 }
7881 }
7882 if {$perfile_attrs} {
7883 cache_gitattr encoding $sublist
7884 }
7885 if {![eof $gdtf]} {
7886 return [expr {$nr >= $max? 2: 1}]
7887 }
7888 close $gdtf
7889 set treediffs($ids) $treediff
7890 unset treepending
7891 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7892 gettree $diffids
7893 } elseif {$ids != $diffids} {
7894 if {![info exists diffmergeid]} {
7895 gettreediffs $diffids
7896 }
7897 } else {
7898 addtocflist $ids
7899 }
7900 return 0
7901}
7902
7903# empty string or positive integer
7904proc diffcontextvalidate {v} {
7905 return [regexp {^(|[1-9][0-9]*)$} $v]
7906}
7907
7908proc diffcontextchange {n1 n2 op} {
7909 global diffcontextstring diffcontext
7910
7911 if {[string is integer -strict $diffcontextstring]} {
7912 if {$diffcontextstring >= 0} {
7913 set diffcontext $diffcontextstring
7914 reselectline
7915 }
7916 }
7917}
7918
7919proc changeignorespace {} {
7920 reselectline
7921}
7922
7923proc changeworddiff {name ix op} {
7924 reselectline
7925}
7926
7927proc initblobdiffvars {} {
7928 global diffencoding targetline diffnparents
7929 global diffinhdr currdiffsubmod diffseehere
7930 set targetline {}
7931 set diffnparents 0
7932 set diffinhdr 0
7933 set diffencoding [get_path_encoding {}]
7934 set currdiffsubmod ""
7935 set diffseehere -1
7936}
7937
7938proc getblobdiffs {ids} {
7939 global blobdifffd diffids env
7940 global treediffs
7941 global diffcontext
7942 global ignorespace
7943 global worddiff
7944 global limitdiffs vfilelimit curview
7945 global git_version
7946
7947 set textconv {}
7948 if {[package vcompare $git_version "1.6.1"] >= 0} {
7949 set textconv "--textconv"
7950 }
7951 set submodule {}
7952 if {[package vcompare $git_version "1.6.6"] >= 0} {
7953 set submodule "--submodule"
7954 }
7955 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7956 if {$ignorespace} {
7957 append cmd " -w"
7958 }
7959 if {$worddiff ne [mc "Line diff"]} {
7960 append cmd " --word-diff=porcelain"
7961 }
7962 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7963 set cmd [concat $cmd -- $vfilelimit($curview)]
7964 }
7965 if {[catch {set bdf [open $cmd r]} err]} {
7966 error_popup [mc "Error getting diffs: %s" $err]
7967 return
7968 }
7969 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7970 set blobdifffd($ids) $bdf
7971 initblobdiffvars
7972 filerun $bdf [list getblobdiffline $bdf $diffids]
7973}
7974
7975proc savecmitpos {} {
7976 global ctext cmitmode
7977
7978 if {$cmitmode eq "tree"} {
7979 return {}
7980 }
7981 return [list target_scrollpos [$ctext index @0,0]]
7982}
7983
7984proc savectextpos {} {
7985 global ctext
7986
7987 return [list target_scrollpos [$ctext index @0,0]]
7988}
7989
7990proc maybe_scroll_ctext {ateof} {
7991 global ctext target_scrollpos
7992
7993 if {![info exists target_scrollpos]} return
7994 if {!$ateof} {
7995 set nlines [expr {[winfo height $ctext]
7996 / [font metrics textfont -linespace]}]
7997 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7998 }
7999 $ctext yview $target_scrollpos
8000 unset target_scrollpos
8001}
8002
8003proc setinlist {var i val} {
8004 global $var
8005
8006 while {[llength [set $var]] < $i} {
8007 lappend $var {}
8008 }
8009 if {[llength [set $var]] == $i} {
8010 lappend $var $val
8011 } else {
8012 lset $var $i $val
8013 }
8014}
8015
8016proc makediffhdr {fname ids} {
8017 global ctext curdiffstart treediffs diffencoding
8018 global ctext_file_names jump_to_here targetline diffline
8019
8020 set fname [encoding convertfrom $fname]
8021 set diffencoding [get_path_encoding $fname]
8022 set i [lsearch -exact $treediffs($ids) $fname]
8023 if {$i >= 0} {
8024 setinlist difffilestart $i $curdiffstart
8025 }
8026 lset ctext_file_names end $fname
8027 set l [expr {(78 - [string length $fname]) / 2}]
8028 set pad [string range "----------------------------------------" 1 $l]
8029 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8030 set targetline {}
8031 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8032 set targetline [lindex $jump_to_here 1]
8033 }
8034 set diffline 0
8035}
8036
8037proc blobdiffmaybeseehere {ateof} {
8038 global diffseehere
8039 if {$diffseehere >= 0} {
8040 mark_ctext_line [lindex [split $diffseehere .] 0]
8041 }
8042 maybe_scroll_ctext $ateof
8043}
8044
8045proc getblobdiffline {bdf ids} {
8046 global diffids blobdifffd
8047 global ctext
8048
8049 set nr 0
8050 $ctext conf -state normal
8051 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8052 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8053 catch {close $bdf}
8054 return 0
8055 }
8056 parseblobdiffline $ids $line
8057 }
8058 $ctext conf -state disabled
8059 blobdiffmaybeseehere [eof $bdf]
8060 if {[eof $bdf]} {
8061 catch {close $bdf}
8062 return 0
8063 }
8064 return [expr {$nr >= 1000? 2: 1}]
8065}
8066
8067proc parseblobdiffline {ids line} {
8068 global ctext curdiffstart
8069 global diffnexthead diffnextnote difffilestart
8070 global ctext_file_names ctext_file_lines
8071 global diffinhdr treediffs mergemax diffnparents
8072 global diffencoding jump_to_here targetline diffline currdiffsubmod
8073 global worddiff diffseehere
8074
8075 if {![string compare -length 5 "diff " $line]} {
8076 if {![regexp {^diff (--cc|--git) } $line m type]} {
8077 set line [encoding convertfrom $line]
8078 $ctext insert end "$line\n" hunksep
8079 continue
8080 }
8081 # start of a new file
8082 set diffinhdr 1
8083 $ctext insert end "\n"
8084 set curdiffstart [$ctext index "end - 1c"]
8085 lappend ctext_file_names ""
8086 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8087 $ctext insert end "\n" filesep
8088
8089 if {$type eq "--cc"} {
8090 # start of a new file in a merge diff
8091 set fname [string range $line 10 end]
8092 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8093 lappend treediffs($ids) $fname
8094 add_flist [list $fname]
8095 }
8096
8097 } else {
8098 set line [string range $line 11 end]
8099 # If the name hasn't changed the length will be odd,
8100 # the middle char will be a space, and the two bits either
8101 # side will be a/name and b/name, or "a/name" and "b/name".
8102 # If the name has changed we'll get "rename from" and
8103 # "rename to" or "copy from" and "copy to" lines following
8104 # this, and we'll use them to get the filenames.
8105 # This complexity is necessary because spaces in the
8106 # filename(s) don't get escaped.
8107 set l [string length $line]
8108 set i [expr {$l / 2}]
8109 if {!(($l & 1) && [string index $line $i] eq " " &&
8110 [string range $line 2 [expr {$i - 1}]] eq \
8111 [string range $line [expr {$i + 3}] end])} {
8112 return
8113 }
8114 # unescape if quoted and chop off the a/ from the front
8115 if {[string index $line 0] eq "\""} {
8116 set fname [string range [lindex $line 0] 2 end]
8117 } else {
8118 set fname [string range $line 2 [expr {$i - 1}]]
8119 }
8120 }
8121 makediffhdr $fname $ids
8122
8123 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8124 set fname [encoding convertfrom [string range $line 16 end]]
8125 $ctext insert end "\n"
8126 set curdiffstart [$ctext index "end - 1c"]
8127 lappend ctext_file_names $fname
8128 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8129 $ctext insert end "$line\n" filesep
8130 set i [lsearch -exact $treediffs($ids) $fname]
8131 if {$i >= 0} {
8132 setinlist difffilestart $i $curdiffstart
8133 }
8134
8135 } elseif {![string compare -length 2 "@@" $line]} {
8136 regexp {^@@+} $line ats
8137 set line [encoding convertfrom $diffencoding $line]
8138 $ctext insert end "$line\n" hunksep
8139 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8140 set diffline $nl
8141 }
8142 set diffnparents [expr {[string length $ats] - 1}]
8143 set diffinhdr 0
8144
8145 } elseif {![string compare -length 10 "Submodule " $line]} {
8146 # start of a new submodule
8147 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8148 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8149 } else {
8150 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8151 }
8152 if {$currdiffsubmod != $fname} {
8153 $ctext insert end "\n"; # Add newline after commit message
8154 }
8155 set curdiffstart [$ctext index "end - 1c"]
8156 lappend ctext_file_names ""
8157 if {$currdiffsubmod != $fname} {
8158 lappend ctext_file_lines $fname
8159 makediffhdr $fname $ids
8160 set currdiffsubmod $fname
8161 $ctext insert end "\n$line\n" filesep
8162 } else {
8163 $ctext insert end "$line\n" filesep
8164 }
8165 } elseif {![string compare -length 3 " >" $line]} {
8166 set $currdiffsubmod ""
8167 set line [encoding convertfrom $diffencoding $line]
8168 $ctext insert end "$line\n" dresult
8169 } elseif {![string compare -length 3 " <" $line]} {
8170 set $currdiffsubmod ""
8171 set line [encoding convertfrom $diffencoding $line]
8172 $ctext insert end "$line\n" d0
8173 } elseif {$diffinhdr} {
8174 if {![string compare -length 12 "rename from " $line]} {
8175 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8176 if {[string index $fname 0] eq "\""} {
8177 set fname [lindex $fname 0]
8178 }
8179 set fname [encoding convertfrom $fname]
8180 set i [lsearch -exact $treediffs($ids) $fname]
8181 if {$i >= 0} {
8182 setinlist difffilestart $i $curdiffstart
8183 }
8184 } elseif {![string compare -length 10 $line "rename to "] ||
8185 ![string compare -length 8 $line "copy to "]} {
8186 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8187 if {[string index $fname 0] eq "\""} {
8188 set fname [lindex $fname 0]
8189 }
8190 makediffhdr $fname $ids
8191 } elseif {[string compare -length 3 $line "---"] == 0} {
8192 # do nothing
8193 return
8194 } elseif {[string compare -length 3 $line "+++"] == 0} {
8195 set diffinhdr 0
8196 return
8197 }
8198 $ctext insert end "$line\n" filesep
8199
8200 } else {
8201 set line [string map {\x1A ^Z} \
8202 [encoding convertfrom $diffencoding $line]]
8203 # parse the prefix - one ' ', '-' or '+' for each parent
8204 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8205 set tag [expr {$diffnparents > 1? "m": "d"}]
8206 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8207 set words_pre_markup ""
8208 set words_post_markup ""
8209 if {[string trim $prefix " -+"] eq {}} {
8210 # prefix only has " ", "-" and "+" in it: normal diff line
8211 set num [string first "-" $prefix]
8212 if {$dowords} {
8213 set line [string range $line 1 end]
8214 }
8215 if {$num >= 0} {
8216 # removed line, first parent with line is $num
8217 if {$num >= $mergemax} {
8218 set num "max"
8219 }
8220 if {$dowords && $worddiff eq [mc "Markup words"]} {
8221 $ctext insert end "\[-$line-\]" $tag$num
8222 } else {
8223 $ctext insert end "$line" $tag$num
8224 }
8225 if {!$dowords} {
8226 $ctext insert end "\n" $tag$num
8227 }
8228 } else {
8229 set tags {}
8230 if {[string first "+" $prefix] >= 0} {
8231 # added line
8232 lappend tags ${tag}result
8233 if {$diffnparents > 1} {
8234 set num [string first " " $prefix]
8235 if {$num >= 0} {
8236 if {$num >= $mergemax} {
8237 set num "max"
8238 }
8239 lappend tags m$num
8240 }
8241 }
8242 set words_pre_markup "{+"
8243 set words_post_markup "+}"
8244 }
8245 if {$targetline ne {}} {
8246 if {$diffline == $targetline} {
8247 set diffseehere [$ctext index "end - 1 chars"]
8248 set targetline {}
8249 } else {
8250 incr diffline
8251 }
8252 }
8253 if {$dowords && $worddiff eq [mc "Markup words"]} {
8254 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8255 } else {
8256 $ctext insert end "$line" $tags
8257 }
8258 if {!$dowords} {
8259 $ctext insert end "\n" $tags
8260 }
8261 }
8262 } elseif {$dowords && $prefix eq "~"} {
8263 $ctext insert end "\n" {}
8264 } else {
8265 # "\ No newline at end of file",
8266 # or something else we don't recognize
8267 $ctext insert end "$line\n" hunksep
8268 }
8269 }
8270}
8271
8272proc changediffdisp {} {
8273 global ctext diffelide
8274
8275 $ctext tag conf d0 -elide [lindex $diffelide 0]
8276 $ctext tag conf dresult -elide [lindex $diffelide 1]
8277}
8278
8279proc highlightfile {cline} {
8280 global cflist cflist_top
8281
8282 if {![info exists cflist_top]} return
8283
8284 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8285 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8286 $cflist see $cline.0
8287 set cflist_top $cline
8288}
8289
8290proc highlightfile_for_scrollpos {topidx} {
8291 global cmitmode difffilestart
8292
8293 if {$cmitmode eq "tree"} return
8294 if {![info exists difffilestart]} return
8295
8296 set top [lindex [split $topidx .] 0]
8297 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8298 highlightfile 0
8299 } else {
8300 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8301 }
8302}
8303
8304proc prevfile {} {
8305 global difffilestart ctext cmitmode
8306
8307 if {$cmitmode eq "tree"} return
8308 set prev 0.0
8309 set here [$ctext index @0,0]
8310 foreach loc $difffilestart {
8311 if {[$ctext compare $loc >= $here]} {
8312 $ctext yview $prev
8313 return
8314 }
8315 set prev $loc
8316 }
8317 $ctext yview $prev
8318}
8319
8320proc nextfile {} {
8321 global difffilestart ctext cmitmode
8322
8323 if {$cmitmode eq "tree"} return
8324 set here [$ctext index @0,0]
8325 foreach loc $difffilestart {
8326 if {[$ctext compare $loc > $here]} {
8327 $ctext yview $loc
8328 return
8329 }
8330 }
8331}
8332
8333proc clear_ctext {{first 1.0}} {
8334 global ctext smarktop smarkbot
8335 global ctext_file_names ctext_file_lines
8336 global pendinglinks
8337
8338 set l [lindex [split $first .] 0]
8339 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8340 set smarktop $l
8341 }
8342 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8343 set smarkbot $l
8344 }
8345 $ctext delete $first end
8346 if {$first eq "1.0"} {
8347 unset -nocomplain pendinglinks
8348 }
8349 set ctext_file_names {}
8350 set ctext_file_lines {}
8351}
8352
8353proc settabs {{firstab {}}} {
8354 global firsttabstop tabstop ctext have_tk85
8355
8356 if {$firstab ne {} && $have_tk85} {
8357 set firsttabstop $firstab
8358 }
8359 set w [font measure textfont "0"]
8360 if {$firsttabstop != 0} {
8361 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8362 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8363 } elseif {$have_tk85 || $tabstop != 8} {
8364 $ctext conf -tabs [expr {$tabstop * $w}]
8365 } else {
8366 $ctext conf -tabs {}
8367 }
8368}
8369
8370proc incrsearch {name ix op} {
8371 global ctext searchstring searchdirn
8372
8373 if {[catch {$ctext index anchor}]} {
8374 # no anchor set, use start of selection, or of visible area
8375 set sel [$ctext tag ranges sel]
8376 if {$sel ne {}} {
8377 $ctext mark set anchor [lindex $sel 0]
8378 } elseif {$searchdirn eq "-forwards"} {
8379 $ctext mark set anchor @0,0
8380 } else {
8381 $ctext mark set anchor @0,[winfo height $ctext]
8382 }
8383 }
8384 if {$searchstring ne {}} {
8385 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8386 if {$here ne {}} {
8387 $ctext see $here
8388 set mend "$here + $mlen c"
8389 $ctext tag remove sel 1.0 end
8390 $ctext tag add sel $here $mend
8391 suppress_highlighting_file_for_current_scrollpos
8392 highlightfile_for_scrollpos $here
8393 }
8394 }
8395 rehighlight_search_results
8396}
8397
8398proc dosearch {} {
8399 global sstring ctext searchstring searchdirn
8400
8401 focus $sstring
8402 $sstring icursor end
8403 set searchdirn -forwards
8404 if {$searchstring ne {}} {
8405 set sel [$ctext tag ranges sel]
8406 if {$sel ne {}} {
8407 set start "[lindex $sel 0] + 1c"
8408 } elseif {[catch {set start [$ctext index anchor]}]} {
8409 set start "@0,0"
8410 }
8411 set match [$ctext search -count mlen -- $searchstring $start]
8412 $ctext tag remove sel 1.0 end
8413 if {$match eq {}} {
8414 bell
8415 return
8416 }
8417 $ctext see $match
8418 suppress_highlighting_file_for_current_scrollpos
8419 highlightfile_for_scrollpos $match
8420 set mend "$match + $mlen c"
8421 $ctext tag add sel $match $mend
8422 $ctext mark unset anchor
8423 rehighlight_search_results
8424 }
8425}
8426
8427proc dosearchback {} {
8428 global sstring ctext searchstring searchdirn
8429
8430 focus $sstring
8431 $sstring icursor end
8432 set searchdirn -backwards
8433 if {$searchstring ne {}} {
8434 set sel [$ctext tag ranges sel]
8435 if {$sel ne {}} {
8436 set start [lindex $sel 0]
8437 } elseif {[catch {set start [$ctext index anchor]}]} {
8438 set start @0,[winfo height $ctext]
8439 }
8440 set match [$ctext search -backwards -count ml -- $searchstring $start]
8441 $ctext tag remove sel 1.0 end
8442 if {$match eq {}} {
8443 bell
8444 return
8445 }
8446 $ctext see $match
8447 suppress_highlighting_file_for_current_scrollpos
8448 highlightfile_for_scrollpos $match
8449 set mend "$match + $ml c"
8450 $ctext tag add sel $match $mend
8451 $ctext mark unset anchor
8452 rehighlight_search_results
8453 }
8454}
8455
8456proc rehighlight_search_results {} {
8457 global ctext searchstring
8458
8459 $ctext tag remove found 1.0 end
8460 $ctext tag remove currentsearchhit 1.0 end
8461
8462 if {$searchstring ne {}} {
8463 searchmarkvisible 1
8464 }
8465}
8466
8467proc searchmark {first last} {
8468 global ctext searchstring
8469
8470 set sel [$ctext tag ranges sel]
8471
8472 set mend $first.0
8473 while {1} {
8474 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8475 if {$match eq {}} break
8476 set mend "$match + $mlen c"
8477 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8478 $ctext tag add currentsearchhit $match $mend
8479 } else {
8480 $ctext tag add found $match $mend
8481 }
8482 }
8483}
8484
8485proc searchmarkvisible {doall} {
8486 global ctext smarktop smarkbot
8487
8488 set topline [lindex [split [$ctext index @0,0] .] 0]
8489 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8490 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8491 # no overlap with previous
8492 searchmark $topline $botline
8493 set smarktop $topline
8494 set smarkbot $botline
8495 } else {
8496 if {$topline < $smarktop} {
8497 searchmark $topline [expr {$smarktop-1}]
8498 set smarktop $topline
8499 }
8500 if {$botline > $smarkbot} {
8501 searchmark [expr {$smarkbot+1}] $botline
8502 set smarkbot $botline
8503 }
8504 }
8505}
8506
8507proc suppress_highlighting_file_for_current_scrollpos {} {
8508 global ctext suppress_highlighting_file_for_this_scrollpos
8509
8510 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8511}
8512
8513proc scrolltext {f0 f1} {
8514 global searchstring cmitmode ctext
8515 global suppress_highlighting_file_for_this_scrollpos
8516
8517 set topidx [$ctext index @0,0]
8518 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8519 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8520 highlightfile_for_scrollpos $topidx
8521 }
8522
8523 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8524
8525 .bleft.bottom.sb set $f0 $f1
8526 if {$searchstring ne {}} {
8527 searchmarkvisible 0
8528 }
8529}
8530
8531proc setcoords {} {
8532 global linespc charspc canvx0 canvy0
8533 global xspc1 xspc2 lthickness
8534
8535 set linespc [font metrics mainfont -linespace]
8536 set charspc [font measure mainfont "m"]
8537 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8538 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8539 set lthickness [expr {int($linespc / 9) + 1}]
8540 set xspc1(0) $linespc
8541 set xspc2 $linespc
8542}
8543
8544proc redisplay {} {
8545 global canv
8546 global selectedline
8547
8548 set ymax [lindex [$canv cget -scrollregion] 3]
8549 if {$ymax eq {} || $ymax == 0} return
8550 set span [$canv yview]
8551 clear_display
8552 setcanvscroll
8553 allcanvs yview moveto [lindex $span 0]
8554 drawvisible
8555 if {$selectedline ne {}} {
8556 selectline $selectedline 0
8557 allcanvs yview moveto [lindex $span 0]
8558 }
8559}
8560
8561proc parsefont {f n} {
8562 global fontattr
8563
8564 set fontattr($f,family) [lindex $n 0]
8565 set s [lindex $n 1]
8566 if {$s eq {} || $s == 0} {
8567 set s 10
8568 } elseif {$s < 0} {
8569 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8570 }
8571 set fontattr($f,size) $s
8572 set fontattr($f,weight) normal
8573 set fontattr($f,slant) roman
8574 foreach style [lrange $n 2 end] {
8575 switch -- $style {
8576 "normal" -
8577 "bold" {set fontattr($f,weight) $style}
8578 "roman" -
8579 "italic" {set fontattr($f,slant) $style}
8580 }
8581 }
8582}
8583
8584proc fontflags {f {isbold 0}} {
8585 global fontattr
8586
8587 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8588 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8589 -slant $fontattr($f,slant)]
8590}
8591
8592proc fontname {f} {
8593 global fontattr
8594
8595 set n [list $fontattr($f,family) $fontattr($f,size)]
8596 if {$fontattr($f,weight) eq "bold"} {
8597 lappend n "bold"
8598 }
8599 if {$fontattr($f,slant) eq "italic"} {
8600 lappend n "italic"
8601 }
8602 return $n
8603}
8604
8605proc incrfont {inc} {
8606 global mainfont textfont ctext canv cflist showrefstop
8607 global stopped entries fontattr
8608
8609 unmarkmatches
8610 set s $fontattr(mainfont,size)
8611 incr s $inc
8612 if {$s < 1} {
8613 set s 1
8614 }
8615 set fontattr(mainfont,size) $s
8616 font config mainfont -size $s
8617 font config mainfontbold -size $s
8618 set mainfont [fontname mainfont]
8619 set s $fontattr(textfont,size)
8620 incr s $inc
8621 if {$s < 1} {
8622 set s 1
8623 }
8624 set fontattr(textfont,size) $s
8625 font config textfont -size $s
8626 font config textfontbold -size $s
8627 set textfont [fontname textfont]
8628 setcoords
8629 settabs
8630 redisplay
8631}
8632
8633proc clearsha1 {} {
8634 global sha1entry sha1string
8635 if {[string length $sha1string] == 40} {
8636 $sha1entry delete 0 end
8637 }
8638}
8639
8640proc sha1change {n1 n2 op} {
8641 global sha1string currentid sha1but
8642 if {$sha1string == {}
8643 || ([info exists currentid] && $sha1string == $currentid)} {
8644 set state disabled
8645 } else {
8646 set state normal
8647 }
8648 if {[$sha1but cget -state] == $state} return
8649 if {$state == "normal"} {
8650 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8651 } else {
8652 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8653 }
8654}
8655
8656proc gotocommit {} {
8657 global sha1string tagids headids curview varcid
8658
8659 if {$sha1string == {}
8660 || ([info exists currentid] && $sha1string == $currentid)} return
8661 if {[info exists tagids($sha1string)]} {
8662 set id $tagids($sha1string)
8663 } elseif {[info exists headids($sha1string)]} {
8664 set id $headids($sha1string)
8665 } else {
8666 set id [string tolower $sha1string]
8667 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8668 set matches [longid $id]
8669 if {$matches ne {}} {
8670 if {[llength $matches] > 1} {
8671 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8672 return
8673 }
8674 set id [lindex $matches 0]
8675 }
8676 } else {
8677 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8678 error_popup [mc "Revision %s is not known" $sha1string]
8679 return
8680 }
8681 }
8682 }
8683 if {[commitinview $id $curview]} {
8684 selectline [rowofcommit $id] 1
8685 return
8686 }
8687 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8688 set msg [mc "SHA1 id %s is not known" $sha1string]
8689 } else {
8690 set msg [mc "Revision %s is not in the current view" $sha1string]
8691 }
8692 error_popup $msg
8693}
8694
8695proc lineenter {x y id} {
8696 global hoverx hovery hoverid hovertimer
8697 global commitinfo canv
8698
8699 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8700 set hoverx $x
8701 set hovery $y
8702 set hoverid $id
8703 if {[info exists hovertimer]} {
8704 after cancel $hovertimer
8705 }
8706 set hovertimer [after 500 linehover]
8707 $canv delete hover
8708}
8709
8710proc linemotion {x y id} {
8711 global hoverx hovery hoverid hovertimer
8712
8713 if {[info exists hoverid] && $id == $hoverid} {
8714 set hoverx $x
8715 set hovery $y
8716 if {[info exists hovertimer]} {
8717 after cancel $hovertimer
8718 }
8719 set hovertimer [after 500 linehover]
8720 }
8721}
8722
8723proc lineleave {id} {
8724 global hoverid hovertimer canv
8725
8726 if {[info exists hoverid] && $id == $hoverid} {
8727 $canv delete hover
8728 if {[info exists hovertimer]} {
8729 after cancel $hovertimer
8730 unset hovertimer
8731 }
8732 unset hoverid
8733 }
8734}
8735
8736proc linehover {} {
8737 global hoverx hovery hoverid hovertimer
8738 global canv linespc lthickness
8739 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8740
8741 global commitinfo
8742
8743 set text [lindex $commitinfo($hoverid) 0]
8744 set ymax [lindex [$canv cget -scrollregion] 3]
8745 if {$ymax == {}} return
8746 set yfrac [lindex [$canv yview] 0]
8747 set x [expr {$hoverx + 2 * $linespc}]
8748 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8749 set x0 [expr {$x - 2 * $lthickness}]
8750 set y0 [expr {$y - 2 * $lthickness}]
8751 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8752 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8753 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8754 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8755 -width 1 -tags hover]
8756 $canv raise $t
8757 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8758 -font mainfont -fill $linehoverfgcolor]
8759 $canv raise $t
8760}
8761
8762proc clickisonarrow {id y} {
8763 global lthickness
8764
8765 set ranges [rowranges $id]
8766 set thresh [expr {2 * $lthickness + 6}]
8767 set n [expr {[llength $ranges] - 1}]
8768 for {set i 1} {$i < $n} {incr i} {
8769 set row [lindex $ranges $i]
8770 if {abs([yc $row] - $y) < $thresh} {
8771 return $i
8772 }
8773 }
8774 return {}
8775}
8776
8777proc arrowjump {id n y} {
8778 global canv
8779
8780 # 1 <-> 2, 3 <-> 4, etc...
8781 set n [expr {(($n - 1) ^ 1) + 1}]
8782 set row [lindex [rowranges $id] $n]
8783 set yt [yc $row]
8784 set ymax [lindex [$canv cget -scrollregion] 3]
8785 if {$ymax eq {} || $ymax <= 0} return
8786 set view [$canv yview]
8787 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8788 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8789 if {$yfrac < 0} {
8790 set yfrac 0
8791 }
8792 allcanvs yview moveto $yfrac
8793}
8794
8795proc lineclick {x y id isnew} {
8796 global ctext commitinfo children canv thickerline curview
8797
8798 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8799 unmarkmatches
8800 unselectline
8801 normalline
8802 $canv delete hover
8803 # draw this line thicker than normal
8804 set thickerline $id
8805 drawlines $id
8806 if {$isnew} {
8807 set ymax [lindex [$canv cget -scrollregion] 3]
8808 if {$ymax eq {}} return
8809 set yfrac [lindex [$canv yview] 0]
8810 set y [expr {$y + $yfrac * $ymax}]
8811 }
8812 set dirn [clickisonarrow $id $y]
8813 if {$dirn ne {}} {
8814 arrowjump $id $dirn $y
8815 return
8816 }
8817
8818 if {$isnew} {
8819 addtohistory [list lineclick $x $y $id 0] savectextpos
8820 }
8821 # fill the details pane with info about this line
8822 $ctext conf -state normal
8823 clear_ctext
8824 settabs 0
8825 $ctext insert end "[mc "Parent"]:\t"
8826 $ctext insert end $id link0
8827 setlink $id link0
8828 set info $commitinfo($id)
8829 $ctext insert end "\n\t[lindex $info 0]\n"
8830 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8831 set date [formatdate [lindex $info 2]]
8832 $ctext insert end "\t[mc "Date"]:\t$date\n"
8833 set kids $children($curview,$id)
8834 if {$kids ne {}} {
8835 $ctext insert end "\n[mc "Children"]:"
8836 set i 0
8837 foreach child $kids {
8838 incr i
8839 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8840 set info $commitinfo($child)
8841 $ctext insert end "\n\t"
8842 $ctext insert end $child link$i
8843 setlink $child link$i
8844 $ctext insert end "\n\t[lindex $info 0]"
8845 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8846 set date [formatdate [lindex $info 2]]
8847 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8848 }
8849 }
8850 maybe_scroll_ctext 1
8851 $ctext conf -state disabled
8852 init_flist {}
8853}
8854
8855proc normalline {} {
8856 global thickerline
8857 if {[info exists thickerline]} {
8858 set id $thickerline
8859 unset thickerline
8860 drawlines $id
8861 }
8862}
8863
8864proc selbyid {id {isnew 1}} {
8865 global curview
8866 if {[commitinview $id $curview]} {
8867 selectline [rowofcommit $id] $isnew
8868 }
8869}
8870
8871proc mstime {} {
8872 global startmstime
8873 if {![info exists startmstime]} {
8874 set startmstime [clock clicks -milliseconds]
8875 }
8876 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8877}
8878
8879proc rowmenu {x y id} {
8880 global rowctxmenu selectedline rowmenuid curview
8881 global nullid nullid2 fakerowmenu mainhead markedid
8882
8883 stopfinding
8884 set rowmenuid $id
8885 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8886 set state disabled
8887 } else {
8888 set state normal
8889 }
8890 if {[info exists markedid] && $markedid ne $id} {
8891 set mstate normal
8892 } else {
8893 set mstate disabled
8894 }
8895 if {$id ne $nullid && $id ne $nullid2} {
8896 set menu $rowctxmenu
8897 if {$mainhead ne {}} {
8898 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8899 } else {
8900 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8901 }
8902 $menu entryconfigure 9 -state $mstate
8903 $menu entryconfigure 10 -state $mstate
8904 $menu entryconfigure 11 -state $mstate
8905 } else {
8906 set menu $fakerowmenu
8907 }
8908 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8909 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8910 $menu entryconfigure [mca "Make patch"] -state $state
8911 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8912 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8913 tk_popup $menu $x $y
8914}
8915
8916proc markhere {} {
8917 global rowmenuid markedid canv
8918
8919 set markedid $rowmenuid
8920 make_idmark $markedid
8921}
8922
8923proc gotomark {} {
8924 global markedid
8925
8926 if {[info exists markedid]} {
8927 selbyid $markedid
8928 }
8929}
8930
8931proc replace_by_kids {l r} {
8932 global curview children
8933
8934 set id [commitonrow $r]
8935 set l [lreplace $l 0 0]
8936 foreach kid $children($curview,$id) {
8937 lappend l [rowofcommit $kid]
8938 }
8939 return [lsort -integer -decreasing -unique $l]
8940}
8941
8942proc find_common_desc {} {
8943 global markedid rowmenuid curview children
8944
8945 if {![info exists markedid]} return
8946 if {![commitinview $markedid $curview] ||
8947 ![commitinview $rowmenuid $curview]} return
8948 #set t1 [clock clicks -milliseconds]
8949 set l1 [list [rowofcommit $markedid]]
8950 set l2 [list [rowofcommit $rowmenuid]]
8951 while 1 {
8952 set r1 [lindex $l1 0]
8953 set r2 [lindex $l2 0]
8954 if {$r1 eq {} || $r2 eq {}} break
8955 if {$r1 == $r2} {
8956 selectline $r1 1
8957 break
8958 }
8959 if {$r1 > $r2} {
8960 set l1 [replace_by_kids $l1 $r1]
8961 } else {
8962 set l2 [replace_by_kids $l2 $r2]
8963 }
8964 }
8965 #set t2 [clock clicks -milliseconds]
8966 #puts "took [expr {$t2-$t1}]ms"
8967}
8968
8969proc compare_commits {} {
8970 global markedid rowmenuid curview children
8971
8972 if {![info exists markedid]} return
8973 if {![commitinview $markedid $curview]} return
8974 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8975 do_cmp_commits $markedid $rowmenuid
8976}
8977
8978proc getpatchid {id} {
8979 global patchids
8980
8981 if {![info exists patchids($id)]} {
8982 set cmd [diffcmd [list $id] {-p --root}]
8983 # trim off the initial "|"
8984 set cmd [lrange $cmd 1 end]
8985 if {[catch {
8986 set x [eval exec $cmd | git patch-id]
8987 set patchids($id) [lindex $x 0]
8988 }]} {
8989 set patchids($id) "error"
8990 }
8991 }
8992 return $patchids($id)
8993}
8994
8995proc do_cmp_commits {a b} {
8996 global ctext curview parents children patchids commitinfo
8997
8998 $ctext conf -state normal
8999 clear_ctext
9000 init_flist {}
9001 for {set i 0} {$i < 100} {incr i} {
9002 set skipa 0
9003 set skipb 0
9004 if {[llength $parents($curview,$a)] > 1} {
9005 appendshortlink $a [mc "Skipping merge commit "] "\n"
9006 set skipa 1
9007 } else {
9008 set patcha [getpatchid $a]
9009 }
9010 if {[llength $parents($curview,$b)] > 1} {
9011 appendshortlink $b [mc "Skipping merge commit "] "\n"
9012 set skipb 1
9013 } else {
9014 set patchb [getpatchid $b]
9015 }
9016 if {!$skipa && !$skipb} {
9017 set heada [lindex $commitinfo($a) 0]
9018 set headb [lindex $commitinfo($b) 0]
9019 if {$patcha eq "error"} {
9020 appendshortlink $a [mc "Error getting patch ID for "] \
9021 [mc " - stopping\n"]
9022 break
9023 }
9024 if {$patchb eq "error"} {
9025 appendshortlink $b [mc "Error getting patch ID for "] \
9026 [mc " - stopping\n"]
9027 break
9028 }
9029 if {$patcha eq $patchb} {
9030 if {$heada eq $headb} {
9031 appendshortlink $a [mc "Commit "]
9032 appendshortlink $b " == " " $heada\n"
9033 } else {
9034 appendshortlink $a [mc "Commit "] " $heada\n"
9035 appendshortlink $b [mc " is the same patch as\n "] \
9036 " $headb\n"
9037 }
9038 set skipa 1
9039 set skipb 1
9040 } else {
9041 $ctext insert end "\n"
9042 appendshortlink $a [mc "Commit "] " $heada\n"
9043 appendshortlink $b [mc " differs from\n "] \
9044 " $headb\n"
9045 $ctext insert end [mc "Diff of commits:\n\n"]
9046 $ctext conf -state disabled
9047 update
9048 diffcommits $a $b
9049 return
9050 }
9051 }
9052 if {$skipa} {
9053 set kids [real_children $curview,$a]
9054 if {[llength $kids] != 1} {
9055 $ctext insert end "\n"
9056 appendshortlink $a [mc "Commit "] \
9057 [mc " has %s children - stopping\n" [llength $kids]]
9058 break
9059 }
9060 set a [lindex $kids 0]
9061 }
9062 if {$skipb} {
9063 set kids [real_children $curview,$b]
9064 if {[llength $kids] != 1} {
9065 appendshortlink $b [mc "Commit "] \
9066 [mc " has %s children - stopping\n" [llength $kids]]
9067 break
9068 }
9069 set b [lindex $kids 0]
9070 }
9071 }
9072 $ctext conf -state disabled
9073}
9074
9075proc diffcommits {a b} {
9076 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9077
9078 set tmpdir [gitknewtmpdir]
9079 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9080 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9081 if {[catch {
9082 exec git diff-tree -p --pretty $a >$fna
9083 exec git diff-tree -p --pretty $b >$fnb
9084 } err]} {
9085 error_popup [mc "Error writing commit to file: %s" $err]
9086 return
9087 }
9088 if {[catch {
9089 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9090 } err]} {
9091 error_popup [mc "Error diffing commits: %s" $err]
9092 return
9093 }
9094 set diffids [list commits $a $b]
9095 set blobdifffd($diffids) $fd
9096 set diffinhdr 0
9097 set currdiffsubmod ""
9098 filerun $fd [list getblobdiffline $fd $diffids]
9099}
9100
9101proc diffvssel {dirn} {
9102 global rowmenuid selectedline
9103
9104 if {$selectedline eq {}} return
9105 if {$dirn} {
9106 set oldid [commitonrow $selectedline]
9107 set newid $rowmenuid
9108 } else {
9109 set oldid $rowmenuid
9110 set newid [commitonrow $selectedline]
9111 }
9112 addtohistory [list doseldiff $oldid $newid] savectextpos
9113 doseldiff $oldid $newid
9114}
9115
9116proc diffvsmark {dirn} {
9117 global rowmenuid markedid
9118
9119 if {![info exists markedid]} return
9120 if {$dirn} {
9121 set oldid $markedid
9122 set newid $rowmenuid
9123 } else {
9124 set oldid $rowmenuid
9125 set newid $markedid
9126 }
9127 addtohistory [list doseldiff $oldid $newid] savectextpos
9128 doseldiff $oldid $newid
9129}
9130
9131proc doseldiff {oldid newid} {
9132 global ctext
9133 global commitinfo
9134
9135 $ctext conf -state normal
9136 clear_ctext
9137 init_flist [mc "Top"]
9138 $ctext insert end "[mc "From"] "
9139 $ctext insert end $oldid link0
9140 setlink $oldid link0
9141 $ctext insert end "\n "
9142 $ctext insert end [lindex $commitinfo($oldid) 0]
9143 $ctext insert end "\n\n[mc "To"] "
9144 $ctext insert end $newid link1
9145 setlink $newid link1
9146 $ctext insert end "\n "
9147 $ctext insert end [lindex $commitinfo($newid) 0]
9148 $ctext insert end "\n"
9149 $ctext conf -state disabled
9150 $ctext tag remove found 1.0 end
9151 startdiff [list $oldid $newid]
9152}
9153
9154proc mkpatch {} {
9155 global rowmenuid currentid commitinfo patchtop patchnum NS
9156
9157 if {![info exists currentid]} return
9158 set oldid $currentid
9159 set oldhead [lindex $commitinfo($oldid) 0]
9160 set newid $rowmenuid
9161 set newhead [lindex $commitinfo($newid) 0]
9162 set top .patch
9163 set patchtop $top
9164 catch {destroy $top}
9165 ttk_toplevel $top
9166 make_transient $top .
9167 ${NS}::label $top.title -text [mc "Generate patch"]
9168 grid $top.title - -pady 10
9169 ${NS}::label $top.from -text [mc "From:"]
9170 ${NS}::entry $top.fromsha1 -width 40
9171 $top.fromsha1 insert 0 $oldid
9172 $top.fromsha1 conf -state readonly
9173 grid $top.from $top.fromsha1 -sticky w
9174 ${NS}::entry $top.fromhead -width 60
9175 $top.fromhead insert 0 $oldhead
9176 $top.fromhead conf -state readonly
9177 grid x $top.fromhead -sticky w
9178 ${NS}::label $top.to -text [mc "To:"]
9179 ${NS}::entry $top.tosha1 -width 40
9180 $top.tosha1 insert 0 $newid
9181 $top.tosha1 conf -state readonly
9182 grid $top.to $top.tosha1 -sticky w
9183 ${NS}::entry $top.tohead -width 60
9184 $top.tohead insert 0 $newhead
9185 $top.tohead conf -state readonly
9186 grid x $top.tohead -sticky w
9187 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9188 grid $top.rev x -pady 10 -padx 5
9189 ${NS}::label $top.flab -text [mc "Output file:"]
9190 ${NS}::entry $top.fname -width 60
9191 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9192 incr patchnum
9193 grid $top.flab $top.fname -sticky w
9194 ${NS}::frame $top.buts
9195 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9196 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9197 bind $top <Key-Return> mkpatchgo
9198 bind $top <Key-Escape> mkpatchcan
9199 grid $top.buts.gen $top.buts.can
9200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9202 grid $top.buts - -pady 10 -sticky ew
9203 focus $top.fname
9204}
9205
9206proc mkpatchrev {} {
9207 global patchtop
9208
9209 set oldid [$patchtop.fromsha1 get]
9210 set oldhead [$patchtop.fromhead get]
9211 set newid [$patchtop.tosha1 get]
9212 set newhead [$patchtop.tohead get]
9213 foreach e [list fromsha1 fromhead tosha1 tohead] \
9214 v [list $newid $newhead $oldid $oldhead] {
9215 $patchtop.$e conf -state normal
9216 $patchtop.$e delete 0 end
9217 $patchtop.$e insert 0 $v
9218 $patchtop.$e conf -state readonly
9219 }
9220}
9221
9222proc mkpatchgo {} {
9223 global patchtop nullid nullid2
9224
9225 set oldid [$patchtop.fromsha1 get]
9226 set newid [$patchtop.tosha1 get]
9227 set fname [$patchtop.fname get]
9228 set cmd [diffcmd [list $oldid $newid] -p]
9229 # trim off the initial "|"
9230 set cmd [lrange $cmd 1 end]
9231 lappend cmd >$fname &
9232 if {[catch {eval exec $cmd} err]} {
9233 error_popup "[mc "Error creating patch:"] $err" $patchtop
9234 }
9235 catch {destroy $patchtop}
9236 unset patchtop
9237}
9238
9239proc mkpatchcan {} {
9240 global patchtop
9241
9242 catch {destroy $patchtop}
9243 unset patchtop
9244}
9245
9246proc mktag {} {
9247 global rowmenuid mktagtop commitinfo NS
9248
9249 set top .maketag
9250 set mktagtop $top
9251 catch {destroy $top}
9252 ttk_toplevel $top
9253 make_transient $top .
9254 ${NS}::label $top.title -text [mc "Create tag"]
9255 grid $top.title - -pady 10
9256 ${NS}::label $top.id -text [mc "ID:"]
9257 ${NS}::entry $top.sha1 -width 40
9258 $top.sha1 insert 0 $rowmenuid
9259 $top.sha1 conf -state readonly
9260 grid $top.id $top.sha1 -sticky w
9261 ${NS}::entry $top.head -width 60
9262 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9263 $top.head conf -state readonly
9264 grid x $top.head -sticky w
9265 ${NS}::label $top.tlab -text [mc "Tag name:"]
9266 ${NS}::entry $top.tag -width 60
9267 grid $top.tlab $top.tag -sticky w
9268 ${NS}::label $top.op -text [mc "Tag message is optional"]
9269 grid $top.op -columnspan 2 -sticky we
9270 ${NS}::label $top.mlab -text [mc "Tag message:"]
9271 ${NS}::entry $top.msg -width 60
9272 grid $top.mlab $top.msg -sticky w
9273 ${NS}::frame $top.buts
9274 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9275 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9276 bind $top <Key-Return> mktaggo
9277 bind $top <Key-Escape> mktagcan
9278 grid $top.buts.gen $top.buts.can
9279 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9280 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9281 grid $top.buts - -pady 10 -sticky ew
9282 focus $top.tag
9283}
9284
9285proc domktag {} {
9286 global mktagtop env tagids idtags
9287
9288 set id [$mktagtop.sha1 get]
9289 set tag [$mktagtop.tag get]
9290 set msg [$mktagtop.msg get]
9291 if {$tag == {}} {
9292 error_popup [mc "No tag name specified"] $mktagtop
9293 return 0
9294 }
9295 if {[info exists tagids($tag)]} {
9296 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9297 return 0
9298 }
9299 if {[catch {
9300 if {$msg != {}} {
9301 exec git tag -a -m $msg $tag $id
9302 } else {
9303 exec git tag $tag $id
9304 }
9305 } err]} {
9306 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9307 return 0
9308 }
9309
9310 set tagids($tag) $id
9311 lappend idtags($id) $tag
9312 redrawtags $id
9313 addedtag $id
9314 dispneartags 0
9315 run refill_reflist
9316 return 1
9317}
9318
9319proc redrawtags {id} {
9320 global canv linehtag idpos currentid curview cmitlisted markedid
9321 global canvxmax iddrawn circleitem mainheadid circlecolors
9322 global mainheadcirclecolor
9323
9324 if {![commitinview $id $curview]} return
9325 if {![info exists iddrawn($id)]} return
9326 set row [rowofcommit $id]
9327 if {$id eq $mainheadid} {
9328 set ofill $mainheadcirclecolor
9329 } else {
9330 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9331 }
9332 $canv itemconf $circleitem($row) -fill $ofill
9333 $canv delete tag.$id
9334 set xt [eval drawtags $id $idpos($id)]
9335 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9336 set text [$canv itemcget $linehtag($id) -text]
9337 set font [$canv itemcget $linehtag($id) -font]
9338 set xr [expr {$xt + [font measure $font $text]}]
9339 if {$xr > $canvxmax} {
9340 set canvxmax $xr
9341 setcanvscroll
9342 }
9343 if {[info exists currentid] && $currentid == $id} {
9344 make_secsel $id
9345 }
9346 if {[info exists markedid] && $markedid eq $id} {
9347 make_idmark $id
9348 }
9349}
9350
9351proc mktagcan {} {
9352 global mktagtop
9353
9354 catch {destroy $mktagtop}
9355 unset mktagtop
9356}
9357
9358proc mktaggo {} {
9359 if {![domktag]} return
9360 mktagcan
9361}
9362
9363proc writecommit {} {
9364 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9365
9366 set top .writecommit
9367 set wrcomtop $top
9368 catch {destroy $top}
9369 ttk_toplevel $top
9370 make_transient $top .
9371 ${NS}::label $top.title -text [mc "Write commit to file"]
9372 grid $top.title - -pady 10
9373 ${NS}::label $top.id -text [mc "ID:"]
9374 ${NS}::entry $top.sha1 -width 40
9375 $top.sha1 insert 0 $rowmenuid
9376 $top.sha1 conf -state readonly
9377 grid $top.id $top.sha1 -sticky w
9378 ${NS}::entry $top.head -width 60
9379 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9380 $top.head conf -state readonly
9381 grid x $top.head -sticky w
9382 ${NS}::label $top.clab -text [mc "Command:"]
9383 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9384 grid $top.clab $top.cmd -sticky w -pady 10
9385 ${NS}::label $top.flab -text [mc "Output file:"]
9386 ${NS}::entry $top.fname -width 60
9387 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9388 grid $top.flab $top.fname -sticky w
9389 ${NS}::frame $top.buts
9390 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9391 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9392 bind $top <Key-Return> wrcomgo
9393 bind $top <Key-Escape> wrcomcan
9394 grid $top.buts.gen $top.buts.can
9395 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9396 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9397 grid $top.buts - -pady 10 -sticky ew
9398 focus $top.fname
9399}
9400
9401proc wrcomgo {} {
9402 global wrcomtop
9403
9404 set id [$wrcomtop.sha1 get]
9405 set cmd "echo $id | [$wrcomtop.cmd get]"
9406 set fname [$wrcomtop.fname get]
9407 if {[catch {exec sh -c $cmd >$fname &} err]} {
9408 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9409 }
9410 catch {destroy $wrcomtop}
9411 unset wrcomtop
9412}
9413
9414proc wrcomcan {} {
9415 global wrcomtop
9416
9417 catch {destroy $wrcomtop}
9418 unset wrcomtop
9419}
9420
9421proc mkbranch {} {
9422 global rowmenuid mkbrtop NS
9423
9424 set top .makebranch
9425 catch {destroy $top}
9426 ttk_toplevel $top
9427 make_transient $top .
9428 ${NS}::label $top.title -text [mc "Create new branch"]
9429 grid $top.title - -pady 10
9430 ${NS}::label $top.id -text [mc "ID:"]
9431 ${NS}::entry $top.sha1 -width 40
9432 $top.sha1 insert 0 $rowmenuid
9433 $top.sha1 conf -state readonly
9434 grid $top.id $top.sha1 -sticky w
9435 ${NS}::label $top.nlab -text [mc "Name:"]
9436 ${NS}::entry $top.name -width 40
9437 grid $top.nlab $top.name -sticky w
9438 ${NS}::frame $top.buts
9439 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9440 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9441 bind $top <Key-Return> [list mkbrgo $top]
9442 bind $top <Key-Escape> "catch {destroy $top}"
9443 grid $top.buts.go $top.buts.can
9444 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9445 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9446 grid $top.buts - -pady 10 -sticky ew
9447 focus $top.name
9448}
9449
9450proc mkbrgo {top} {
9451 global headids idheads
9452
9453 set name [$top.name get]
9454 set id [$top.sha1 get]
9455 set cmdargs {}
9456 set old_id {}
9457 if {$name eq {}} {
9458 error_popup [mc "Please specify a name for the new branch"] $top
9459 return
9460 }
9461 if {[info exists headids($name)]} {
9462 if {![confirm_popup [mc \
9463 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9464 return
9465 }
9466 set old_id $headids($name)
9467 lappend cmdargs -f
9468 }
9469 catch {destroy $top}
9470 lappend cmdargs $name $id
9471 nowbusy newbranch
9472 update
9473 if {[catch {
9474 eval exec git branch $cmdargs
9475 } err]} {
9476 notbusy newbranch
9477 error_popup $err
9478 } else {
9479 notbusy newbranch
9480 if {$old_id ne {}} {
9481 movehead $id $name
9482 movedhead $id $name
9483 redrawtags $old_id
9484 redrawtags $id
9485 } else {
9486 set headids($name) $id
9487 lappend idheads($id) $name
9488 addedhead $id $name
9489 redrawtags $id
9490 }
9491 dispneartags 0
9492 run refill_reflist
9493 }
9494}
9495
9496proc exec_citool {tool_args {baseid {}}} {
9497 global commitinfo env
9498
9499 set save_env [array get env GIT_AUTHOR_*]
9500
9501 if {$baseid ne {}} {
9502 if {![info exists commitinfo($baseid)]} {
9503 getcommit $baseid
9504 }
9505 set author [lindex $commitinfo($baseid) 1]
9506 set date [lindex $commitinfo($baseid) 2]
9507 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9508 $author author name email]
9509 && $date ne {}} {
9510 set env(GIT_AUTHOR_NAME) $name
9511 set env(GIT_AUTHOR_EMAIL) $email
9512 set env(GIT_AUTHOR_DATE) $date
9513 }
9514 }
9515
9516 eval exec git citool $tool_args &
9517
9518 array unset env GIT_AUTHOR_*
9519 array set env $save_env
9520}
9521
9522proc cherrypick {} {
9523 global rowmenuid curview
9524 global mainhead mainheadid
9525 global gitdir
9526
9527 set oldhead [exec git rev-parse HEAD]
9528 set dheads [descheads $rowmenuid]
9529 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9530 set ok [confirm_popup [mc "Commit %s is already\
9531 included in branch %s -- really re-apply it?" \
9532 [string range $rowmenuid 0 7] $mainhead]]
9533 if {!$ok} return
9534 }
9535 nowbusy cherrypick [mc "Cherry-picking"]
9536 update
9537 # Unfortunately git-cherry-pick writes stuff to stderr even when
9538 # no error occurs, and exec takes that as an indication of error...
9539 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9540 notbusy cherrypick
9541 if {[regexp -line \
9542 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9543 $err msg fname]} {
9544 error_popup [mc "Cherry-pick failed because of local changes\
9545 to file '%s'.\nPlease commit, reset or stash\
9546 your changes and try again." $fname]
9547 } elseif {[regexp -line \
9548 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9549 $err]} {
9550 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9551 conflict.\nDo you wish to run git citool to\
9552 resolve it?"]]} {
9553 # Force citool to read MERGE_MSG
9554 file delete [file join $gitdir "GITGUI_MSG"]
9555 exec_citool {} $rowmenuid
9556 }
9557 } else {
9558 error_popup $err
9559 }
9560 run updatecommits
9561 return
9562 }
9563 set newhead [exec git rev-parse HEAD]
9564 if {$newhead eq $oldhead} {
9565 notbusy cherrypick
9566 error_popup [mc "No changes committed"]
9567 return
9568 }
9569 addnewchild $newhead $oldhead
9570 if {[commitinview $oldhead $curview]} {
9571 # XXX this isn't right if we have a path limit...
9572 insertrow $newhead $oldhead $curview
9573 if {$mainhead ne {}} {
9574 movehead $newhead $mainhead
9575 movedhead $newhead $mainhead
9576 }
9577 set mainheadid $newhead
9578 redrawtags $oldhead
9579 redrawtags $newhead
9580 selbyid $newhead
9581 }
9582 notbusy cherrypick
9583}
9584
9585proc revert {} {
9586 global rowmenuid curview
9587 global mainhead mainheadid
9588 global gitdir
9589
9590 set oldhead [exec git rev-parse HEAD]
9591 set dheads [descheads $rowmenuid]
9592 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9593 set ok [confirm_popup [mc "Commit %s is not\
9594 included in branch %s -- really revert it?" \
9595 [string range $rowmenuid 0 7] $mainhead]]
9596 if {!$ok} return
9597 }
9598 nowbusy revert [mc "Reverting"]
9599 update
9600
9601 if [catch {exec git revert --no-edit $rowmenuid} err] {
9602 notbusy revert
9603 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9604 $err match files] {
9605 regsub {\n( |\t)+} $files "\n" files
9606 error_popup [mc "Revert failed because of local changes to\
9607 the following files:%s Please commit, reset or stash \
9608 your changes and try again." $files]
9609 } elseif [regexp {error: could not revert} $err] {
9610 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9611 Do you wish to run git citool to resolve it?"]] {
9612 # Force citool to read MERGE_MSG
9613 file delete [file join $gitdir "GITGUI_MSG"]
9614 exec_citool {} $rowmenuid
9615 }
9616 } else { error_popup $err }
9617 run updatecommits
9618 return
9619 }
9620
9621 set newhead [exec git rev-parse HEAD]
9622 if { $newhead eq $oldhead } {
9623 notbusy revert
9624 error_popup [mc "No changes committed"]
9625 return
9626 }
9627
9628 addnewchild $newhead $oldhead
9629
9630 if [commitinview $oldhead $curview] {
9631 # XXX this isn't right if we have a path limit...
9632 insertrow $newhead $oldhead $curview
9633 if {$mainhead ne {}} {
9634 movehead $newhead $mainhead
9635 movedhead $newhead $mainhead
9636 }
9637 set mainheadid $newhead
9638 redrawtags $oldhead
9639 redrawtags $newhead
9640 selbyid $newhead
9641 }
9642
9643 notbusy revert
9644}
9645
9646proc resethead {} {
9647 global mainhead rowmenuid confirm_ok resettype NS
9648
9649 set confirm_ok 0
9650 set w ".confirmreset"
9651 ttk_toplevel $w
9652 make_transient $w .
9653 wm title $w [mc "Confirm reset"]
9654 ${NS}::label $w.m -text \
9655 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9656 pack $w.m -side top -fill x -padx 20 -pady 20
9657 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9658 set resettype mixed
9659 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9660 -text [mc "Soft: Leave working tree and index untouched"]
9661 grid $w.f.soft -sticky w
9662 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9663 -text [mc "Mixed: Leave working tree untouched, reset index"]
9664 grid $w.f.mixed -sticky w
9665 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9666 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9667 grid $w.f.hard -sticky w
9668 pack $w.f -side top -fill x -padx 4
9669 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9670 pack $w.ok -side left -fill x -padx 20 -pady 20
9671 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9672 bind $w <Key-Escape> [list destroy $w]
9673 pack $w.cancel -side right -fill x -padx 20 -pady 20
9674 bind $w <Visibility> "grab $w; focus $w"
9675 tkwait window $w
9676 if {!$confirm_ok} return
9677 if {[catch {set fd [open \
9678 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9679 error_popup $err
9680 } else {
9681 dohidelocalchanges
9682 filerun $fd [list readresetstat $fd]
9683 nowbusy reset [mc "Resetting"]
9684 selbyid $rowmenuid
9685 }
9686}
9687
9688proc readresetstat {fd} {
9689 global mainhead mainheadid showlocalchanges rprogcoord
9690
9691 if {[gets $fd line] >= 0} {
9692 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9693 set rprogcoord [expr {1.0 * $m / $n}]
9694 adjustprogress
9695 }
9696 return 1
9697 }
9698 set rprogcoord 0
9699 adjustprogress
9700 notbusy reset
9701 if {[catch {close $fd} err]} {
9702 error_popup $err
9703 }
9704 set oldhead $mainheadid
9705 set newhead [exec git rev-parse HEAD]
9706 if {$newhead ne $oldhead} {
9707 movehead $newhead $mainhead
9708 movedhead $newhead $mainhead
9709 set mainheadid $newhead
9710 redrawtags $oldhead
9711 redrawtags $newhead
9712 }
9713 if {$showlocalchanges} {
9714 doshowlocalchanges
9715 }
9716 return 0
9717}
9718
9719# context menu for a head
9720proc headmenu {x y id head} {
9721 global headmenuid headmenuhead headctxmenu mainhead
9722
9723 stopfinding
9724 set headmenuid $id
9725 set headmenuhead $head
9726 set state normal
9727 if {[string match "remotes/*" $head]} {
9728 set state disabled
9729 }
9730 if {$head eq $mainhead} {
9731 set state disabled
9732 }
9733 $headctxmenu entryconfigure 0 -state $state
9734 $headctxmenu entryconfigure 1 -state $state
9735 tk_popup $headctxmenu $x $y
9736}
9737
9738proc cobranch {} {
9739 global headmenuid headmenuhead headids
9740 global showlocalchanges
9741
9742 # check the tree is clean first??
9743 nowbusy checkout [mc "Checking out"]
9744 update
9745 dohidelocalchanges
9746 if {[catch {
9747 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9748 } err]} {
9749 notbusy checkout
9750 error_popup $err
9751 if {$showlocalchanges} {
9752 dodiffindex
9753 }
9754 } else {
9755 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9756 }
9757}
9758
9759proc readcheckoutstat {fd newhead newheadid} {
9760 global mainhead mainheadid headids showlocalchanges progresscoords
9761 global viewmainheadid curview
9762
9763 if {[gets $fd line] >= 0} {
9764 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9765 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9766 adjustprogress
9767 }
9768 return 1
9769 }
9770 set progresscoords {0 0}
9771 adjustprogress
9772 notbusy checkout
9773 if {[catch {close $fd} err]} {
9774 error_popup $err
9775 }
9776 set oldmainid $mainheadid
9777 set mainhead $newhead
9778 set mainheadid $newheadid
9779 set viewmainheadid($curview) $newheadid
9780 redrawtags $oldmainid
9781 redrawtags $newheadid
9782 selbyid $newheadid
9783 if {$showlocalchanges} {
9784 dodiffindex
9785 }
9786}
9787
9788proc rmbranch {} {
9789 global headmenuid headmenuhead mainhead
9790 global idheads
9791
9792 set head $headmenuhead
9793 set id $headmenuid
9794 # this check shouldn't be needed any more...
9795 if {$head eq $mainhead} {
9796 error_popup [mc "Cannot delete the currently checked-out branch"]
9797 return
9798 }
9799 set dheads [descheads $id]
9800 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9801 # the stuff on this branch isn't on any other branch
9802 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9803 branch.\nReally delete branch %s?" $head $head]]} return
9804 }
9805 nowbusy rmbranch
9806 update
9807 if {[catch {exec git branch -D $head} err]} {
9808 notbusy rmbranch
9809 error_popup $err
9810 return
9811 }
9812 removehead $id $head
9813 removedhead $id $head
9814 redrawtags $id
9815 notbusy rmbranch
9816 dispneartags 0
9817 run refill_reflist
9818}
9819
9820# Display a list of tags and heads
9821proc showrefs {} {
9822 global showrefstop bgcolor fgcolor selectbgcolor NS
9823 global bglist fglist reflistfilter reflist maincursor
9824
9825 set top .showrefs
9826 set showrefstop $top
9827 if {[winfo exists $top]} {
9828 raise $top
9829 refill_reflist
9830 return
9831 }
9832 ttk_toplevel $top
9833 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9834 make_transient $top .
9835 text $top.list -background $bgcolor -foreground $fgcolor \
9836 -selectbackground $selectbgcolor -font mainfont \
9837 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9838 -width 30 -height 20 -cursor $maincursor \
9839 -spacing1 1 -spacing3 1 -state disabled
9840 $top.list tag configure highlight -background $selectbgcolor
9841 if {![lsearch -exact $bglist $top.list]} {
9842 lappend bglist $top.list
9843 lappend fglist $top.list
9844 }
9845 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9846 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9847 grid $top.list $top.ysb -sticky nsew
9848 grid $top.xsb x -sticky ew
9849 ${NS}::frame $top.f
9850 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9851 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9852 set reflistfilter "*"
9853 trace add variable reflistfilter write reflistfilter_change
9854 pack $top.f.e -side right -fill x -expand 1
9855 pack $top.f.l -side left
9856 grid $top.f - -sticky ew -pady 2
9857 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9858 bind $top <Key-Escape> [list destroy $top]
9859 grid $top.close -
9860 grid columnconfigure $top 0 -weight 1
9861 grid rowconfigure $top 0 -weight 1
9862 bind $top.list <1> {break}
9863 bind $top.list <B1-Motion> {break}
9864 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9865 set reflist {}
9866 refill_reflist
9867}
9868
9869proc sel_reflist {w x y} {
9870 global showrefstop reflist headids tagids otherrefids
9871
9872 if {![winfo exists $showrefstop]} return
9873 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9874 set ref [lindex $reflist [expr {$l-1}]]
9875 set n [lindex $ref 0]
9876 switch -- [lindex $ref 1] {
9877 "H" {selbyid $headids($n)}
9878 "T" {selbyid $tagids($n)}
9879 "o" {selbyid $otherrefids($n)}
9880 }
9881 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9882}
9883
9884proc unsel_reflist {} {
9885 global showrefstop
9886
9887 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9888 $showrefstop.list tag remove highlight 0.0 end
9889}
9890
9891proc reflistfilter_change {n1 n2 op} {
9892 global reflistfilter
9893
9894 after cancel refill_reflist
9895 after 200 refill_reflist
9896}
9897
9898proc refill_reflist {} {
9899 global reflist reflistfilter showrefstop headids tagids otherrefids
9900 global curview
9901
9902 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9903 set refs {}
9904 foreach n [array names headids] {
9905 if {[string match $reflistfilter $n]} {
9906 if {[commitinview $headids($n) $curview]} {
9907 lappend refs [list $n H]
9908 } else {
9909 interestedin $headids($n) {run refill_reflist}
9910 }
9911 }
9912 }
9913 foreach n [array names tagids] {
9914 if {[string match $reflistfilter $n]} {
9915 if {[commitinview $tagids($n) $curview]} {
9916 lappend refs [list $n T]
9917 } else {
9918 interestedin $tagids($n) {run refill_reflist}
9919 }
9920 }
9921 }
9922 foreach n [array names otherrefids] {
9923 if {[string match $reflistfilter $n]} {
9924 if {[commitinview $otherrefids($n) $curview]} {
9925 lappend refs [list $n o]
9926 } else {
9927 interestedin $otherrefids($n) {run refill_reflist}
9928 }
9929 }
9930 }
9931 set refs [lsort -index 0 $refs]
9932 if {$refs eq $reflist} return
9933
9934 # Update the contents of $showrefstop.list according to the
9935 # differences between $reflist (old) and $refs (new)
9936 $showrefstop.list conf -state normal
9937 $showrefstop.list insert end "\n"
9938 set i 0
9939 set j 0
9940 while {$i < [llength $reflist] || $j < [llength $refs]} {
9941 if {$i < [llength $reflist]} {
9942 if {$j < [llength $refs]} {
9943 set cmp [string compare [lindex $reflist $i 0] \
9944 [lindex $refs $j 0]]
9945 if {$cmp == 0} {
9946 set cmp [string compare [lindex $reflist $i 1] \
9947 [lindex $refs $j 1]]
9948 }
9949 } else {
9950 set cmp -1
9951 }
9952 } else {
9953 set cmp 1
9954 }
9955 switch -- $cmp {
9956 -1 {
9957 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9958 incr i
9959 }
9960 0 {
9961 incr i
9962 incr j
9963 }
9964 1 {
9965 set l [expr {$j + 1}]
9966 $showrefstop.list image create $l.0 -align baseline \
9967 -image reficon-[lindex $refs $j 1] -padx 2
9968 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9969 incr j
9970 }
9971 }
9972 }
9973 set reflist $refs
9974 # delete last newline
9975 $showrefstop.list delete end-2c end-1c
9976 $showrefstop.list conf -state disabled
9977}
9978
9979# Stuff for finding nearby tags
9980proc getallcommits {} {
9981 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9982 global idheads idtags idotherrefs allparents tagobjid
9983 global gitdir
9984
9985 if {![info exists allcommits]} {
9986 set nextarc 0
9987 set allcommits 0
9988 set seeds {}
9989 set allcwait 0
9990 set cachedarcs 0
9991 set allccache [file join $gitdir "gitk.cache"]
9992 if {![catch {
9993 set f [open $allccache r]
9994 set allcwait 1
9995 getcache $f
9996 }]} return
9997 }
9998
9999 if {$allcwait} {
10000 return
10001 }
10002 set cmd [list | git rev-list --parents]
10003 set allcupdate [expr {$seeds ne {}}]
10004 if {!$allcupdate} {
10005 set ids "--all"
10006 } else {
10007 set refs [concat [array names idheads] [array names idtags] \
10008 [array names idotherrefs]]
10009 set ids {}
10010 set tagobjs {}
10011 foreach name [array names tagobjid] {
10012 lappend tagobjs $tagobjid($name)
10013 }
10014 foreach id [lsort -unique $refs] {
10015 if {![info exists allparents($id)] &&
10016 [lsearch -exact $tagobjs $id] < 0} {
10017 lappend ids $id
10018 }
10019 }
10020 if {$ids ne {}} {
10021 foreach id $seeds {
10022 lappend ids "^$id"
10023 }
10024 }
10025 }
10026 if {$ids ne {}} {
10027 set fd [open [concat $cmd $ids] r]
10028 fconfigure $fd -blocking 0
10029 incr allcommits
10030 nowbusy allcommits
10031 filerun $fd [list getallclines $fd]
10032 } else {
10033 dispneartags 0
10034 }
10035}
10036
10037# Since most commits have 1 parent and 1 child, we group strings of
10038# such commits into "arcs" joining branch/merge points (BMPs), which
10039# are commits that either don't have 1 parent or don't have 1 child.
10040#
10041# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10042# arcout(id) - outgoing arcs for BMP
10043# arcids(a) - list of IDs on arc including end but not start
10044# arcstart(a) - BMP ID at start of arc
10045# arcend(a) - BMP ID at end of arc
10046# growing(a) - arc a is still growing
10047# arctags(a) - IDs out of arcids (excluding end) that have tags
10048# archeads(a) - IDs out of arcids (excluding end) that have heads
10049# The start of an arc is at the descendent end, so "incoming" means
10050# coming from descendents, and "outgoing" means going towards ancestors.
10051
10052proc getallclines {fd} {
10053 global allparents allchildren idtags idheads nextarc
10054 global arcnos arcids arctags arcout arcend arcstart archeads growing
10055 global seeds allcommits cachedarcs allcupdate
10056
10057 set nid 0
10058 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10059 set id [lindex $line 0]
10060 if {[info exists allparents($id)]} {
10061 # seen it already
10062 continue
10063 }
10064 set cachedarcs 0
10065 set olds [lrange $line 1 end]
10066 set allparents($id) $olds
10067 if {![info exists allchildren($id)]} {
10068 set allchildren($id) {}
10069 set arcnos($id) {}
10070 lappend seeds $id
10071 } else {
10072 set a $arcnos($id)
10073 if {[llength $olds] == 1 && [llength $a] == 1} {
10074 lappend arcids($a) $id
10075 if {[info exists idtags($id)]} {
10076 lappend arctags($a) $id
10077 }
10078 if {[info exists idheads($id)]} {
10079 lappend archeads($a) $id
10080 }
10081 if {[info exists allparents($olds)]} {
10082 # seen parent already
10083 if {![info exists arcout($olds)]} {
10084 splitarc $olds
10085 }
10086 lappend arcids($a) $olds
10087 set arcend($a) $olds
10088 unset growing($a)
10089 }
10090 lappend allchildren($olds) $id
10091 lappend arcnos($olds) $a
10092 continue
10093 }
10094 }
10095 foreach a $arcnos($id) {
10096 lappend arcids($a) $id
10097 set arcend($a) $id
10098 unset growing($a)
10099 }
10100
10101 set ao {}
10102 foreach p $olds {
10103 lappend allchildren($p) $id
10104 set a [incr nextarc]
10105 set arcstart($a) $id
10106 set archeads($a) {}
10107 set arctags($a) {}
10108 set archeads($a) {}
10109 set arcids($a) {}
10110 lappend ao $a
10111 set growing($a) 1
10112 if {[info exists allparents($p)]} {
10113 # seen it already, may need to make a new branch
10114 if {![info exists arcout($p)]} {
10115 splitarc $p
10116 }
10117 lappend arcids($a) $p
10118 set arcend($a) $p
10119 unset growing($a)
10120 }
10121 lappend arcnos($p) $a
10122 }
10123 set arcout($id) $ao
10124 }
10125 if {$nid > 0} {
10126 global cached_dheads cached_dtags cached_atags
10127 unset -nocomplain cached_dheads
10128 unset -nocomplain cached_dtags
10129 unset -nocomplain cached_atags
10130 }
10131 if {![eof $fd]} {
10132 return [expr {$nid >= 1000? 2: 1}]
10133 }
10134 set cacheok 1
10135 if {[catch {
10136 fconfigure $fd -blocking 1
10137 close $fd
10138 } err]} {
10139 # got an error reading the list of commits
10140 # if we were updating, try rereading the whole thing again
10141 if {$allcupdate} {
10142 incr allcommits -1
10143 dropcache $err
10144 return
10145 }
10146 error_popup "[mc "Error reading commit topology information;\
10147 branch and preceding/following tag information\
10148 will be incomplete."]\n($err)"
10149 set cacheok 0
10150 }
10151 if {[incr allcommits -1] == 0} {
10152 notbusy allcommits
10153 if {$cacheok} {
10154 run savecache
10155 }
10156 }
10157 dispneartags 0
10158 return 0
10159}
10160
10161proc recalcarc {a} {
10162 global arctags archeads arcids idtags idheads
10163
10164 set at {}
10165 set ah {}
10166 foreach id [lrange $arcids($a) 0 end-1] {
10167 if {[info exists idtags($id)]} {
10168 lappend at $id
10169 }
10170 if {[info exists idheads($id)]} {
10171 lappend ah $id
10172 }
10173 }
10174 set arctags($a) $at
10175 set archeads($a) $ah
10176}
10177
10178proc splitarc {p} {
10179 global arcnos arcids nextarc arctags archeads idtags idheads
10180 global arcstart arcend arcout allparents growing
10181
10182 set a $arcnos($p)
10183 if {[llength $a] != 1} {
10184 puts "oops splitarc called but [llength $a] arcs already"
10185 return
10186 }
10187 set a [lindex $a 0]
10188 set i [lsearch -exact $arcids($a) $p]
10189 if {$i < 0} {
10190 puts "oops splitarc $p not in arc $a"
10191 return
10192 }
10193 set na [incr nextarc]
10194 if {[info exists arcend($a)]} {
10195 set arcend($na) $arcend($a)
10196 } else {
10197 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10198 set j [lsearch -exact $arcnos($l) $a]
10199 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10200 }
10201 set tail [lrange $arcids($a) [expr {$i+1}] end]
10202 set arcids($a) [lrange $arcids($a) 0 $i]
10203 set arcend($a) $p
10204 set arcstart($na) $p
10205 set arcout($p) $na
10206 set arcids($na) $tail
10207 if {[info exists growing($a)]} {
10208 set growing($na) 1
10209 unset growing($a)
10210 }
10211
10212 foreach id $tail {
10213 if {[llength $arcnos($id)] == 1} {
10214 set arcnos($id) $na
10215 } else {
10216 set j [lsearch -exact $arcnos($id) $a]
10217 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10218 }
10219 }
10220
10221 # reconstruct tags and heads lists
10222 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10223 recalcarc $a
10224 recalcarc $na
10225 } else {
10226 set arctags($na) {}
10227 set archeads($na) {}
10228 }
10229}
10230
10231# Update things for a new commit added that is a child of one
10232# existing commit. Used when cherry-picking.
10233proc addnewchild {id p} {
10234 global allparents allchildren idtags nextarc
10235 global arcnos arcids arctags arcout arcend arcstart archeads growing
10236 global seeds allcommits
10237
10238 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10239 set allparents($id) [list $p]
10240 set allchildren($id) {}
10241 set arcnos($id) {}
10242 lappend seeds $id
10243 lappend allchildren($p) $id
10244 set a [incr nextarc]
10245 set arcstart($a) $id
10246 set archeads($a) {}
10247 set arctags($a) {}
10248 set arcids($a) [list $p]
10249 set arcend($a) $p
10250 if {![info exists arcout($p)]} {
10251 splitarc $p
10252 }
10253 lappend arcnos($p) $a
10254 set arcout($id) [list $a]
10255}
10256
10257# This implements a cache for the topology information.
10258# The cache saves, for each arc, the start and end of the arc,
10259# the ids on the arc, and the outgoing arcs from the end.
10260proc readcache {f} {
10261 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10262 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10263 global allcwait
10264
10265 set a $nextarc
10266 set lim $cachedarcs
10267 if {$lim - $a > 500} {
10268 set lim [expr {$a + 500}]
10269 }
10270 if {[catch {
10271 if {$a == $lim} {
10272 # finish reading the cache and setting up arctags, etc.
10273 set line [gets $f]
10274 if {$line ne "1"} {error "bad final version"}
10275 close $f
10276 foreach id [array names idtags] {
10277 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10278 [llength $allparents($id)] == 1} {
10279 set a [lindex $arcnos($id) 0]
10280 if {$arctags($a) eq {}} {
10281 recalcarc $a
10282 }
10283 }
10284 }
10285 foreach id [array names idheads] {
10286 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10287 [llength $allparents($id)] == 1} {
10288 set a [lindex $arcnos($id) 0]
10289 if {$archeads($a) eq {}} {
10290 recalcarc $a
10291 }
10292 }
10293 }
10294 foreach id [lsort -unique $possible_seeds] {
10295 if {$arcnos($id) eq {}} {
10296 lappend seeds $id
10297 }
10298 }
10299 set allcwait 0
10300 } else {
10301 while {[incr a] <= $lim} {
10302 set line [gets $f]
10303 if {[llength $line] != 3} {error "bad line"}
10304 set s [lindex $line 0]
10305 set arcstart($a) $s
10306 lappend arcout($s) $a
10307 if {![info exists arcnos($s)]} {
10308 lappend possible_seeds $s
10309 set arcnos($s) {}
10310 }
10311 set e [lindex $line 1]
10312 if {$e eq {}} {
10313 set growing($a) 1
10314 } else {
10315 set arcend($a) $e
10316 if {![info exists arcout($e)]} {
10317 set arcout($e) {}
10318 }
10319 }
10320 set arcids($a) [lindex $line 2]
10321 foreach id $arcids($a) {
10322 lappend allparents($s) $id
10323 set s $id
10324 lappend arcnos($id) $a
10325 }
10326 if {![info exists allparents($s)]} {
10327 set allparents($s) {}
10328 }
10329 set arctags($a) {}
10330 set archeads($a) {}
10331 }
10332 set nextarc [expr {$a - 1}]
10333 }
10334 } err]} {
10335 dropcache $err
10336 return 0
10337 }
10338 if {!$allcwait} {
10339 getallcommits
10340 }
10341 return $allcwait
10342}
10343
10344proc getcache {f} {
10345 global nextarc cachedarcs possible_seeds
10346
10347 if {[catch {
10348 set line [gets $f]
10349 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10350 # make sure it's an integer
10351 set cachedarcs [expr {int([lindex $line 1])}]
10352 if {$cachedarcs < 0} {error "bad number of arcs"}
10353 set nextarc 0
10354 set possible_seeds {}
10355 run readcache $f
10356 } err]} {
10357 dropcache $err
10358 }
10359 return 0
10360}
10361
10362proc dropcache {err} {
10363 global allcwait nextarc cachedarcs seeds
10364
10365 #puts "dropping cache ($err)"
10366 foreach v {arcnos arcout arcids arcstart arcend growing \
10367 arctags archeads allparents allchildren} {
10368 global $v
10369 unset -nocomplain $v
10370 }
10371 set allcwait 0
10372 set nextarc 0
10373 set cachedarcs 0
10374 set seeds {}
10375 getallcommits
10376}
10377
10378proc writecache {f} {
10379 global cachearc cachedarcs allccache
10380 global arcstart arcend arcnos arcids arcout
10381
10382 set a $cachearc
10383 set lim $cachedarcs
10384 if {$lim - $a > 1000} {
10385 set lim [expr {$a + 1000}]
10386 }
10387 if {[catch {
10388 while {[incr a] <= $lim} {
10389 if {[info exists arcend($a)]} {
10390 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10391 } else {
10392 puts $f [list $arcstart($a) {} $arcids($a)]
10393 }
10394 }
10395 } err]} {
10396 catch {close $f}
10397 catch {file delete $allccache}
10398 #puts "writing cache failed ($err)"
10399 return 0
10400 }
10401 set cachearc [expr {$a - 1}]
10402 if {$a > $cachedarcs} {
10403 puts $f "1"
10404 close $f
10405 return 0
10406 }
10407 return 1
10408}
10409
10410proc savecache {} {
10411 global nextarc cachedarcs cachearc allccache
10412
10413 if {$nextarc == $cachedarcs} return
10414 set cachearc 0
10415 set cachedarcs $nextarc
10416 catch {
10417 set f [open $allccache w]
10418 puts $f [list 1 $cachedarcs]
10419 run writecache $f
10420 }
10421}
10422
10423# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10424# or 0 if neither is true.
10425proc anc_or_desc {a b} {
10426 global arcout arcstart arcend arcnos cached_isanc
10427
10428 if {$arcnos($a) eq $arcnos($b)} {
10429 # Both are on the same arc(s); either both are the same BMP,
10430 # or if one is not a BMP, the other is also not a BMP or is
10431 # the BMP at end of the arc (and it only has 1 incoming arc).
10432 # Or both can be BMPs with no incoming arcs.
10433 if {$a eq $b || $arcnos($a) eq {}} {
10434 return 0
10435 }
10436 # assert {[llength $arcnos($a)] == 1}
10437 set arc [lindex $arcnos($a) 0]
10438 set i [lsearch -exact $arcids($arc) $a]
10439 set j [lsearch -exact $arcids($arc) $b]
10440 if {$i < 0 || $i > $j} {
10441 return 1
10442 } else {
10443 return -1
10444 }
10445 }
10446
10447 if {![info exists arcout($a)]} {
10448 set arc [lindex $arcnos($a) 0]
10449 if {[info exists arcend($arc)]} {
10450 set aend $arcend($arc)
10451 } else {
10452 set aend {}
10453 }
10454 set a $arcstart($arc)
10455 } else {
10456 set aend $a
10457 }
10458 if {![info exists arcout($b)]} {
10459 set arc [lindex $arcnos($b) 0]
10460 if {[info exists arcend($arc)]} {
10461 set bend $arcend($arc)
10462 } else {
10463 set bend {}
10464 }
10465 set b $arcstart($arc)
10466 } else {
10467 set bend $b
10468 }
10469 if {$a eq $bend} {
10470 return 1
10471 }
10472 if {$b eq $aend} {
10473 return -1
10474 }
10475 if {[info exists cached_isanc($a,$bend)]} {
10476 if {$cached_isanc($a,$bend)} {
10477 return 1
10478 }
10479 }
10480 if {[info exists cached_isanc($b,$aend)]} {
10481 if {$cached_isanc($b,$aend)} {
10482 return -1
10483 }
10484 if {[info exists cached_isanc($a,$bend)]} {
10485 return 0
10486 }
10487 }
10488
10489 set todo [list $a $b]
10490 set anc($a) a
10491 set anc($b) b
10492 for {set i 0} {$i < [llength $todo]} {incr i} {
10493 set x [lindex $todo $i]
10494 if {$anc($x) eq {}} {
10495 continue
10496 }
10497 foreach arc $arcnos($x) {
10498 set xd $arcstart($arc)
10499 if {$xd eq $bend} {
10500 set cached_isanc($a,$bend) 1
10501 set cached_isanc($b,$aend) 0
10502 return 1
10503 } elseif {$xd eq $aend} {
10504 set cached_isanc($b,$aend) 1
10505 set cached_isanc($a,$bend) 0
10506 return -1
10507 }
10508 if {![info exists anc($xd)]} {
10509 set anc($xd) $anc($x)
10510 lappend todo $xd
10511 } elseif {$anc($xd) ne $anc($x)} {
10512 set anc($xd) {}
10513 }
10514 }
10515 }
10516 set cached_isanc($a,$bend) 0
10517 set cached_isanc($b,$aend) 0
10518 return 0
10519}
10520
10521# This identifies whether $desc has an ancestor that is
10522# a growing tip of the graph and which is not an ancestor of $anc
10523# and returns 0 if so and 1 if not.
10524# If we subsequently discover a tag on such a growing tip, and that
10525# turns out to be a descendent of $anc (which it could, since we
10526# don't necessarily see children before parents), then $desc
10527# isn't a good choice to display as a descendent tag of
10528# $anc (since it is the descendent of another tag which is
10529# a descendent of $anc). Similarly, $anc isn't a good choice to
10530# display as a ancestor tag of $desc.
10531#
10532proc is_certain {desc anc} {
10533 global arcnos arcout arcstart arcend growing problems
10534
10535 set certain {}
10536 if {[llength $arcnos($anc)] == 1} {
10537 # tags on the same arc are certain
10538 if {$arcnos($desc) eq $arcnos($anc)} {
10539 return 1
10540 }
10541 if {![info exists arcout($anc)]} {
10542 # if $anc is partway along an arc, use the start of the arc instead
10543 set a [lindex $arcnos($anc) 0]
10544 set anc $arcstart($a)
10545 }
10546 }
10547 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10548 set x $desc
10549 } else {
10550 set a [lindex $arcnos($desc) 0]
10551 set x $arcend($a)
10552 }
10553 if {$x == $anc} {
10554 return 1
10555 }
10556 set anclist [list $x]
10557 set dl($x) 1
10558 set nnh 1
10559 set ngrowanc 0
10560 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10561 set x [lindex $anclist $i]
10562 if {$dl($x)} {
10563 incr nnh -1
10564 }
10565 set done($x) 1
10566 foreach a $arcout($x) {
10567 if {[info exists growing($a)]} {
10568 if {![info exists growanc($x)] && $dl($x)} {
10569 set growanc($x) 1
10570 incr ngrowanc
10571 }
10572 } else {
10573 set y $arcend($a)
10574 if {[info exists dl($y)]} {
10575 if {$dl($y)} {
10576 if {!$dl($x)} {
10577 set dl($y) 0
10578 if {![info exists done($y)]} {
10579 incr nnh -1
10580 }
10581 if {[info exists growanc($x)]} {
10582 incr ngrowanc -1
10583 }
10584 set xl [list $y]
10585 for {set k 0} {$k < [llength $xl]} {incr k} {
10586 set z [lindex $xl $k]
10587 foreach c $arcout($z) {
10588 if {[info exists arcend($c)]} {
10589 set v $arcend($c)
10590 if {[info exists dl($v)] && $dl($v)} {
10591 set dl($v) 0
10592 if {![info exists done($v)]} {
10593 incr nnh -1
10594 }
10595 if {[info exists growanc($v)]} {
10596 incr ngrowanc -1
10597 }
10598 lappend xl $v
10599 }
10600 }
10601 }
10602 }
10603 }
10604 }
10605 } elseif {$y eq $anc || !$dl($x)} {
10606 set dl($y) 0
10607 lappend anclist $y
10608 } else {
10609 set dl($y) 1
10610 lappend anclist $y
10611 incr nnh
10612 }
10613 }
10614 }
10615 }
10616 foreach x [array names growanc] {
10617 if {$dl($x)} {
10618 return 0
10619 }
10620 return 0
10621 }
10622 return 1
10623}
10624
10625proc validate_arctags {a} {
10626 global arctags idtags
10627
10628 set i -1
10629 set na $arctags($a)
10630 foreach id $arctags($a) {
10631 incr i
10632 if {![info exists idtags($id)]} {
10633 set na [lreplace $na $i $i]
10634 incr i -1
10635 }
10636 }
10637 set arctags($a) $na
10638}
10639
10640proc validate_archeads {a} {
10641 global archeads idheads
10642
10643 set i -1
10644 set na $archeads($a)
10645 foreach id $archeads($a) {
10646 incr i
10647 if {![info exists idheads($id)]} {
10648 set na [lreplace $na $i $i]
10649 incr i -1
10650 }
10651 }
10652 set archeads($a) $na
10653}
10654
10655# Return the list of IDs that have tags that are descendents of id,
10656# ignoring IDs that are descendents of IDs already reported.
10657proc desctags {id} {
10658 global arcnos arcstart arcids arctags idtags allparents
10659 global growing cached_dtags
10660
10661 if {![info exists allparents($id)]} {
10662 return {}
10663 }
10664 set t1 [clock clicks -milliseconds]
10665 set argid $id
10666 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10667 # part-way along an arc; check that arc first
10668 set a [lindex $arcnos($id) 0]
10669 if {$arctags($a) ne {}} {
10670 validate_arctags $a
10671 set i [lsearch -exact $arcids($a) $id]
10672 set tid {}
10673 foreach t $arctags($a) {
10674 set j [lsearch -exact $arcids($a) $t]
10675 if {$j >= $i} break
10676 set tid $t
10677 }
10678 if {$tid ne {}} {
10679 return $tid
10680 }
10681 }
10682 set id $arcstart($a)
10683 if {[info exists idtags($id)]} {
10684 return $id
10685 }
10686 }
10687 if {[info exists cached_dtags($id)]} {
10688 return $cached_dtags($id)
10689 }
10690
10691 set origid $id
10692 set todo [list $id]
10693 set queued($id) 1
10694 set nc 1
10695 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10696 set id [lindex $todo $i]
10697 set done($id) 1
10698 set ta [info exists hastaggedancestor($id)]
10699 if {!$ta} {
10700 incr nc -1
10701 }
10702 # ignore tags on starting node
10703 if {!$ta && $i > 0} {
10704 if {[info exists idtags($id)]} {
10705 set tagloc($id) $id
10706 set ta 1
10707 } elseif {[info exists cached_dtags($id)]} {
10708 set tagloc($id) $cached_dtags($id)
10709 set ta 1
10710 }
10711 }
10712 foreach a $arcnos($id) {
10713 set d $arcstart($a)
10714 if {!$ta && $arctags($a) ne {}} {
10715 validate_arctags $a
10716 if {$arctags($a) ne {}} {
10717 lappend tagloc($id) [lindex $arctags($a) end]
10718 }
10719 }
10720 if {$ta || $arctags($a) ne {}} {
10721 set tomark [list $d]
10722 for {set j 0} {$j < [llength $tomark]} {incr j} {
10723 set dd [lindex $tomark $j]
10724 if {![info exists hastaggedancestor($dd)]} {
10725 if {[info exists done($dd)]} {
10726 foreach b $arcnos($dd) {
10727 lappend tomark $arcstart($b)
10728 }
10729 if {[info exists tagloc($dd)]} {
10730 unset tagloc($dd)
10731 }
10732 } elseif {[info exists queued($dd)]} {
10733 incr nc -1
10734 }
10735 set hastaggedancestor($dd) 1
10736 }
10737 }
10738 }
10739 if {![info exists queued($d)]} {
10740 lappend todo $d
10741 set queued($d) 1
10742 if {![info exists hastaggedancestor($d)]} {
10743 incr nc
10744 }
10745 }
10746 }
10747 }
10748 set tags {}
10749 foreach id [array names tagloc] {
10750 if {![info exists hastaggedancestor($id)]} {
10751 foreach t $tagloc($id) {
10752 if {[lsearch -exact $tags $t] < 0} {
10753 lappend tags $t
10754 }
10755 }
10756 }
10757 }
10758 set t2 [clock clicks -milliseconds]
10759 set loopix $i
10760
10761 # remove tags that are descendents of other tags
10762 for {set i 0} {$i < [llength $tags]} {incr i} {
10763 set a [lindex $tags $i]
10764 for {set j 0} {$j < $i} {incr j} {
10765 set b [lindex $tags $j]
10766 set r [anc_or_desc $a $b]
10767 if {$r == 1} {
10768 set tags [lreplace $tags $j $j]
10769 incr j -1
10770 incr i -1
10771 } elseif {$r == -1} {
10772 set tags [lreplace $tags $i $i]
10773 incr i -1
10774 break
10775 }
10776 }
10777 }
10778
10779 if {[array names growing] ne {}} {
10780 # graph isn't finished, need to check if any tag could get
10781 # eclipsed by another tag coming later. Simply ignore any
10782 # tags that could later get eclipsed.
10783 set ctags {}
10784 foreach t $tags {
10785 if {[is_certain $t $origid]} {
10786 lappend ctags $t
10787 }
10788 }
10789 if {$tags eq $ctags} {
10790 set cached_dtags($origid) $tags
10791 } else {
10792 set tags $ctags
10793 }
10794 } else {
10795 set cached_dtags($origid) $tags
10796 }
10797 set t3 [clock clicks -milliseconds]
10798 if {0 && $t3 - $t1 >= 100} {
10799 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10800 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10801 }
10802 return $tags
10803}
10804
10805proc anctags {id} {
10806 global arcnos arcids arcout arcend arctags idtags allparents
10807 global growing cached_atags
10808
10809 if {![info exists allparents($id)]} {
10810 return {}
10811 }
10812 set t1 [clock clicks -milliseconds]
10813 set argid $id
10814 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10815 # part-way along an arc; check that arc first
10816 set a [lindex $arcnos($id) 0]
10817 if {$arctags($a) ne {}} {
10818 validate_arctags $a
10819 set i [lsearch -exact $arcids($a) $id]
10820 foreach t $arctags($a) {
10821 set j [lsearch -exact $arcids($a) $t]
10822 if {$j > $i} {
10823 return $t
10824 }
10825 }
10826 }
10827 if {![info exists arcend($a)]} {
10828 return {}
10829 }
10830 set id $arcend($a)
10831 if {[info exists idtags($id)]} {
10832 return $id
10833 }
10834 }
10835 if {[info exists cached_atags($id)]} {
10836 return $cached_atags($id)
10837 }
10838
10839 set origid $id
10840 set todo [list $id]
10841 set queued($id) 1
10842 set taglist {}
10843 set nc 1
10844 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10845 set id [lindex $todo $i]
10846 set done($id) 1
10847 set td [info exists hastaggeddescendent($id)]
10848 if {!$td} {
10849 incr nc -1
10850 }
10851 # ignore tags on starting node
10852 if {!$td && $i > 0} {
10853 if {[info exists idtags($id)]} {
10854 set tagloc($id) $id
10855 set td 1
10856 } elseif {[info exists cached_atags($id)]} {
10857 set tagloc($id) $cached_atags($id)
10858 set td 1
10859 }
10860 }
10861 foreach a $arcout($id) {
10862 if {!$td && $arctags($a) ne {}} {
10863 validate_arctags $a
10864 if {$arctags($a) ne {}} {
10865 lappend tagloc($id) [lindex $arctags($a) 0]
10866 }
10867 }
10868 if {![info exists arcend($a)]} continue
10869 set d $arcend($a)
10870 if {$td || $arctags($a) ne {}} {
10871 set tomark [list $d]
10872 for {set j 0} {$j < [llength $tomark]} {incr j} {
10873 set dd [lindex $tomark $j]
10874 if {![info exists hastaggeddescendent($dd)]} {
10875 if {[info exists done($dd)]} {
10876 foreach b $arcout($dd) {
10877 if {[info exists arcend($b)]} {
10878 lappend tomark $arcend($b)
10879 }
10880 }
10881 if {[info exists tagloc($dd)]} {
10882 unset tagloc($dd)
10883 }
10884 } elseif {[info exists queued($dd)]} {
10885 incr nc -1
10886 }
10887 set hastaggeddescendent($dd) 1
10888 }
10889 }
10890 }
10891 if {![info exists queued($d)]} {
10892 lappend todo $d
10893 set queued($d) 1
10894 if {![info exists hastaggeddescendent($d)]} {
10895 incr nc
10896 }
10897 }
10898 }
10899 }
10900 set t2 [clock clicks -milliseconds]
10901 set loopix $i
10902 set tags {}
10903 foreach id [array names tagloc] {
10904 if {![info exists hastaggeddescendent($id)]} {
10905 foreach t $tagloc($id) {
10906 if {[lsearch -exact $tags $t] < 0} {
10907 lappend tags $t
10908 }
10909 }
10910 }
10911 }
10912
10913 # remove tags that are ancestors of other tags
10914 for {set i 0} {$i < [llength $tags]} {incr i} {
10915 set a [lindex $tags $i]
10916 for {set j 0} {$j < $i} {incr j} {
10917 set b [lindex $tags $j]
10918 set r [anc_or_desc $a $b]
10919 if {$r == -1} {
10920 set tags [lreplace $tags $j $j]
10921 incr j -1
10922 incr i -1
10923 } elseif {$r == 1} {
10924 set tags [lreplace $tags $i $i]
10925 incr i -1
10926 break
10927 }
10928 }
10929 }
10930
10931 if {[array names growing] ne {}} {
10932 # graph isn't finished, need to check if any tag could get
10933 # eclipsed by another tag coming later. Simply ignore any
10934 # tags that could later get eclipsed.
10935 set ctags {}
10936 foreach t $tags {
10937 if {[is_certain $origid $t]} {
10938 lappend ctags $t
10939 }
10940 }
10941 if {$tags eq $ctags} {
10942 set cached_atags($origid) $tags
10943 } else {
10944 set tags $ctags
10945 }
10946 } else {
10947 set cached_atags($origid) $tags
10948 }
10949 set t3 [clock clicks -milliseconds]
10950 if {0 && $t3 - $t1 >= 100} {
10951 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10952 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10953 }
10954 return $tags
10955}
10956
10957# Return the list of IDs that have heads that are descendents of id,
10958# including id itself if it has a head.
10959proc descheads {id} {
10960 global arcnos arcstart arcids archeads idheads cached_dheads
10961 global allparents arcout
10962
10963 if {![info exists allparents($id)]} {
10964 return {}
10965 }
10966 set aret {}
10967 if {![info exists arcout($id)]} {
10968 # part-way along an arc; check it first
10969 set a [lindex $arcnos($id) 0]
10970 if {$archeads($a) ne {}} {
10971 validate_archeads $a
10972 set i [lsearch -exact $arcids($a) $id]
10973 foreach t $archeads($a) {
10974 set j [lsearch -exact $arcids($a) $t]
10975 if {$j > $i} break
10976 lappend aret $t
10977 }
10978 }
10979 set id $arcstart($a)
10980 }
10981 set origid $id
10982 set todo [list $id]
10983 set seen($id) 1
10984 set ret {}
10985 for {set i 0} {$i < [llength $todo]} {incr i} {
10986 set id [lindex $todo $i]
10987 if {[info exists cached_dheads($id)]} {
10988 set ret [concat $ret $cached_dheads($id)]
10989 } else {
10990 if {[info exists idheads($id)]} {
10991 lappend ret $id
10992 }
10993 foreach a $arcnos($id) {
10994 if {$archeads($a) ne {}} {
10995 validate_archeads $a
10996 if {$archeads($a) ne {}} {
10997 set ret [concat $ret $archeads($a)]
10998 }
10999 }
11000 set d $arcstart($a)
11001 if {![info exists seen($d)]} {
11002 lappend todo $d
11003 set seen($d) 1
11004 }
11005 }
11006 }
11007 }
11008 set ret [lsort -unique $ret]
11009 set cached_dheads($origid) $ret
11010 return [concat $ret $aret]
11011}
11012
11013proc addedtag {id} {
11014 global arcnos arcout cached_dtags cached_atags
11015
11016 if {![info exists arcnos($id)]} return
11017 if {![info exists arcout($id)]} {
11018 recalcarc [lindex $arcnos($id) 0]
11019 }
11020 unset -nocomplain cached_dtags
11021 unset -nocomplain cached_atags
11022}
11023
11024proc addedhead {hid head} {
11025 global arcnos arcout cached_dheads
11026
11027 if {![info exists arcnos($hid)]} return
11028 if {![info exists arcout($hid)]} {
11029 recalcarc [lindex $arcnos($hid) 0]
11030 }
11031 unset -nocomplain cached_dheads
11032}
11033
11034proc removedhead {hid head} {
11035 global cached_dheads
11036
11037 unset -nocomplain cached_dheads
11038}
11039
11040proc movedhead {hid head} {
11041 global arcnos arcout cached_dheads
11042
11043 if {![info exists arcnos($hid)]} return
11044 if {![info exists arcout($hid)]} {
11045 recalcarc [lindex $arcnos($hid) 0]
11046 }
11047 unset -nocomplain cached_dheads
11048}
11049
11050proc changedrefs {} {
11051 global cached_dheads cached_dtags cached_atags cached_tagcontent
11052 global arctags archeads arcnos arcout idheads idtags
11053
11054 foreach id [concat [array names idheads] [array names idtags]] {
11055 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11056 set a [lindex $arcnos($id) 0]
11057 if {![info exists donearc($a)]} {
11058 recalcarc $a
11059 set donearc($a) 1
11060 }
11061 }
11062 }
11063 unset -nocomplain cached_tagcontent
11064 unset -nocomplain cached_dtags
11065 unset -nocomplain cached_atags
11066 unset -nocomplain cached_dheads
11067}
11068
11069proc rereadrefs {} {
11070 global idtags idheads idotherrefs mainheadid
11071
11072 set refids [concat [array names idtags] \
11073 [array names idheads] [array names idotherrefs]]
11074 foreach id $refids {
11075 if {![info exists ref($id)]} {
11076 set ref($id) [listrefs $id]
11077 }
11078 }
11079 set oldmainhead $mainheadid
11080 readrefs
11081 changedrefs
11082 set refids [lsort -unique [concat $refids [array names idtags] \
11083 [array names idheads] [array names idotherrefs]]]
11084 foreach id $refids {
11085 set v [listrefs $id]
11086 if {![info exists ref($id)] || $ref($id) != $v} {
11087 redrawtags $id
11088 }
11089 }
11090 if {$oldmainhead ne $mainheadid} {
11091 redrawtags $oldmainhead
11092 redrawtags $mainheadid
11093 }
11094 run refill_reflist
11095}
11096
11097proc listrefs {id} {
11098 global idtags idheads idotherrefs
11099
11100 set x {}
11101 if {[info exists idtags($id)]} {
11102 set x $idtags($id)
11103 }
11104 set y {}
11105 if {[info exists idheads($id)]} {
11106 set y $idheads($id)
11107 }
11108 set z {}
11109 if {[info exists idotherrefs($id)]} {
11110 set z $idotherrefs($id)
11111 }
11112 return [list $x $y $z]
11113}
11114
11115proc add_tag_ctext {tag} {
11116 global ctext cached_tagcontent tagids
11117
11118 if {![info exists cached_tagcontent($tag)]} {
11119 catch {
11120 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11121 }
11122 }
11123 $ctext insert end "[mc "Tag"]: $tag\n" bold
11124 if {[info exists cached_tagcontent($tag)]} {
11125 set text $cached_tagcontent($tag)
11126 } else {
11127 set text "[mc "Id"]: $tagids($tag)"
11128 }
11129 appendwithlinks $text {}
11130}
11131
11132proc showtag {tag isnew} {
11133 global ctext cached_tagcontent tagids linknum tagobjid
11134
11135 if {$isnew} {
11136 addtohistory [list showtag $tag 0] savectextpos
11137 }
11138 $ctext conf -state normal
11139 clear_ctext
11140 settabs 0
11141 set linknum 0
11142 add_tag_ctext $tag
11143 maybe_scroll_ctext 1
11144 $ctext conf -state disabled
11145 init_flist {}
11146}
11147
11148proc showtags {id isnew} {
11149 global idtags ctext linknum
11150
11151 if {$isnew} {
11152 addtohistory [list showtags $id 0] savectextpos
11153 }
11154 $ctext conf -state normal
11155 clear_ctext
11156 settabs 0
11157 set linknum 0
11158 set sep {}
11159 foreach tag $idtags($id) {
11160 $ctext insert end $sep
11161 add_tag_ctext $tag
11162 set sep "\n\n"
11163 }
11164 maybe_scroll_ctext 1
11165 $ctext conf -state disabled
11166 init_flist {}
11167}
11168
11169proc doquit {} {
11170 global stopped
11171 global gitktmpdir
11172
11173 set stopped 100
11174 savestuff .
11175 destroy .
11176
11177 if {[info exists gitktmpdir]} {
11178 catch {file delete -force $gitktmpdir}
11179 }
11180}
11181
11182proc mkfontdisp {font top which} {
11183 global fontattr fontpref $font NS use_ttk
11184
11185 set fontpref($font) [set $font]
11186 ${NS}::button $top.${font}but -text $which \
11187 -command [list choosefont $font $which]
11188 ${NS}::label $top.$font -relief flat -font $font \
11189 -text $fontattr($font,family) -justify left
11190 grid x $top.${font}but $top.$font -sticky w
11191}
11192
11193proc choosefont {font which} {
11194 global fontparam fontlist fonttop fontattr
11195 global prefstop NS
11196
11197 set fontparam(which) $which
11198 set fontparam(font) $font
11199 set fontparam(family) [font actual $font -family]
11200 set fontparam(size) $fontattr($font,size)
11201 set fontparam(weight) $fontattr($font,weight)
11202 set fontparam(slant) $fontattr($font,slant)
11203 set top .gitkfont
11204 set fonttop $top
11205 if {![winfo exists $top]} {
11206 font create sample
11207 eval font config sample [font actual $font]
11208 ttk_toplevel $top
11209 make_transient $top $prefstop
11210 wm title $top [mc "Gitk font chooser"]
11211 ${NS}::label $top.l -textvariable fontparam(which)
11212 pack $top.l -side top
11213 set fontlist [lsort [font families]]
11214 ${NS}::frame $top.f
11215 listbox $top.f.fam -listvariable fontlist \
11216 -yscrollcommand [list $top.f.sb set]
11217 bind $top.f.fam <<ListboxSelect>> selfontfam
11218 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11219 pack $top.f.sb -side right -fill y
11220 pack $top.f.fam -side left -fill both -expand 1
11221 pack $top.f -side top -fill both -expand 1
11222 ${NS}::frame $top.g
11223 spinbox $top.g.size -from 4 -to 40 -width 4 \
11224 -textvariable fontparam(size) \
11225 -validatecommand {string is integer -strict %s}
11226 checkbutton $top.g.bold -padx 5 \
11227 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11228 -variable fontparam(weight) -onvalue bold -offvalue normal
11229 checkbutton $top.g.ital -padx 5 \
11230 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11231 -variable fontparam(slant) -onvalue italic -offvalue roman
11232 pack $top.g.size $top.g.bold $top.g.ital -side left
11233 pack $top.g -side top
11234 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11235 -background white
11236 $top.c create text 100 25 -anchor center -text $which -font sample \
11237 -fill black -tags text
11238 bind $top.c <Configure> [list centertext $top.c]
11239 pack $top.c -side top -fill x
11240 ${NS}::frame $top.buts
11241 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11242 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11243 bind $top <Key-Return> fontok
11244 bind $top <Key-Escape> fontcan
11245 grid $top.buts.ok $top.buts.can
11246 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11247 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11248 pack $top.buts -side bottom -fill x
11249 trace add variable fontparam write chg_fontparam
11250 } else {
11251 raise $top
11252 $top.c itemconf text -text $which
11253 }
11254 set i [lsearch -exact $fontlist $fontparam(family)]
11255 if {$i >= 0} {
11256 $top.f.fam selection set $i
11257 $top.f.fam see $i
11258 }
11259}
11260
11261proc centertext {w} {
11262 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11263}
11264
11265proc fontok {} {
11266 global fontparam fontpref prefstop
11267
11268 set f $fontparam(font)
11269 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11270 if {$fontparam(weight) eq "bold"} {
11271 lappend fontpref($f) "bold"
11272 }
11273 if {$fontparam(slant) eq "italic"} {
11274 lappend fontpref($f) "italic"
11275 }
11276 set w $prefstop.notebook.fonts.$f
11277 $w conf -text $fontparam(family) -font $fontpref($f)
11278
11279 fontcan
11280}
11281
11282proc fontcan {} {
11283 global fonttop fontparam
11284
11285 if {[info exists fonttop]} {
11286 catch {destroy $fonttop}
11287 catch {font delete sample}
11288 unset fonttop
11289 unset fontparam
11290 }
11291}
11292
11293if {[package vsatisfies [package provide Tk] 8.6]} {
11294 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11295 # function to make use of it.
11296 proc choosefont {font which} {
11297 tk fontchooser configure -title $which -font $font \
11298 -command [list on_choosefont $font $which]
11299 tk fontchooser show
11300 }
11301 proc on_choosefont {font which newfont} {
11302 global fontparam
11303 puts stderr "$font $newfont"
11304 array set f [font actual $newfont]
11305 set fontparam(which) $which
11306 set fontparam(font) $font
11307 set fontparam(family) $f(-family)
11308 set fontparam(size) $f(-size)
11309 set fontparam(weight) $f(-weight)
11310 set fontparam(slant) $f(-slant)
11311 fontok
11312 }
11313}
11314
11315proc selfontfam {} {
11316 global fonttop fontparam
11317
11318 set i [$fonttop.f.fam curselection]
11319 if {$i ne {}} {
11320 set fontparam(family) [$fonttop.f.fam get $i]
11321 }
11322}
11323
11324proc chg_fontparam {v sub op} {
11325 global fontparam
11326
11327 font config sample -$sub $fontparam($sub)
11328}
11329
11330# Create a property sheet tab page
11331proc create_prefs_page {w} {
11332 global NS
11333 set parent [join [lrange [split $w .] 0 end-1] .]
11334 if {[winfo class $parent] eq "TNotebook"} {
11335 ${NS}::frame $w
11336 } else {
11337 ${NS}::labelframe $w
11338 }
11339}
11340
11341proc prefspage_general {notebook} {
11342 global NS maxwidth maxgraphpct showneartags showlocalchanges
11343 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11344 global hideremotes want_ttk have_ttk maxrefs
11345
11346 set page [create_prefs_page $notebook.general]
11347
11348 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11349 grid $page.ldisp - -sticky w -pady 10
11350 ${NS}::label $page.spacer -text " "
11351 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11352 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11353 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11354 #xgettext:no-tcl-format
11355 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11356 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11357 grid x $page.maxpctl $page.maxpct -sticky w
11358 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11359 -variable showlocalchanges
11360 grid x $page.showlocal -sticky w
11361 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11362 -variable autoselect
11363 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11364 grid x $page.autoselect $page.autosellen -sticky w
11365 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11366 -variable hideremotes
11367 grid x $page.hideremotes -sticky w
11368
11369 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11370 grid $page.ddisp - -sticky w -pady 10
11371 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11372 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11373 grid x $page.tabstopl $page.tabstop -sticky w
11374 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11375 -variable showneartags
11376 grid x $page.ntag -sticky w
11377 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11378 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11379 grid x $page.maxrefsl $page.maxrefs -sticky w
11380 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11381 -variable limitdiffs
11382 grid x $page.ldiff -sticky w
11383 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11384 -variable perfile_attrs
11385 grid x $page.lattr -sticky w
11386
11387 ${NS}::entry $page.extdifft -textvariable extdifftool
11388 ${NS}::frame $page.extdifff
11389 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11390 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11391 pack $page.extdifff.l $page.extdifff.b -side left
11392 pack configure $page.extdifff.l -padx 10
11393 grid x $page.extdifff $page.extdifft -sticky ew
11394
11395 ${NS}::label $page.lgen -text [mc "General options"]
11396 grid $page.lgen - -sticky w -pady 10
11397 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11398 -text [mc "Use themed widgets"]
11399 if {$have_ttk} {
11400 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11401 } else {
11402 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11403 }
11404 grid x $page.want_ttk $page.ttk_note -sticky w
11405 return $page
11406}
11407
11408proc prefspage_colors {notebook} {
11409 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11410
11411 set page [create_prefs_page $notebook.colors]
11412
11413 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11414 grid $page.cdisp - -sticky w -pady 10
11415 label $page.ui -padx 40 -relief sunk -background $uicolor
11416 ${NS}::button $page.uibut -text [mc "Interface"] \
11417 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11418 grid x $page.uibut $page.ui -sticky w
11419 label $page.bg -padx 40 -relief sunk -background $bgcolor
11420 ${NS}::button $page.bgbut -text [mc "Background"] \
11421 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11422 grid x $page.bgbut $page.bg -sticky w
11423 label $page.fg -padx 40 -relief sunk -background $fgcolor
11424 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11425 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11426 grid x $page.fgbut $page.fg -sticky w
11427 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11428 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11429 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11430 [list $ctext tag conf d0 -foreground]]
11431 grid x $page.diffoldbut $page.diffold -sticky w
11432 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11433 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11434 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11435 [list $ctext tag conf dresult -foreground]]
11436 grid x $page.diffnewbut $page.diffnew -sticky w
11437 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11438 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11439 -command [list choosecolor diffcolors 2 $page.hunksep \
11440 [mc "diff hunk header"] \
11441 [list $ctext tag conf hunksep -foreground]]
11442 grid x $page.hunksepbut $page.hunksep -sticky w
11443 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11444 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11445 -command [list choosecolor markbgcolor {} $page.markbgsep \
11446 [mc "marked line background"] \
11447 [list $ctext tag conf omark -background]]
11448 grid x $page.markbgbut $page.markbgsep -sticky w
11449 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11450 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11451 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11452 grid x $page.selbgbut $page.selbgsep -sticky w
11453 return $page
11454}
11455
11456proc prefspage_fonts {notebook} {
11457 global NS
11458 set page [create_prefs_page $notebook.fonts]
11459 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11460 grid $page.cfont - -sticky w -pady 10
11461 mkfontdisp mainfont $page [mc "Main font"]
11462 mkfontdisp textfont $page [mc "Diff display font"]
11463 mkfontdisp uifont $page [mc "User interface font"]
11464 return $page
11465}
11466
11467proc doprefs {} {
11468 global maxwidth maxgraphpct use_ttk NS
11469 global oldprefs prefstop showneartags showlocalchanges
11470 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11471 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11472 global hideremotes want_ttk have_ttk
11473
11474 set top .gitkprefs
11475 set prefstop $top
11476 if {[winfo exists $top]} {
11477 raise $top
11478 return
11479 }
11480 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11481 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11482 set oldprefs($v) [set $v]
11483 }
11484 ttk_toplevel $top
11485 wm title $top [mc "Gitk preferences"]
11486 make_transient $top .
11487
11488 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11489 set notebook [ttk::notebook $top.notebook]
11490 } else {
11491 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11492 }
11493
11494 lappend pages [prefspage_general $notebook] [mc "General"]
11495 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11496 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11497 set col 0
11498 foreach {page title} $pages {
11499 if {$use_notebook} {
11500 $notebook add $page -text $title
11501 } else {
11502 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11503 -text $title -command [list raise $page]]
11504 $page configure -text $title
11505 grid $btn -row 0 -column [incr col] -sticky w
11506 grid $page -row 1 -column 0 -sticky news -columnspan 100
11507 }
11508 }
11509
11510 if {!$use_notebook} {
11511 grid columnconfigure $notebook 0 -weight 1
11512 grid rowconfigure $notebook 1 -weight 1
11513 raise [lindex $pages 0]
11514 }
11515
11516 grid $notebook -sticky news -padx 2 -pady 2
11517 grid rowconfigure $top 0 -weight 1
11518 grid columnconfigure $top 0 -weight 1
11519
11520 ${NS}::frame $top.buts
11521 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11522 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11523 bind $top <Key-Return> prefsok
11524 bind $top <Key-Escape> prefscan
11525 grid $top.buts.ok $top.buts.can
11526 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11527 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11528 grid $top.buts - - -pady 10 -sticky ew
11529 grid columnconfigure $top 2 -weight 1
11530 bind $top <Visibility> [list focus $top.buts.ok]
11531}
11532
11533proc choose_extdiff {} {
11534 global extdifftool
11535
11536 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11537 if {$prog ne {}} {
11538 set extdifftool $prog
11539 }
11540}
11541
11542proc choosecolor {v vi w x cmd} {
11543 global $v
11544
11545 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11546 -title [mc "Gitk: choose color for %s" $x]]
11547 if {$c eq {}} return
11548 $w conf -background $c
11549 lset $v $vi $c
11550 eval $cmd $c
11551}
11552
11553proc setselbg {c} {
11554 global bglist cflist
11555 foreach w $bglist {
11556 if {[winfo exists $w]} {
11557 $w configure -selectbackground $c
11558 }
11559 }
11560 $cflist tag configure highlight \
11561 -background [$cflist cget -selectbackground]
11562 allcanvs itemconf secsel -fill $c
11563}
11564
11565# This sets the background color and the color scheme for the whole UI.
11566# For some reason, tk_setPalette chooses a nasty dark red for selectColor
11567# if we don't specify one ourselves, which makes the checkbuttons and
11568# radiobuttons look bad. This chooses white for selectColor if the
11569# background color is light, or black if it is dark.
11570proc setui {c} {
11571 if {[tk windowingsystem] eq "win32"} { return }
11572 set bg [winfo rgb . $c]
11573 set selc black
11574 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11575 set selc white
11576 }
11577 tk_setPalette background $c selectColor $selc
11578}
11579
11580proc setbg {c} {
11581 global bglist
11582
11583 foreach w $bglist {
11584 if {[winfo exists $w]} {
11585 $w conf -background $c
11586 }
11587 }
11588}
11589
11590proc setfg {c} {
11591 global fglist canv
11592
11593 foreach w $fglist {
11594 if {[winfo exists $w]} {
11595 $w conf -foreground $c
11596 }
11597 }
11598 allcanvs itemconf text -fill $c
11599 $canv itemconf circle -outline $c
11600 $canv itemconf markid -outline $c
11601}
11602
11603proc prefscan {} {
11604 global oldprefs prefstop
11605
11606 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11607 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11608 global $v
11609 set $v $oldprefs($v)
11610 }
11611 catch {destroy $prefstop}
11612 unset prefstop
11613 fontcan
11614}
11615
11616proc prefsok {} {
11617 global maxwidth maxgraphpct
11618 global oldprefs prefstop showneartags showlocalchanges
11619 global fontpref mainfont textfont uifont
11620 global limitdiffs treediffs perfile_attrs
11621 global hideremotes
11622
11623 catch {destroy $prefstop}
11624 unset prefstop
11625 fontcan
11626 set fontchanged 0
11627 if {$mainfont ne $fontpref(mainfont)} {
11628 set mainfont $fontpref(mainfont)
11629 parsefont mainfont $mainfont
11630 eval font configure mainfont [fontflags mainfont]
11631 eval font configure mainfontbold [fontflags mainfont 1]
11632 setcoords
11633 set fontchanged 1
11634 }
11635 if {$textfont ne $fontpref(textfont)} {
11636 set textfont $fontpref(textfont)
11637 parsefont textfont $textfont
11638 eval font configure textfont [fontflags textfont]
11639 eval font configure textfontbold [fontflags textfont 1]
11640 }
11641 if {$uifont ne $fontpref(uifont)} {
11642 set uifont $fontpref(uifont)
11643 parsefont uifont $uifont
11644 eval font configure uifont [fontflags uifont]
11645 }
11646 settabs
11647 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11648 if {$showlocalchanges} {
11649 doshowlocalchanges
11650 } else {
11651 dohidelocalchanges
11652 }
11653 }
11654 if {$limitdiffs != $oldprefs(limitdiffs) ||
11655 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11656 # treediffs elements are limited by path;
11657 # won't have encodings cached if perfile_attrs was just turned on
11658 unset -nocomplain treediffs
11659 }
11660 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11661 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11662 redisplay
11663 } elseif {$showneartags != $oldprefs(showneartags) ||
11664 $limitdiffs != $oldprefs(limitdiffs)} {
11665 reselectline
11666 }
11667 if {$hideremotes != $oldprefs(hideremotes)} {
11668 rereadrefs
11669 }
11670}
11671
11672proc formatdate {d} {
11673 global datetimeformat
11674 if {$d ne {}} {
11675 # If $datetimeformat includes a timezone, display in the
11676 # timezone of the argument. Otherwise, display in local time.
11677 if {[string match {*%[zZ]*} $datetimeformat]} {
11678 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11679 # Tcl < 8.5 does not support -timezone. Emulate it by
11680 # setting TZ (e.g. TZ=<-0430>+04:30).
11681 global env
11682 if {[info exists env(TZ)]} {
11683 set savedTZ $env(TZ)
11684 }
11685 set zone [lindex $d 1]
11686 set sign [string map {+ - - +} [string index $zone 0]]
11687 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11688 set d [clock format [lindex $d 0] -format $datetimeformat]
11689 if {[info exists savedTZ]} {
11690 set env(TZ) $savedTZ
11691 } else {
11692 unset env(TZ)
11693 }
11694 }
11695 } else {
11696 set d [clock format [lindex $d 0] -format $datetimeformat]
11697 }
11698 }
11699 return $d
11700}
11701
11702# This list of encoding names and aliases is distilled from
11703# http://www.iana.org/assignments/character-sets.
11704# Not all of them are supported by Tcl.
11705set encoding_aliases {
11706 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11707 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11708 { ISO-10646-UTF-1 csISO10646UTF1 }
11709 { ISO_646.basic:1983 ref csISO646basic1983 }
11710 { INVARIANT csINVARIANT }
11711 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11712 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11713 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11714 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11715 { NATS-DANO iso-ir-9-1 csNATSDANO }
11716 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11717 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11718 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11719 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11720 { ISO-2022-KR csISO2022KR }
11721 { EUC-KR csEUCKR }
11722 { ISO-2022-JP csISO2022JP }
11723 { ISO-2022-JP-2 csISO2022JP2 }
11724 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11725 csISO13JISC6220jp }
11726 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11727 { IT iso-ir-15 ISO646-IT csISO15Italian }
11728 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11729 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11730 { greek7-old iso-ir-18 csISO18Greek7Old }
11731 { latin-greek iso-ir-19 csISO19LatinGreek }
11732 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11733 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11734 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11735 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11736 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11737 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11738 { INIS iso-ir-49 csISO49INIS }
11739 { INIS-8 iso-ir-50 csISO50INIS8 }
11740 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11741 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11742 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11743 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11744 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11745 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11746 csISO60Norwegian1 }
11747 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11748 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11749 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11750 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11751 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11752 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11753 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11754 { greek7 iso-ir-88 csISO88Greek7 }
11755 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11756 { iso-ir-90 csISO90 }
11757 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11758 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11759 csISO92JISC62991984b }
11760 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11761 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11762 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11763 csISO95JIS62291984handadd }
11764 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11765 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11766 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11767 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11768 CP819 csISOLatin1 }
11769 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11770 { T.61-7bit iso-ir-102 csISO102T617bit }
11771 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11772 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11773 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11774 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11775 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11776 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11777 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11778 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11779 arabic csISOLatinArabic }
11780 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11781 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11782 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11783 greek greek8 csISOLatinGreek }
11784 { T.101-G2 iso-ir-128 csISO128T101G2 }
11785 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11786 csISOLatinHebrew }
11787 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11788 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11789 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11790 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11791 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11792 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11793 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11794 csISOLatinCyrillic }
11795 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11796 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11797 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11798 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11799 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11800 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11801 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11802 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11803 { ISO_10367-box iso-ir-155 csISO10367Box }
11804 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11805 { latin-lap lap iso-ir-158 csISO158Lap }
11806 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11807 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11808 { us-dk csUSDK }
11809 { dk-us csDKUS }
11810 { JIS_X0201 X0201 csHalfWidthKatakana }
11811 { KSC5636 ISO646-KR csKSC5636 }
11812 { ISO-10646-UCS-2 csUnicode }
11813 { ISO-10646-UCS-4 csUCS4 }
11814 { DEC-MCS dec csDECMCS }
11815 { hp-roman8 roman8 r8 csHPRoman8 }
11816 { macintosh mac csMacintosh }
11817 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11818 csIBM037 }
11819 { IBM038 EBCDIC-INT cp038 csIBM038 }
11820 { IBM273 CP273 csIBM273 }
11821 { IBM274 EBCDIC-BE CP274 csIBM274 }
11822 { IBM275 EBCDIC-BR cp275 csIBM275 }
11823 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11824 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11825 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11826 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11827 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11828 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11829 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11830 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11831 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11832 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11833 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11834 { IBM437 cp437 437 csPC8CodePage437 }
11835 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11836 { IBM775 cp775 csPC775Baltic }
11837 { IBM850 cp850 850 csPC850Multilingual }
11838 { IBM851 cp851 851 csIBM851 }
11839 { IBM852 cp852 852 csPCp852 }
11840 { IBM855 cp855 855 csIBM855 }
11841 { IBM857 cp857 857 csIBM857 }
11842 { IBM860 cp860 860 csIBM860 }
11843 { IBM861 cp861 861 cp-is csIBM861 }
11844 { IBM862 cp862 862 csPC862LatinHebrew }
11845 { IBM863 cp863 863 csIBM863 }
11846 { IBM864 cp864 csIBM864 }
11847 { IBM865 cp865 865 csIBM865 }
11848 { IBM866 cp866 866 csIBM866 }
11849 { IBM868 CP868 cp-ar csIBM868 }
11850 { IBM869 cp869 869 cp-gr csIBM869 }
11851 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11852 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11853 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11854 { IBM891 cp891 csIBM891 }
11855 { IBM903 cp903 csIBM903 }
11856 { IBM904 cp904 904 csIBBM904 }
11857 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11858 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11859 { IBM1026 CP1026 csIBM1026 }
11860 { EBCDIC-AT-DE csIBMEBCDICATDE }
11861 { EBCDIC-AT-DE-A csEBCDICATDEA }
11862 { EBCDIC-CA-FR csEBCDICCAFR }
11863 { EBCDIC-DK-NO csEBCDICDKNO }
11864 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11865 { EBCDIC-FI-SE csEBCDICFISE }
11866 { EBCDIC-FI-SE-A csEBCDICFISEA }
11867 { EBCDIC-FR csEBCDICFR }
11868 { EBCDIC-IT csEBCDICIT }
11869 { EBCDIC-PT csEBCDICPT }
11870 { EBCDIC-ES csEBCDICES }
11871 { EBCDIC-ES-A csEBCDICESA }
11872 { EBCDIC-ES-S csEBCDICESS }
11873 { EBCDIC-UK csEBCDICUK }
11874 { EBCDIC-US csEBCDICUS }
11875 { UNKNOWN-8BIT csUnknown8BiT }
11876 { MNEMONIC csMnemonic }
11877 { MNEM csMnem }
11878 { VISCII csVISCII }
11879 { VIQR csVIQR }
11880 { KOI8-R csKOI8R }
11881 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11882 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11883 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11884 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11885 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11886 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11887 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11888 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11889 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11890 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11891 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11892 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11893 { IBM1047 IBM-1047 }
11894 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11895 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11896 { UNICODE-1-1 csUnicode11 }
11897 { CESU-8 csCESU-8 }
11898 { BOCU-1 csBOCU-1 }
11899 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11900 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11901 l8 }
11902 { ISO-8859-15 ISO_8859-15 Latin-9 }
11903 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11904 { GBK CP936 MS936 windows-936 }
11905 { JIS_Encoding csJISEncoding }
11906 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11907 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11908 EUC-JP }
11909 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11910 { ISO-10646-UCS-Basic csUnicodeASCII }
11911 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11912 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11913 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11914 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11915 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11916 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11917 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11918 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11919 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11920 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11921 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11922 { Ventura-US csVenturaUS }
11923 { Ventura-International csVenturaInternational }
11924 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11925 { PC8-Turkish csPC8Turkish }
11926 { IBM-Symbols csIBMSymbols }
11927 { IBM-Thai csIBMThai }
11928 { HP-Legal csHPLegal }
11929 { HP-Pi-font csHPPiFont }
11930 { HP-Math8 csHPMath8 }
11931 { Adobe-Symbol-Encoding csHPPSMath }
11932 { HP-DeskTop csHPDesktop }
11933 { Ventura-Math csVenturaMath }
11934 { Microsoft-Publishing csMicrosoftPublishing }
11935 { Windows-31J csWindows31J }
11936 { GB2312 csGB2312 }
11937 { Big5 csBig5 }
11938}
11939
11940proc tcl_encoding {enc} {
11941 global encoding_aliases tcl_encoding_cache
11942 if {[info exists tcl_encoding_cache($enc)]} {
11943 return $tcl_encoding_cache($enc)
11944 }
11945 set names [encoding names]
11946 set lcnames [string tolower $names]
11947 set enc [string tolower $enc]
11948 set i [lsearch -exact $lcnames $enc]
11949 if {$i < 0} {
11950 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11951 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11952 set i [lsearch -exact $lcnames $encx]
11953 }
11954 }
11955 if {$i < 0} {
11956 foreach l $encoding_aliases {
11957 set ll [string tolower $l]
11958 if {[lsearch -exact $ll $enc] < 0} continue
11959 # look through the aliases for one that tcl knows about
11960 foreach e $ll {
11961 set i [lsearch -exact $lcnames $e]
11962 if {$i < 0} {
11963 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11964 set i [lsearch -exact $lcnames $ex]
11965 }
11966 }
11967 if {$i >= 0} break
11968 }
11969 break
11970 }
11971 }
11972 set tclenc {}
11973 if {$i >= 0} {
11974 set tclenc [lindex $names $i]
11975 }
11976 set tcl_encoding_cache($enc) $tclenc
11977 return $tclenc
11978}
11979
11980proc gitattr {path attr default} {
11981 global path_attr_cache
11982 if {[info exists path_attr_cache($attr,$path)]} {
11983 set r $path_attr_cache($attr,$path)
11984 } else {
11985 set r "unspecified"
11986 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11987 regexp "(.*): $attr: (.*)" $line m f r
11988 }
11989 set path_attr_cache($attr,$path) $r
11990 }
11991 if {$r eq "unspecified"} {
11992 return $default
11993 }
11994 return $r
11995}
11996
11997proc cache_gitattr {attr pathlist} {
11998 global path_attr_cache
11999 set newlist {}
12000 foreach path $pathlist {
12001 if {![info exists path_attr_cache($attr,$path)]} {
12002 lappend newlist $path
12003 }
12004 }
12005 set lim 1000
12006 if {[tk windowingsystem] == "win32"} {
12007 # windows has a 32k limit on the arguments to a command...
12008 set lim 30
12009 }
12010 while {$newlist ne {}} {
12011 set head [lrange $newlist 0 [expr {$lim - 1}]]
12012 set newlist [lrange $newlist $lim end]
12013 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12014 foreach row [split $rlist "\n"] {
12015 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12016 if {[string index $path 0] eq "\""} {
12017 set path [encoding convertfrom [lindex $path 0]]
12018 }
12019 set path_attr_cache($attr,$path) $value
12020 }
12021 }
12022 }
12023 }
12024}
12025
12026proc get_path_encoding {path} {
12027 global gui_encoding perfile_attrs
12028 set tcl_enc $gui_encoding
12029 if {$path ne {} && $perfile_attrs} {
12030 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12031 if {$enc2 ne {}} {
12032 set tcl_enc $enc2
12033 }
12034 }
12035 return $tcl_enc
12036}
12037
12038## For msgcat loading, first locate the installation location.
12039if { [info exists ::env(GITK_MSGSDIR)] } {
12040 ## Msgsdir was manually set in the environment.
12041 set gitk_msgsdir $::env(GITK_MSGSDIR)
12042} else {
12043 ## Let's guess the prefix from argv0.
12044 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12045 set gitk_libdir [file join $gitk_prefix share gitk lib]
12046 set gitk_msgsdir [file join $gitk_libdir msgs]
12047 unset gitk_prefix
12048}
12049
12050## Internationalization (i18n) through msgcat and gettext. See
12051## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12052package require msgcat
12053namespace import ::msgcat::mc
12054## And eventually load the actual message catalog
12055::msgcat::mcload $gitk_msgsdir
12056
12057# First check that Tcl/Tk is recent enough
12058if {[catch {package require Tk 8.4} err]} {
12059 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12060 Gitk requires at least Tcl/Tk 8.4."]
12061 exit 1
12062}
12063
12064# on OSX bring the current Wish process window to front
12065if {[tk windowingsystem] eq "aqua"} {
12066 exec osascript -e [format {
12067 tell application "System Events"
12068 set frontmost of processes whose unix id is %d to true
12069 end tell
12070 } [pid] ]
12071}
12072
12073# Unset GIT_TRACE var if set
12074if { [info exists ::env(GIT_TRACE)] } {
12075 unset ::env(GIT_TRACE)
12076}
12077
12078# defaults...
12079set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12080
12081set gitencoding {}
12082catch {
12083 set gitencoding [exec git config --get i18n.commitencoding]
12084}
12085catch {
12086 set gitencoding [exec git config --get i18n.logoutputencoding]
12087}
12088if {$gitencoding == ""} {
12089 set gitencoding "utf-8"
12090}
12091set tclencoding [tcl_encoding $gitencoding]
12092if {$tclencoding == {}} {
12093 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12094}
12095
12096set gui_encoding [encoding system]
12097catch {
12098 set enc [exec git config --get gui.encoding]
12099 if {$enc ne {}} {
12100 set tclenc [tcl_encoding $enc]
12101 if {$tclenc ne {}} {
12102 set gui_encoding $tclenc
12103 } else {
12104 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12105 }
12106 }
12107}
12108
12109set log_showroot true
12110catch {
12111 set log_showroot [exec git config --bool --get log.showroot]
12112}
12113
12114if {[tk windowingsystem] eq "aqua"} {
12115 set mainfont {{Lucida Grande} 9}
12116 set textfont {Monaco 9}
12117 set uifont {{Lucida Grande} 9 bold}
12118} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12119 # fontconfig!
12120 set mainfont {sans 9}
12121 set textfont {monospace 9}
12122 set uifont {sans 9 bold}
12123} else {
12124 set mainfont {Helvetica 9}
12125 set textfont {Courier 9}
12126 set uifont {Helvetica 9 bold}
12127}
12128set tabstop 8
12129set findmergefiles 0
12130set maxgraphpct 50
12131set maxwidth 16
12132set revlistorder 0
12133set fastdate 0
12134set uparrowlen 5
12135set downarrowlen 5
12136set mingaplen 100
12137set cmitmode "patch"
12138set wrapcomment "none"
12139set showneartags 1
12140set hideremotes 0
12141set maxrefs 20
12142set visiblerefs {"master"}
12143set maxlinelen 200
12144set showlocalchanges 1
12145set limitdiffs 1
12146set datetimeformat "%Y-%m-%d %H:%M:%S"
12147set autoselect 1
12148set autosellen 40
12149set perfile_attrs 0
12150set want_ttk 1
12151
12152if {[tk windowingsystem] eq "aqua"} {
12153 set extdifftool "opendiff"
12154} else {
12155 set extdifftool "meld"
12156}
12157
12158set colors {green red blue magenta darkgrey brown orange}
12159if {[tk windowingsystem] eq "win32"} {
12160 set uicolor SystemButtonFace
12161 set uifgcolor SystemButtonText
12162 set uifgdisabledcolor SystemDisabledText
12163 set bgcolor SystemWindow
12164 set fgcolor SystemWindowText
12165 set selectbgcolor SystemHighlight
12166} else {
12167 set uicolor grey85
12168 set uifgcolor black
12169 set uifgdisabledcolor "#999"
12170 set bgcolor white
12171 set fgcolor black
12172 set selectbgcolor gray85
12173}
12174set diffcolors {red "#00a000" blue}
12175set diffcontext 3
12176set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12177set ignorespace 0
12178set worddiff ""
12179set markbgcolor "#e0e0ff"
12180
12181set headbgcolor green
12182set headfgcolor black
12183set headoutlinecolor black
12184set remotebgcolor #ffddaa
12185set tagbgcolor yellow
12186set tagfgcolor black
12187set tagoutlinecolor black
12188set reflinecolor black
12189set filesepbgcolor #aaaaaa
12190set filesepfgcolor black
12191set linehoverbgcolor #ffff80
12192set linehoverfgcolor black
12193set linehoveroutlinecolor black
12194set mainheadcirclecolor yellow
12195set workingfilescirclecolor red
12196set indexcirclecolor green
12197set circlecolors {white blue gray blue blue}
12198set linkfgcolor blue
12199set circleoutlinecolor $fgcolor
12200set foundbgcolor yellow
12201set currentsearchhitbgcolor orange
12202
12203# button for popping up context menus
12204if {[tk windowingsystem] eq "aqua"} {
12205 set ctxbut <Button-2>
12206} else {
12207 set ctxbut <Button-3>
12208}
12209
12210catch {
12211 # follow the XDG base directory specification by default. See
12212 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12213 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12214 # XDG_CONFIG_HOME environment variable is set
12215 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12216 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12217 } else {
12218 # default XDG_CONFIG_HOME
12219 set config_file "~/.config/git/gitk"
12220 set config_file_tmp "~/.config/git/gitk-tmp"
12221 }
12222 if {![file exists $config_file]} {
12223 # for backward compatibility use the old config file if it exists
12224 if {[file exists "~/.gitk"]} {
12225 set config_file "~/.gitk"
12226 set config_file_tmp "~/.gitk-tmp"
12227 } elseif {![file exists [file dirname $config_file]]} {
12228 file mkdir [file dirname $config_file]
12229 }
12230 }
12231 source $config_file
12232}
12233config_check_tmp_exists 50
12234
12235set config_variables {
12236 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12237 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12238 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12239 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12240 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12241 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12242 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12243 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12244 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12245 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12246}
12247foreach var $config_variables {
12248 config_init_trace $var
12249 trace add variable $var write config_variable_change_cb
12250}
12251
12252parsefont mainfont $mainfont
12253eval font create mainfont [fontflags mainfont]
12254eval font create mainfontbold [fontflags mainfont 1]
12255
12256parsefont textfont $textfont
12257eval font create textfont [fontflags textfont]
12258eval font create textfontbold [fontflags textfont 1]
12259
12260parsefont uifont $uifont
12261eval font create uifont [fontflags uifont]
12262
12263setui $uicolor
12264
12265setoptions
12266
12267# check that we can find a .git directory somewhere...
12268if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12269 show_error {} . [mc "Cannot find a git repository here."]
12270 exit 1
12271}
12272
12273set selecthead {}
12274set selectheadid {}
12275
12276set revtreeargs {}
12277set cmdline_files {}
12278set i 0
12279set revtreeargscmd {}
12280foreach arg $argv {
12281 switch -glob -- $arg {
12282 "" { }
12283 "--" {
12284 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12285 break
12286 }
12287 "--select-commit=*" {
12288 set selecthead [string range $arg 16 end]
12289 }
12290 "--argscmd=*" {
12291 set revtreeargscmd [string range $arg 10 end]
12292 }
12293 default {
12294 lappend revtreeargs $arg
12295 }
12296 }
12297 incr i
12298}
12299
12300if {$selecthead eq "HEAD"} {
12301 set selecthead {}
12302}
12303
12304if {$i >= [llength $argv] && $revtreeargs ne {}} {
12305 # no -- on command line, but some arguments (other than --argscmd)
12306 if {[catch {
12307 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12308 set cmdline_files [split $f "\n"]
12309 set n [llength $cmdline_files]
12310 set revtreeargs [lrange $revtreeargs 0 end-$n]
12311 # Unfortunately git rev-parse doesn't produce an error when
12312 # something is both a revision and a filename. To be consistent
12313 # with git log and git rev-list, check revtreeargs for filenames.
12314 foreach arg $revtreeargs {
12315 if {[file exists $arg]} {
12316 show_error {} . [mc "Ambiguous argument '%s': both revision\
12317 and filename" $arg]
12318 exit 1
12319 }
12320 }
12321 } err]} {
12322 # unfortunately we get both stdout and stderr in $err,
12323 # so look for "fatal:".
12324 set i [string first "fatal:" $err]
12325 if {$i > 0} {
12326 set err [string range $err [expr {$i + 6}] end]
12327 }
12328 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12329 exit 1
12330 }
12331}
12332
12333set nullid "0000000000000000000000000000000000000000"
12334set nullid2 "0000000000000000000000000000000000000001"
12335set nullfile "/dev/null"
12336
12337set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12338if {![info exists have_ttk]} {
12339 set have_ttk [llength [info commands ::ttk::style]]
12340}
12341set use_ttk [expr {$have_ttk && $want_ttk}]
12342set NS [expr {$use_ttk ? "ttk" : ""}]
12343
12344regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12345
12346set show_notes {}
12347if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12348 set show_notes "--show-notes"
12349}
12350
12351set appname "gitk"
12352
12353set runq {}
12354set history {}
12355set historyindex 0
12356set fh_serial 0
12357set nhl_names {}
12358set highlight_paths {}
12359set findpattern {}
12360set searchdirn -forwards
12361set boldids {}
12362set boldnameids {}
12363set diffelide {0 0}
12364set markingmatches 0
12365set linkentercount 0
12366set need_redisplay 0
12367set nrows_drawn 0
12368set firsttabstop 0
12369
12370set nextviewnum 1
12371set curview 0
12372set selectedview 0
12373set selectedhlview [mc "None"]
12374set highlight_related [mc "None"]
12375set highlight_files {}
12376set viewfiles(0) {}
12377set viewperm(0) 0
12378set viewchanged(0) 0
12379set viewargs(0) {}
12380set viewargscmd(0) {}
12381
12382set selectedline {}
12383set numcommits 0
12384set loginstance 0
12385set cmdlineok 0
12386set stopped 0
12387set stuffsaved 0
12388set patchnum 0
12389set lserial 0
12390set hasworktree [hasworktree]
12391set cdup {}
12392if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12393 set cdup [exec git rev-parse --show-cdup]
12394}
12395set worktree [exec git rev-parse --show-toplevel]
12396setcoords
12397makewindow
12398catch {
12399 image create photo gitlogo -width 16 -height 16
12400
12401 image create photo gitlogominus -width 4 -height 2
12402 gitlogominus put #C00000 -to 0 0 4 2
12403 gitlogo copy gitlogominus -to 1 5
12404 gitlogo copy gitlogominus -to 6 5
12405 gitlogo copy gitlogominus -to 11 5
12406 image delete gitlogominus
12407
12408 image create photo gitlogoplus -width 4 -height 4
12409 gitlogoplus put #008000 -to 1 0 3 4
12410 gitlogoplus put #008000 -to 0 1 4 3
12411 gitlogo copy gitlogoplus -to 1 9
12412 gitlogo copy gitlogoplus -to 6 9
12413 gitlogo copy gitlogoplus -to 11 9
12414 image delete gitlogoplus
12415
12416 image create photo gitlogo32 -width 32 -height 32
12417 gitlogo32 copy gitlogo -zoom 2 2
12418
12419 wm iconphoto . -default gitlogo gitlogo32
12420}
12421# wait for the window to become visible
12422tkwait visibility .
12423set_window_title
12424update
12425readrefs
12426
12427if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12428 # create a view for the files/dirs specified on the command line
12429 set curview 1
12430 set selectedview 1
12431 set nextviewnum 2
12432 set viewname(1) [mc "Command line"]
12433 set viewfiles(1) $cmdline_files
12434 set viewargs(1) $revtreeargs
12435 set viewargscmd(1) $revtreeargscmd
12436 set viewperm(1) 0
12437 set viewchanged(1) 0
12438 set vdatemode(1) 0
12439 addviewmenu 1
12440 .bar.view entryconf [mca "Edit view..."] -state normal
12441 .bar.view entryconf [mca "Delete view"] -state normal
12442}
12443
12444if {[info exists permviews]} {
12445 foreach v $permviews {
12446 set n $nextviewnum
12447 incr nextviewnum
12448 set viewname($n) [lindex $v 0]
12449 set viewfiles($n) [lindex $v 1]
12450 set viewargs($n) [lindex $v 2]
12451 set viewargscmd($n) [lindex $v 3]
12452 set viewperm($n) 1
12453 set viewchanged($n) 0
12454 addviewmenu $n
12455 }
12456}
12457
12458if {[tk windowingsystem] eq "win32"} {
12459 focus -force .
12460}
12461
12462getcommits {}
12463
12464# Local variables:
12465# mode: tcl
12466# indent-tabs-mode: t
12467# tab-width: 8
12468# End: