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