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