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