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