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