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