Merge git://git.kernel.org/pub/scm/gitk/gitk
[git/git.git] / gitk-git / gitk
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
4
5 # Copyright © 2005-2009 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.
9
10 package require Tk
11
12 proc gitdir {} {
13 global env
14 if {[info exists env(GIT_DIR)]} {
15 return $env(GIT_DIR)
16 } else {
17 return [exec git rev-parse --git-dir]
18 }
19 }
20
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
26 proc run args {
27 global isonrunq runq currunq
28
29 set script $args
30 if {[info exists isonrunq($script)]} return
31 if {$runq eq {} && ![info exists currunq]} {
32 after idle dorunq
33 }
34 lappend runq [list {} $script]
35 set isonrunq($script) 1
36 }
37
38 proc filerun {fd script} {
39 fileevent $fd readable [list filereadable $fd $script]
40 }
41
42 proc filereadable {fd script} {
43 global runq currunq
44
45 fileevent $fd readable {}
46 if {$runq eq {} && ![info exists currunq]} {
47 after idle dorunq
48 }
49 lappend runq [list $fd $script]
50 }
51
52 proc nukefile {fd} {
53 global runq
54
55 for {set i 0} {$i < [llength $runq]} {} {
56 if {[lindex $runq $i 0] eq $fd} {
57 set runq [lreplace $runq $i $i]
58 } else {
59 incr i
60 }
61 }
62 }
63
64 proc dorunq {} {
65 global isonrunq runq currunq
66
67 set tstart [clock clicks -milliseconds]
68 set t0 $tstart
69 while {[llength $runq] > 0} {
70 set fd [lindex $runq 0 0]
71 set script [lindex $runq 0 1]
72 set currunq [lindex $runq 0]
73 set runq [lrange $runq 1 end]
74 set repeat [eval $script]
75 unset currunq
76 set t1 [clock clicks -milliseconds]
77 set t [expr {$t1 - $t0}]
78 if {$repeat ne {} && $repeat} {
79 if {$fd eq {} || $repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq [list $fd $script]
83 } else {
84 fileevent $fd readable [list filereadable $fd $script]
85 }
86 } elseif {$fd eq {}} {
87 unset isonrunq($script)
88 }
89 set t0 $t1
90 if {$t1 - $tstart >= 80} break
91 }
92 if {$runq ne {}} {
93 after idle dorunq
94 }
95 }
96
97 proc reg_instance {fd} {
98 global commfd leftover loginstance
99
100 set i [incr loginstance]
101 set commfd($i) $fd
102 set leftover($i) {}
103 return $i
104 }
105
106 proc unmerged_files {files} {
107 global nr_unmerged
108
109 # find the list of unmerged files
110 set mlist {}
111 set nr_unmerged 0
112 if {[catch {
113 set fd [open "| git ls-files -u" r]
114 } err]} {
115 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
116 exit 1
117 }
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
120 if {$i < 0} continue
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
123 incr nr_unmerged
124 if {$files eq {} || [path_filter $files $fname]} {
125 lappend mlist $fname
126 }
127 }
128 catch {close $fd}
129 return $mlist
130 }
131
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
134
135 set vdatemode($n) 0
136 set vmergeonly($n) 0
137 set glflags {}
138 set diffargs {}
139 set nextisval 0
140 set revargs {}
141 set origargs $arglist
142 set allknown 1
143 set filtered 0
144 set i -1
145 foreach arg $arglist {
146 incr i
147 if {$nextisval} {
148 lappend glflags $arg
149 set nextisval 0
150 continue
151 }
152 switch -glob -- $arg {
153 "-d" -
154 "--date-order" {
155 set vdatemode($n) 1
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
158 incr i -1
159 }
160 "-[puabwcrRBMC]" -
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs $arg
169 }
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
179 }
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
185 lappend glflags $arg
186 }
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
195 set filtered 1
196 lappend glflags $arg
197 }
198 "-n" {
199 # This appears to be the only one that has a value as a
200 # separate word following it
201 set filtered 1
202 set nextisval 1
203 lappend glflags $arg
204 }
205 "--not" - "--all" {
206 lappend revargs $arg
207 }
208 "--merge" {
209 set vmergeonly($n) 1
210 # git rev-parse doesn't understand --merge
211 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
212 }
213 "--no-replace-objects" {
214 set env(GIT_NO_REPLACE_OBJECTS) "1"
215 }
216 "-*" {
217 # Other flag arguments including -<n>
218 if {[string is digit -strict [string range $arg 1 end]]} {
219 set filtered 1
220 } else {
221 # a flag argument that we don't recognize;
222 # that means we can't optimize
223 set allknown 0
224 }
225 lappend glflags $arg
226 }
227 default {
228 # Non-flag arguments specify commits or ranges of commits
229 if {[string match "*...*" $arg]} {
230 lappend revargs --gitk-symmetric-diff-marker
231 }
232 lappend revargs $arg
233 }
234 }
235 }
236 set vdflags($n) $diffargs
237 set vflags($n) $glflags
238 set vrevs($n) $revargs
239 set vfiltered($n) $filtered
240 set vorigargs($n) $origargs
241 return $allknown
242 }
243
244 proc parseviewrevs {view revs} {
245 global vposids vnegids
246
247 if {$revs eq {}} {
248 set revs HEAD
249 }
250 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
251 # we get stdout followed by stderr in $err
252 # for an unknown rev, git rev-parse echoes it and then errors out
253 set errlines [split $err "\n"]
254 set badrev {}
255 for {set l 0} {$l < [llength $errlines]} {incr l} {
256 set line [lindex $errlines $l]
257 if {!([string length $line] == 40 && [string is xdigit $line])} {
258 if {[string match "fatal:*" $line]} {
259 if {[string match "fatal: ambiguous argument*" $line]
260 && $badrev ne {}} {
261 if {[llength $badrev] == 1} {
262 set err "unknown revision $badrev"
263 } else {
264 set err "unknown revisions: [join $badrev ", "]"
265 }
266 } else {
267 set err [join [lrange $errlines $l end] "\n"]
268 }
269 break
270 }
271 lappend badrev $line
272 }
273 }
274 error_popup "[mc "Error parsing revisions:"] $err"
275 return {}
276 }
277 set ret {}
278 set pos {}
279 set neg {}
280 set sdm 0
281 foreach id [split $ids "\n"] {
282 if {$id eq "--gitk-symmetric-diff-marker"} {
283 set sdm 4
284 } elseif {[string match "^*" $id]} {
285 if {$sdm != 1} {
286 lappend ret $id
287 if {$sdm == 3} {
288 set sdm 0
289 }
290 }
291 lappend neg [string range $id 1 end]
292 } else {
293 if {$sdm != 2} {
294 lappend ret $id
295 } else {
296 lset ret end $id...[lindex $ret end]
297 }
298 lappend pos $id
299 }
300 incr sdm -1
301 }
302 set vposids($view) $pos
303 set vnegids($view) $neg
304 return $ret
305 }
306
307 # Start off a git log process and arrange to read its output
308 proc start_rev_list {view} {
309 global startmsecs commitidx viewcomplete curview
310 global tclencoding
311 global viewargs viewargscmd viewfiles vfilelimit
312 global showlocalchanges
313 global viewactive viewinstances vmergeonly
314 global mainheadid viewmainheadid viewmainheadid_orig
315 global vcanopt vflags vrevs vorigargs
316
317 set startmsecs [clock clicks -milliseconds]
318 set commitidx($view) 0
319 # these are set this way for the error exits
320 set viewcomplete($view) 1
321 set viewactive($view) 0
322 varcinit $view
323
324 set args $viewargs($view)
325 if {$viewargscmd($view) ne {}} {
326 if {[catch {
327 set str [exec sh -c $viewargscmd($view)]
328 } err]} {
329 error_popup "[mc "Error executing --argscmd command:"] $err"
330 return 0
331 }
332 set args [concat $args [split $str "\n"]]
333 }
334 set vcanopt($view) [parseviewargs $view $args]
335
336 set files $viewfiles($view)
337 if {$vmergeonly($view)} {
338 set files [unmerged_files $files]
339 if {$files eq {}} {
340 global nr_unmerged
341 if {$nr_unmerged == 0} {
342 error_popup [mc "No files selected: --merge specified but\
343 no files are unmerged."]
344 } else {
345 error_popup [mc "No files selected: --merge specified but\
346 no unmerged files are within file limit."]
347 }
348 return 0
349 }
350 }
351 set vfilelimit($view) $files
352
353 if {$vcanopt($view)} {
354 set revs [parseviewrevs $view $vrevs($view)]
355 if {$revs eq {}} {
356 return 0
357 }
358 set args [concat $vflags($view) $revs]
359 } else {
360 set args $vorigargs($view)
361 }
362
363 if {[catch {
364 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
365 --boundary $args "--" $files] r]
366 } err]} {
367 error_popup "[mc "Error executing git log:"] $err"
368 return 0
369 }
370 set i [reg_instance $fd]
371 set viewinstances($view) [list $i]
372 set viewmainheadid($view) $mainheadid
373 set viewmainheadid_orig($view) $mainheadid
374 if {$files ne {} && $mainheadid ne {}} {
375 get_viewmainhead $view
376 }
377 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
378 interestedin $viewmainheadid($view) dodiffindex
379 }
380 fconfigure $fd -blocking 0 -translation lf -eofchar {}
381 if {$tclencoding != {}} {
382 fconfigure $fd -encoding $tclencoding
383 }
384 filerun $fd [list getcommitlines $fd $i $view 0]
385 nowbusy $view [mc "Reading"]
386 set viewcomplete($view) 0
387 set viewactive($view) 1
388 return 1
389 }
390
391 proc stop_instance {inst} {
392 global commfd leftover
393
394 set fd $commfd($inst)
395 catch {
396 set pid [pid $fd]
397
398 if {$::tcl_platform(platform) eq {windows}} {
399 exec kill -f $pid
400 } else {
401 exec kill $pid
402 }
403 }
404 catch {close $fd}
405 nukefile $fd
406 unset commfd($inst)
407 unset leftover($inst)
408 }
409
410 proc stop_backends {} {
411 global commfd
412
413 foreach inst [array names commfd] {
414 stop_instance $inst
415 }
416 }
417
418 proc stop_rev_list {view} {
419 global viewinstances
420
421 foreach inst $viewinstances($view) {
422 stop_instance $inst
423 }
424 set viewinstances($view) {}
425 }
426
427 proc reset_pending_select {selid} {
428 global pending_select mainheadid selectheadid
429
430 if {$selid ne {}} {
431 set pending_select $selid
432 } elseif {$selectheadid ne {}} {
433 set pending_select $selectheadid
434 } else {
435 set pending_select $mainheadid
436 }
437 }
438
439 proc getcommits {selid} {
440 global canv curview need_redisplay viewactive
441
442 initlayout
443 if {[start_rev_list $curview]} {
444 reset_pending_select $selid
445 show_status [mc "Reading commits..."]
446 set need_redisplay 1
447 } else {
448 show_status [mc "No commits selected"]
449 }
450 }
451
452 proc updatecommits {} {
453 global curview vcanopt vorigargs vfilelimit viewinstances
454 global viewactive viewcomplete tclencoding
455 global startmsecs showneartags showlocalchanges
456 global mainheadid viewmainheadid viewmainheadid_orig pending_select
457 global isworktree
458 global varcid vposids vnegids vflags vrevs
459
460 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
461 rereadrefs
462 set view $curview
463 if {$mainheadid ne $viewmainheadid_orig($view)} {
464 if {$showlocalchanges} {
465 dohidelocalchanges
466 }
467 set viewmainheadid($view) $mainheadid
468 set viewmainheadid_orig($view) $mainheadid
469 if {$vfilelimit($view) ne {}} {
470 get_viewmainhead $view
471 }
472 }
473 if {$showlocalchanges} {
474 doshowlocalchanges
475 }
476 if {$vcanopt($view)} {
477 set oldpos $vposids($view)
478 set oldneg $vnegids($view)
479 set revs [parseviewrevs $view $vrevs($view)]
480 if {$revs eq {}} {
481 return
482 }
483 # note: getting the delta when negative refs change is hard,
484 # and could require multiple git log invocations, so in that
485 # case we ask git log for all the commits (not just the delta)
486 if {$oldneg eq $vnegids($view)} {
487 set newrevs {}
488 set npos 0
489 # take out positive refs that we asked for before or
490 # that we have already seen
491 foreach rev $revs {
492 if {[string length $rev] == 40} {
493 if {[lsearch -exact $oldpos $rev] < 0
494 && ![info exists varcid($view,$rev)]} {
495 lappend newrevs $rev
496 incr npos
497 }
498 } else {
499 lappend $newrevs $rev
500 }
501 }
502 if {$npos == 0} return
503 set revs $newrevs
504 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
505 }
506 set args [concat $vflags($view) $revs --not $oldpos]
507 } else {
508 set args $vorigargs($view)
509 }
510 if {[catch {
511 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
512 --boundary $args "--" $vfilelimit($view)] r]
513 } err]} {
514 error_popup "[mc "Error executing git log:"] $err"
515 return
516 }
517 if {$viewactive($view) == 0} {
518 set startmsecs [clock clicks -milliseconds]
519 }
520 set i [reg_instance $fd]
521 lappend viewinstances($view) $i
522 fconfigure $fd -blocking 0 -translation lf -eofchar {}
523 if {$tclencoding != {}} {
524 fconfigure $fd -encoding $tclencoding
525 }
526 filerun $fd [list getcommitlines $fd $i $view 1]
527 incr viewactive($view)
528 set viewcomplete($view) 0
529 reset_pending_select {}
530 nowbusy $view [mc "Reading"]
531 if {$showneartags} {
532 getallcommits
533 }
534 }
535
536 proc reloadcommits {} {
537 global curview viewcomplete selectedline currentid thickerline
538 global showneartags treediffs commitinterest cached_commitrow
539 global targetid
540
541 set selid {}
542 if {$selectedline ne {}} {
543 set selid $currentid
544 }
545
546 if {!$viewcomplete($curview)} {
547 stop_rev_list $curview
548 }
549 resetvarcs $curview
550 set selectedline {}
551 catch {unset currentid}
552 catch {unset thickerline}
553 catch {unset treediffs}
554 readrefs
555 changedrefs
556 if {$showneartags} {
557 getallcommits
558 }
559 clear_display
560 catch {unset commitinterest}
561 catch {unset cached_commitrow}
562 catch {unset targetid}
563 setcanvscroll
564 getcommits $selid
565 return 0
566 }
567
568 # This makes a string representation of a positive integer which
569 # sorts as a string in numerical order
570 proc strrep {n} {
571 if {$n < 16} {
572 return [format "%x" $n]
573 } elseif {$n < 256} {
574 return [format "x%.2x" $n]
575 } elseif {$n < 65536} {
576 return [format "y%.4x" $n]
577 }
578 return [format "z%.8x" $n]
579 }
580
581 # Procedures used in reordering commits from git log (without
582 # --topo-order) into the order for display.
583
584 proc varcinit {view} {
585 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
586 global vtokmod varcmod vrowmod varcix vlastins
587
588 set varcstart($view) {{}}
589 set vupptr($view) {0}
590 set vdownptr($view) {0}
591 set vleftptr($view) {0}
592 set vbackptr($view) {0}
593 set varctok($view) {{}}
594 set varcrow($view) {{}}
595 set vtokmod($view) {}
596 set varcmod($view) 0
597 set vrowmod($view) 0
598 set varcix($view) {{}}
599 set vlastins($view) {0}
600 }
601
602 proc resetvarcs {view} {
603 global varcid varccommits parents children vseedcount ordertok
604
605 foreach vid [array names varcid $view,*] {
606 unset varcid($vid)
607 unset children($vid)
608 unset parents($vid)
609 }
610 # some commits might have children but haven't been seen yet
611 foreach vid [array names children $view,*] {
612 unset children($vid)
613 }
614 foreach va [array names varccommits $view,*] {
615 unset varccommits($va)
616 }
617 foreach vd [array names vseedcount $view,*] {
618 unset vseedcount($vd)
619 }
620 catch {unset ordertok}
621 }
622
623 # returns a list of the commits with no children
624 proc seeds {v} {
625 global vdownptr vleftptr varcstart
626
627 set ret {}
628 set a [lindex $vdownptr($v) 0]
629 while {$a != 0} {
630 lappend ret [lindex $varcstart($v) $a]
631 set a [lindex $vleftptr($v) $a]
632 }
633 return $ret
634 }
635
636 proc newvarc {view id} {
637 global varcid varctok parents children vdatemode
638 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
639 global commitdata commitinfo vseedcount varccommits vlastins
640
641 set a [llength $varctok($view)]
642 set vid $view,$id
643 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
644 if {![info exists commitinfo($id)]} {
645 parsecommit $id $commitdata($id) 1
646 }
647 set cdate [lindex $commitinfo($id) 4]
648 if {![string is integer -strict $cdate]} {
649 set cdate 0
650 }
651 if {![info exists vseedcount($view,$cdate)]} {
652 set vseedcount($view,$cdate) -1
653 }
654 set c [incr vseedcount($view,$cdate)]
655 set cdate [expr {$cdate ^ 0xffffffff}]
656 set tok "s[strrep $cdate][strrep $c]"
657 } else {
658 set tok {}
659 }
660 set ka 0
661 if {[llength $children($vid)] > 0} {
662 set kid [lindex $children($vid) end]
663 set k $varcid($view,$kid)
664 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
665 set ki $kid
666 set ka $k
667 set tok [lindex $varctok($view) $k]
668 }
669 }
670 if {$ka != 0} {
671 set i [lsearch -exact $parents($view,$ki) $id]
672 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
673 append tok [strrep $j]
674 }
675 set c [lindex $vlastins($view) $ka]
676 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
677 set c $ka
678 set b [lindex $vdownptr($view) $ka]
679 } else {
680 set b [lindex $vleftptr($view) $c]
681 }
682 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
683 set c $b
684 set b [lindex $vleftptr($view) $c]
685 }
686 if {$c == $ka} {
687 lset vdownptr($view) $ka $a
688 lappend vbackptr($view) 0
689 } else {
690 lset vleftptr($view) $c $a
691 lappend vbackptr($view) $c
692 }
693 lset vlastins($view) $ka $a
694 lappend vupptr($view) $ka
695 lappend vleftptr($view) $b
696 if {$b != 0} {
697 lset vbackptr($view) $b $a
698 }
699 lappend varctok($view) $tok
700 lappend varcstart($view) $id
701 lappend vdownptr($view) 0
702 lappend varcrow($view) {}
703 lappend varcix($view) {}
704 set varccommits($view,$a) {}
705 lappend vlastins($view) 0
706 return $a
707 }
708
709 proc splitvarc {p v} {
710 global varcid varcstart varccommits varctok vtokmod
711 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
712
713 set oa $varcid($v,$p)
714 set otok [lindex $varctok($v) $oa]
715 set ac $varccommits($v,$oa)
716 set i [lsearch -exact $varccommits($v,$oa) $p]
717 if {$i <= 0} return
718 set na [llength $varctok($v)]
719 # "%" sorts before "0"...
720 set tok "$otok%[strrep $i]"
721 lappend varctok($v) $tok
722 lappend varcrow($v) {}
723 lappend varcix($v) {}
724 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
725 set varccommits($v,$na) [lrange $ac $i end]
726 lappend varcstart($v) $p
727 foreach id $varccommits($v,$na) {
728 set varcid($v,$id) $na
729 }
730 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
731 lappend vlastins($v) [lindex $vlastins($v) $oa]
732 lset vdownptr($v) $oa $na
733 lset vlastins($v) $oa 0
734 lappend vupptr($v) $oa
735 lappend vleftptr($v) 0
736 lappend vbackptr($v) 0
737 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
738 lset vupptr($v) $b $na
739 }
740 if {[string compare $otok $vtokmod($v)] <= 0} {
741 modify_arc $v $oa
742 }
743 }
744
745 proc renumbervarc {a v} {
746 global parents children varctok varcstart varccommits
747 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
748
749 set t1 [clock clicks -milliseconds]
750 set todo {}
751 set isrelated($a) 1
752 set kidchanged($a) 1
753 set ntot 0
754 while {$a != 0} {
755 if {[info exists isrelated($a)]} {
756 lappend todo $a
757 set id [lindex $varccommits($v,$a) end]
758 foreach p $parents($v,$id) {
759 if {[info exists varcid($v,$p)]} {
760 set isrelated($varcid($v,$p)) 1
761 }
762 }
763 }
764 incr ntot
765 set b [lindex $vdownptr($v) $a]
766 if {$b == 0} {
767 while {$a != 0} {
768 set b [lindex $vleftptr($v) $a]
769 if {$b != 0} break
770 set a [lindex $vupptr($v) $a]
771 }
772 }
773 set a $b
774 }
775 foreach a $todo {
776 if {![info exists kidchanged($a)]} continue
777 set id [lindex $varcstart($v) $a]
778 if {[llength $children($v,$id)] > 1} {
779 set children($v,$id) [lsort -command [list vtokcmp $v] \
780 $children($v,$id)]
781 }
782 set oldtok [lindex $varctok($v) $a]
783 if {!$vdatemode($v)} {
784 set tok {}
785 } else {
786 set tok $oldtok
787 }
788 set ka 0
789 set kid [last_real_child $v,$id]
790 if {$kid ne {}} {
791 set k $varcid($v,$kid)
792 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
793 set ki $kid
794 set ka $k
795 set tok [lindex $varctok($v) $k]
796 }
797 }
798 if {$ka != 0} {
799 set i [lsearch -exact $parents($v,$ki) $id]
800 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
801 append tok [strrep $j]
802 }
803 if {$tok eq $oldtok} {
804 continue
805 }
806 set id [lindex $varccommits($v,$a) end]
807 foreach p $parents($v,$id) {
808 if {[info exists varcid($v,$p)]} {
809 set kidchanged($varcid($v,$p)) 1
810 } else {
811 set sortkids($p) 1
812 }
813 }
814 lset varctok($v) $a $tok
815 set b [lindex $vupptr($v) $a]
816 if {$b != $ka} {
817 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
818 modify_arc $v $ka
819 }
820 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
821 modify_arc $v $b
822 }
823 set c [lindex $vbackptr($v) $a]
824 set d [lindex $vleftptr($v) $a]
825 if {$c == 0} {
826 lset vdownptr($v) $b $d
827 } else {
828 lset vleftptr($v) $c $d
829 }
830 if {$d != 0} {
831 lset vbackptr($v) $d $c
832 }
833 if {[lindex $vlastins($v) $b] == $a} {
834 lset vlastins($v) $b $c
835 }
836 lset vupptr($v) $a $ka
837 set c [lindex $vlastins($v) $ka]
838 if {$c == 0 || \
839 [string compare $tok [lindex $varctok($v) $c]] < 0} {
840 set c $ka
841 set b [lindex $vdownptr($v) $ka]
842 } else {
843 set b [lindex $vleftptr($v) $c]
844 }
845 while {$b != 0 && \
846 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
847 set c $b
848 set b [lindex $vleftptr($v) $c]
849 }
850 if {$c == $ka} {
851 lset vdownptr($v) $ka $a
852 lset vbackptr($v) $a 0
853 } else {
854 lset vleftptr($v) $c $a
855 lset vbackptr($v) $a $c
856 }
857 lset vleftptr($v) $a $b
858 if {$b != 0} {
859 lset vbackptr($v) $b $a
860 }
861 lset vlastins($v) $ka $a
862 }
863 }
864 foreach id [array names sortkids] {
865 if {[llength $children($v,$id)] > 1} {
866 set children($v,$id) [lsort -command [list vtokcmp $v] \
867 $children($v,$id)]
868 }
869 }
870 set t2 [clock clicks -milliseconds]
871 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
872 }
873
874 # Fix up the graph after we have found out that in view $v,
875 # $p (a commit that we have already seen) is actually the parent
876 # of the last commit in arc $a.
877 proc fix_reversal {p a v} {
878 global varcid varcstart varctok vupptr
879
880 set pa $varcid($v,$p)
881 if {$p ne [lindex $varcstart($v) $pa]} {
882 splitvarc $p $v
883 set pa $varcid($v,$p)
884 }
885 # seeds always need to be renumbered
886 if {[lindex $vupptr($v) $pa] == 0 ||
887 [string compare [lindex $varctok($v) $a] \
888 [lindex $varctok($v) $pa]] > 0} {
889 renumbervarc $pa $v
890 }
891 }
892
893 proc insertrow {id p v} {
894 global cmitlisted children parents varcid varctok vtokmod
895 global varccommits ordertok commitidx numcommits curview
896 global targetid targetrow
897
898 readcommit $id
899 set vid $v,$id
900 set cmitlisted($vid) 1
901 set children($vid) {}
902 set parents($vid) [list $p]
903 set a [newvarc $v $id]
904 set varcid($vid) $a
905 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
906 modify_arc $v $a
907 }
908 lappend varccommits($v,$a) $id
909 set vp $v,$p
910 if {[llength [lappend children($vp) $id]] > 1} {
911 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
912 catch {unset ordertok}
913 }
914 fix_reversal $p $a $v
915 incr commitidx($v)
916 if {$v == $curview} {
917 set numcommits $commitidx($v)
918 setcanvscroll
919 if {[info exists targetid]} {
920 if {![comes_before $targetid $p]} {
921 incr targetrow
922 }
923 }
924 }
925 }
926
927 proc insertfakerow {id p} {
928 global varcid varccommits parents children cmitlisted
929 global commitidx varctok vtokmod targetid targetrow curview numcommits
930
931 set v $curview
932 set a $varcid($v,$p)
933 set i [lsearch -exact $varccommits($v,$a) $p]
934 if {$i < 0} {
935 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
936 return
937 }
938 set children($v,$id) {}
939 set parents($v,$id) [list $p]
940 set varcid($v,$id) $a
941 lappend children($v,$p) $id
942 set cmitlisted($v,$id) 1
943 set numcommits [incr commitidx($v)]
944 # note we deliberately don't update varcstart($v) even if $i == 0
945 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
946 modify_arc $v $a $i
947 if {[info exists targetid]} {
948 if {![comes_before $targetid $p]} {
949 incr targetrow
950 }
951 }
952 setcanvscroll
953 drawvisible
954 }
955
956 proc removefakerow {id} {
957 global varcid varccommits parents children commitidx
958 global varctok vtokmod cmitlisted currentid selectedline
959 global targetid curview numcommits
960
961 set v $curview
962 if {[llength $parents($v,$id)] != 1} {
963 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
964 return
965 }
966 set p [lindex $parents($v,$id) 0]
967 set a $varcid($v,$id)
968 set i [lsearch -exact $varccommits($v,$a) $id]
969 if {$i < 0} {
970 puts "oops: removefakerow can't find [shortids $id] on arc $a"
971 return
972 }
973 unset varcid($v,$id)
974 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
975 unset parents($v,$id)
976 unset children($v,$id)
977 unset cmitlisted($v,$id)
978 set numcommits [incr commitidx($v) -1]
979 set j [lsearch -exact $children($v,$p) $id]
980 if {$j >= 0} {
981 set children($v,$p) [lreplace $children($v,$p) $j $j]
982 }
983 modify_arc $v $a $i
984 if {[info exist currentid] && $id eq $currentid} {
985 unset currentid
986 set selectedline {}
987 }
988 if {[info exists targetid] && $targetid eq $id} {
989 set targetid $p
990 }
991 setcanvscroll
992 drawvisible
993 }
994
995 proc real_children {vp} {
996 global children nullid nullid2
997
998 set kids {}
999 foreach id $children($vp) {
1000 if {$id ne $nullid && $id ne $nullid2} {
1001 lappend kids $id
1002 }
1003 }
1004 return $kids
1005 }
1006
1007 proc first_real_child {vp} {
1008 global children nullid nullid2
1009
1010 foreach id $children($vp) {
1011 if {$id ne $nullid && $id ne $nullid2} {
1012 return $id
1013 }
1014 }
1015 return {}
1016 }
1017
1018 proc last_real_child {vp} {
1019 global children nullid nullid2
1020
1021 set kids $children($vp)
1022 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1023 set id [lindex $kids $i]
1024 if {$id ne $nullid && $id ne $nullid2} {
1025 return $id
1026 }
1027 }
1028 return {}
1029 }
1030
1031 proc vtokcmp {v a b} {
1032 global varctok varcid
1033
1034 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1035 [lindex $varctok($v) $varcid($v,$b)]]
1036 }
1037
1038 # This assumes that if lim is not given, the caller has checked that
1039 # arc a's token is less than $vtokmod($v)
1040 proc modify_arc {v a {lim {}}} {
1041 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1042
1043 if {$lim ne {}} {
1044 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1045 if {$c > 0} return
1046 if {$c == 0} {
1047 set r [lindex $varcrow($v) $a]
1048 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1049 }
1050 }
1051 set vtokmod($v) [lindex $varctok($v) $a]
1052 set varcmod($v) $a
1053 if {$v == $curview} {
1054 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1055 set a [lindex $vupptr($v) $a]
1056 set lim {}
1057 }
1058 set r 0
1059 if {$a != 0} {
1060 if {$lim eq {}} {
1061 set lim [llength $varccommits($v,$a)]
1062 }
1063 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1064 }
1065 set vrowmod($v) $r
1066 undolayout $r
1067 }
1068 }
1069
1070 proc update_arcrows {v} {
1071 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1072 global varcid vrownum varcorder varcix varccommits
1073 global vupptr vdownptr vleftptr varctok
1074 global displayorder parentlist curview cached_commitrow
1075
1076 if {$vrowmod($v) == $commitidx($v)} return
1077 if {$v == $curview} {
1078 if {[llength $displayorder] > $vrowmod($v)} {
1079 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1080 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1081 }
1082 catch {unset cached_commitrow}
1083 }
1084 set narctot [expr {[llength $varctok($v)] - 1}]
1085 set a $varcmod($v)
1086 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1087 # go up the tree until we find something that has a row number,
1088 # or we get to a seed
1089 set a [lindex $vupptr($v) $a]
1090 }
1091 if {$a == 0} {
1092 set a [lindex $vdownptr($v) 0]
1093 if {$a == 0} return
1094 set vrownum($v) {0}
1095 set varcorder($v) [list $a]
1096 lset varcix($v) $a 0
1097 lset varcrow($v) $a 0
1098 set arcn 0
1099 set row 0
1100 } else {
1101 set arcn [lindex $varcix($v) $a]
1102 if {[llength $vrownum($v)] > $arcn + 1} {
1103 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1104 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1105 }
1106 set row [lindex $varcrow($v) $a]
1107 }
1108 while {1} {
1109 set p $a
1110 incr row [llength $varccommits($v,$a)]
1111 # go down if possible
1112 set b [lindex $vdownptr($v) $a]
1113 if {$b == 0} {
1114 # if not, go left, or go up until we can go left
1115 while {$a != 0} {
1116 set b [lindex $vleftptr($v) $a]
1117 if {$b != 0} break
1118 set a [lindex $vupptr($v) $a]
1119 }
1120 if {$a == 0} break
1121 }
1122 set a $b
1123 incr arcn
1124 lappend vrownum($v) $row
1125 lappend varcorder($v) $a
1126 lset varcix($v) $a $arcn
1127 lset varcrow($v) $a $row
1128 }
1129 set vtokmod($v) [lindex $varctok($v) $p]
1130 set varcmod($v) $p
1131 set vrowmod($v) $row
1132 if {[info exists currentid]} {
1133 set selectedline [rowofcommit $currentid]
1134 }
1135 }
1136
1137 # Test whether view $v contains commit $id
1138 proc commitinview {id v} {
1139 global varcid
1140
1141 return [info exists varcid($v,$id)]
1142 }
1143
1144 # Return the row number for commit $id in the current view
1145 proc rowofcommit {id} {
1146 global varcid varccommits varcrow curview cached_commitrow
1147 global varctok vtokmod
1148
1149 set v $curview
1150 if {![info exists varcid($v,$id)]} {
1151 puts "oops rowofcommit no arc for [shortids $id]"
1152 return {}
1153 }
1154 set a $varcid($v,$id)
1155 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1156 update_arcrows $v
1157 }
1158 if {[info exists cached_commitrow($id)]} {
1159 return $cached_commitrow($id)
1160 }
1161 set i [lsearch -exact $varccommits($v,$a) $id]
1162 if {$i < 0} {
1163 puts "oops didn't find commit [shortids $id] in arc $a"
1164 return {}
1165 }
1166 incr i [lindex $varcrow($v) $a]
1167 set cached_commitrow($id) $i
1168 return $i
1169 }
1170
1171 # Returns 1 if a is on an earlier row than b, otherwise 0
1172 proc comes_before {a b} {
1173 global varcid varctok curview
1174
1175 set v $curview
1176 if {$a eq $b || ![info exists varcid($v,$a)] || \
1177 ![info exists varcid($v,$b)]} {
1178 return 0
1179 }
1180 if {$varcid($v,$a) != $varcid($v,$b)} {
1181 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1182 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1183 }
1184 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1185 }
1186
1187 proc bsearch {l elt} {
1188 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1189 return 0
1190 }
1191 set lo 0
1192 set hi [llength $l]
1193 while {$hi - $lo > 1} {
1194 set mid [expr {int(($lo + $hi) / 2)}]
1195 set t [lindex $l $mid]
1196 if {$elt < $t} {
1197 set hi $mid
1198 } elseif {$elt > $t} {
1199 set lo $mid
1200 } else {
1201 return $mid
1202 }
1203 }
1204 return $lo
1205 }
1206
1207 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1208 proc make_disporder {start end} {
1209 global vrownum curview commitidx displayorder parentlist
1210 global varccommits varcorder parents vrowmod varcrow
1211 global d_valid_start d_valid_end
1212
1213 if {$end > $vrowmod($curview)} {
1214 update_arcrows $curview
1215 }
1216 set ai [bsearch $vrownum($curview) $start]
1217 set start [lindex $vrownum($curview) $ai]
1218 set narc [llength $vrownum($curview)]
1219 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1220 set a [lindex $varcorder($curview) $ai]
1221 set l [llength $displayorder]
1222 set al [llength $varccommits($curview,$a)]
1223 if {$l < $r + $al} {
1224 if {$l < $r} {
1225 set pad [ntimes [expr {$r - $l}] {}]
1226 set displayorder [concat $displayorder $pad]
1227 set parentlist [concat $parentlist $pad]
1228 } elseif {$l > $r} {
1229 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1230 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1231 }
1232 foreach id $varccommits($curview,$a) {
1233 lappend displayorder $id
1234 lappend parentlist $parents($curview,$id)
1235 }
1236 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1237 set i $r
1238 foreach id $varccommits($curview,$a) {
1239 lset displayorder $i $id
1240 lset parentlist $i $parents($curview,$id)
1241 incr i
1242 }
1243 }
1244 incr r $al
1245 }
1246 }
1247
1248 proc commitonrow {row} {
1249 global displayorder
1250
1251 set id [lindex $displayorder $row]
1252 if {$id eq {}} {
1253 make_disporder $row [expr {$row + 1}]
1254 set id [lindex $displayorder $row]
1255 }
1256 return $id
1257 }
1258
1259 proc closevarcs {v} {
1260 global varctok varccommits varcid parents children
1261 global cmitlisted commitidx vtokmod
1262
1263 set missing_parents 0
1264 set scripts {}
1265 set narcs [llength $varctok($v)]
1266 for {set a 1} {$a < $narcs} {incr a} {
1267 set id [lindex $varccommits($v,$a) end]
1268 foreach p $parents($v,$id) {
1269 if {[info exists varcid($v,$p)]} continue
1270 # add p as a new commit
1271 incr missing_parents
1272 set cmitlisted($v,$p) 0
1273 set parents($v,$p) {}
1274 if {[llength $children($v,$p)] == 1 &&
1275 [llength $parents($v,$id)] == 1} {
1276 set b $a
1277 } else {
1278 set b [newvarc $v $p]
1279 }
1280 set varcid($v,$p) $b
1281 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1282 modify_arc $v $b
1283 }
1284 lappend varccommits($v,$b) $p
1285 incr commitidx($v)
1286 set scripts [check_interest $p $scripts]
1287 }
1288 }
1289 if {$missing_parents > 0} {
1290 foreach s $scripts {
1291 eval $s
1292 }
1293 }
1294 }
1295
1296 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1297 # Assumes we already have an arc for $rwid.
1298 proc rewrite_commit {v id rwid} {
1299 global children parents varcid varctok vtokmod varccommits
1300
1301 foreach ch $children($v,$id) {
1302 # make $rwid be $ch's parent in place of $id
1303 set i [lsearch -exact $parents($v,$ch) $id]
1304 if {$i < 0} {
1305 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1306 }
1307 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1308 # add $ch to $rwid's children and sort the list if necessary
1309 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1310 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1311 $children($v,$rwid)]
1312 }
1313 # fix the graph after joining $id to $rwid
1314 set a $varcid($v,$ch)
1315 fix_reversal $rwid $a $v
1316 # parentlist is wrong for the last element of arc $a
1317 # even if displayorder is right, hence the 3rd arg here
1318 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1319 }
1320 }
1321
1322 # Mechanism for registering a command to be executed when we come
1323 # across a particular commit. To handle the case when only the
1324 # prefix of the commit is known, the commitinterest array is now
1325 # indexed by the first 4 characters of the ID. Each element is a
1326 # list of id, cmd pairs.
1327 proc interestedin {id cmd} {
1328 global commitinterest
1329
1330 lappend commitinterest([string range $id 0 3]) $id $cmd
1331 }
1332
1333 proc check_interest {id scripts} {
1334 global commitinterest
1335
1336 set prefix [string range $id 0 3]
1337 if {[info exists commitinterest($prefix)]} {
1338 set newlist {}
1339 foreach {i script} $commitinterest($prefix) {
1340 if {[string match "$i*" $id]} {
1341 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1342 } else {
1343 lappend newlist $i $script
1344 }
1345 }
1346 if {$newlist ne {}} {
1347 set commitinterest($prefix) $newlist
1348 } else {
1349 unset commitinterest($prefix)
1350 }
1351 }
1352 return $scripts
1353 }
1354
1355 proc getcommitlines {fd inst view updating} {
1356 global cmitlisted leftover
1357 global commitidx commitdata vdatemode
1358 global parents children curview hlview
1359 global idpending ordertok
1360 global varccommits varcid varctok vtokmod vfilelimit
1361
1362 set stuff [read $fd 500000]
1363 # git log doesn't terminate the last commit with a null...
1364 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1365 set stuff "\0"
1366 }
1367 if {$stuff == {}} {
1368 if {![eof $fd]} {
1369 return 1
1370 }
1371 global commfd viewcomplete viewactive viewname
1372 global viewinstances
1373 unset commfd($inst)
1374 set i [lsearch -exact $viewinstances($view) $inst]
1375 if {$i >= 0} {
1376 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1377 }
1378 # set it blocking so we wait for the process to terminate
1379 fconfigure $fd -blocking 1
1380 if {[catch {close $fd} err]} {
1381 set fv {}
1382 if {$view != $curview} {
1383 set fv " for the \"$viewname($view)\" view"
1384 }
1385 if {[string range $err 0 4] == "usage"} {
1386 set err "Gitk: error reading commits$fv:\
1387 bad arguments to git log."
1388 if {$viewname($view) eq "Command line"} {
1389 append err \
1390 " (Note: arguments to gitk are passed to git log\
1391 to allow selection of commits to be displayed.)"
1392 }
1393 } else {
1394 set err "Error reading commits$fv: $err"
1395 }
1396 error_popup $err
1397 }
1398 if {[incr viewactive($view) -1] <= 0} {
1399 set viewcomplete($view) 1
1400 # Check if we have seen any ids listed as parents that haven't
1401 # appeared in the list
1402 closevarcs $view
1403 notbusy $view
1404 }
1405 if {$view == $curview} {
1406 run chewcommits
1407 }
1408 return 0
1409 }
1410 set start 0
1411 set gotsome 0
1412 set scripts {}
1413 while 1 {
1414 set i [string first "\0" $stuff $start]
1415 if {$i < 0} {
1416 append leftover($inst) [string range $stuff $start end]
1417 break
1418 }
1419 if {$start == 0} {
1420 set cmit $leftover($inst)
1421 append cmit [string range $stuff 0 [expr {$i - 1}]]
1422 set leftover($inst) {}
1423 } else {
1424 set cmit [string range $stuff $start [expr {$i - 1}]]
1425 }
1426 set start [expr {$i + 1}]
1427 set j [string first "\n" $cmit]
1428 set ok 0
1429 set listed 1
1430 if {$j >= 0 && [string match "commit *" $cmit]} {
1431 set ids [string range $cmit 7 [expr {$j - 1}]]
1432 if {[string match {[-^<>]*} $ids]} {
1433 switch -- [string index $ids 0] {
1434 "-" {set listed 0}
1435 "^" {set listed 2}
1436 "<" {set listed 3}
1437 ">" {set listed 4}
1438 }
1439 set ids [string range $ids 1 end]
1440 }
1441 set ok 1
1442 foreach id $ids {
1443 if {[string length $id] != 40} {
1444 set ok 0
1445 break
1446 }
1447 }
1448 }
1449 if {!$ok} {
1450 set shortcmit $cmit
1451 if {[string length $shortcmit] > 80} {
1452 set shortcmit "[string range $shortcmit 0 80]..."
1453 }
1454 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1455 exit 1
1456 }
1457 set id [lindex $ids 0]
1458 set vid $view,$id
1459
1460 if {!$listed && $updating && ![info exists varcid($vid)] &&
1461 $vfilelimit($view) ne {}} {
1462 # git log doesn't rewrite parents for unlisted commits
1463 # when doing path limiting, so work around that here
1464 # by working out the rewritten parent with git rev-list
1465 # and if we already know about it, using the rewritten
1466 # parent as a substitute parent for $id's children.
1467 if {![catch {
1468 set rwid [exec git rev-list --first-parent --max-count=1 \
1469 $id -- $vfilelimit($view)]
1470 }]} {
1471 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1472 # use $rwid in place of $id
1473 rewrite_commit $view $id $rwid
1474 continue
1475 }
1476 }
1477 }
1478
1479 set a 0
1480 if {[info exists varcid($vid)]} {
1481 if {$cmitlisted($vid) || !$listed} continue
1482 set a $varcid($vid)
1483 }
1484 if {$listed} {
1485 set olds [lrange $ids 1 end]
1486 } else {
1487 set olds {}
1488 }
1489 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1490 set cmitlisted($vid) $listed
1491 set parents($vid) $olds
1492 if {![info exists children($vid)]} {
1493 set children($vid) {}
1494 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1495 set k [lindex $children($vid) 0]
1496 if {[llength $parents($view,$k)] == 1 &&
1497 (!$vdatemode($view) ||
1498 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1499 set a $varcid($view,$k)
1500 }
1501 }
1502 if {$a == 0} {
1503 # new arc
1504 set a [newvarc $view $id]
1505 }
1506 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1507 modify_arc $view $a
1508 }
1509 if {![info exists varcid($vid)]} {
1510 set varcid($vid) $a
1511 lappend varccommits($view,$a) $id
1512 incr commitidx($view)
1513 }
1514
1515 set i 0
1516 foreach p $olds {
1517 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1518 set vp $view,$p
1519 if {[llength [lappend children($vp) $id]] > 1 &&
1520 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1521 set children($vp) [lsort -command [list vtokcmp $view] \
1522 $children($vp)]
1523 catch {unset ordertok}
1524 }
1525 if {[info exists varcid($view,$p)]} {
1526 fix_reversal $p $a $view
1527 }
1528 }
1529 incr i
1530 }
1531
1532 set scripts [check_interest $id $scripts]
1533 set gotsome 1
1534 }
1535 if {$gotsome} {
1536 global numcommits hlview
1537
1538 if {$view == $curview} {
1539 set numcommits $commitidx($view)
1540 run chewcommits
1541 }
1542 if {[info exists hlview] && $view == $hlview} {
1543 # we never actually get here...
1544 run vhighlightmore
1545 }
1546 foreach s $scripts {
1547 eval $s
1548 }
1549 }
1550 return 2
1551 }
1552
1553 proc chewcommits {} {
1554 global curview hlview viewcomplete
1555 global pending_select
1556
1557 layoutmore
1558 if {$viewcomplete($curview)} {
1559 global commitidx varctok
1560 global numcommits startmsecs
1561
1562 if {[info exists pending_select]} {
1563 update
1564 reset_pending_select {}
1565
1566 if {[commitinview $pending_select $curview]} {
1567 selectline [rowofcommit $pending_select] 1
1568 } else {
1569 set row [first_real_row]
1570 selectline $row 1
1571 }
1572 }
1573 if {$commitidx($curview) > 0} {
1574 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1575 #puts "overall $ms ms for $numcommits commits"
1576 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1577 } else {
1578 show_status [mc "No commits selected"]
1579 }
1580 notbusy layout
1581 }
1582 return 0
1583 }
1584
1585 proc do_readcommit {id} {
1586 global tclencoding
1587
1588 # Invoke git-log to handle automatic encoding conversion
1589 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1590 # Read the results using i18n.logoutputencoding
1591 fconfigure $fd -translation lf -eofchar {}
1592 if {$tclencoding != {}} {
1593 fconfigure $fd -encoding $tclencoding
1594 }
1595 set contents [read $fd]
1596 close $fd
1597 # Remove the heading line
1598 regsub {^commit [0-9a-f]+\n} $contents {} contents
1599
1600 return $contents
1601 }
1602
1603 proc readcommit {id} {
1604 if {[catch {set contents [do_readcommit $id]}]} return
1605 parsecommit $id $contents 1
1606 }
1607
1608 proc parsecommit {id contents listed} {
1609 global commitinfo cdate
1610
1611 set inhdr 1
1612 set comment {}
1613 set headline {}
1614 set auname {}
1615 set audate {}
1616 set comname {}
1617 set comdate {}
1618 set hdrend [string first "\n\n" $contents]
1619 if {$hdrend < 0} {
1620 # should never happen...
1621 set hdrend [string length $contents]
1622 }
1623 set header [string range $contents 0 [expr {$hdrend - 1}]]
1624 set comment [string range $contents [expr {$hdrend + 2}] end]
1625 foreach line [split $header "\n"] {
1626 set line [split $line " "]
1627 set tag [lindex $line 0]
1628 if {$tag == "author"} {
1629 set audate [lindex $line end-1]
1630 set auname [join [lrange $line 1 end-2] " "]
1631 } elseif {$tag == "committer"} {
1632 set comdate [lindex $line end-1]
1633 set comname [join [lrange $line 1 end-2] " "]
1634 }
1635 }
1636 set headline {}
1637 # take the first non-blank line of the comment as the headline
1638 set headline [string trimleft $comment]
1639 set i [string first "\n" $headline]
1640 if {$i >= 0} {
1641 set headline [string range $headline 0 $i]
1642 }
1643 set headline [string trimright $headline]
1644 set i [string first "\r" $headline]
1645 if {$i >= 0} {
1646 set headline [string trimright [string range $headline 0 $i]]
1647 }
1648 if {!$listed} {
1649 # git log indents the comment by 4 spaces;
1650 # if we got this via git cat-file, add the indentation
1651 set newcomment {}
1652 foreach line [split $comment "\n"] {
1653 append newcomment " "
1654 append newcomment $line
1655 append newcomment "\n"
1656 }
1657 set comment $newcomment
1658 }
1659 if {$comdate != {}} {
1660 set cdate($id) $comdate
1661 }
1662 set commitinfo($id) [list $headline $auname $audate \
1663 $comname $comdate $comment]
1664 }
1665
1666 proc getcommit {id} {
1667 global commitdata commitinfo
1668
1669 if {[info exists commitdata($id)]} {
1670 parsecommit $id $commitdata($id) 1
1671 } else {
1672 readcommit $id
1673 if {![info exists commitinfo($id)]} {
1674 set commitinfo($id) [list [mc "No commit information available"]]
1675 }
1676 }
1677 return 1
1678 }
1679
1680 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1681 # and are present in the current view.
1682 # This is fairly slow...
1683 proc longid {prefix} {
1684 global varcid curview
1685
1686 set ids {}
1687 foreach match [array names varcid "$curview,$prefix*"] {
1688 lappend ids [lindex [split $match ","] 1]
1689 }
1690 return $ids
1691 }
1692
1693 proc readrefs {} {
1694 global tagids idtags headids idheads tagobjid
1695 global otherrefids idotherrefs mainhead mainheadid
1696 global selecthead selectheadid
1697 global hideremotes
1698
1699 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1700 catch {unset $v}
1701 }
1702 set refd [open [list | git show-ref -d] r]
1703 while {[gets $refd line] >= 0} {
1704 if {[string index $line 40] ne " "} continue
1705 set id [string range $line 0 39]
1706 set ref [string range $line 41 end]
1707 if {![string match "refs/*" $ref]} continue
1708 set name [string range $ref 5 end]
1709 if {[string match "remotes/*" $name]} {
1710 if {![string match "*/HEAD" $name] && !$hideremotes} {
1711 set headids($name) $id
1712 lappend idheads($id) $name
1713 }
1714 } elseif {[string match "heads/*" $name]} {
1715 set name [string range $name 6 end]
1716 set headids($name) $id
1717 lappend idheads($id) $name
1718 } elseif {[string match "tags/*" $name]} {
1719 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1720 # which is what we want since the former is the commit ID
1721 set name [string range $name 5 end]
1722 if {[string match "*^{}" $name]} {
1723 set name [string range $name 0 end-3]
1724 } else {
1725 set tagobjid($name) $id
1726 }
1727 set tagids($name) $id
1728 lappend idtags($id) $name
1729 } else {
1730 set otherrefids($name) $id
1731 lappend idotherrefs($id) $name
1732 }
1733 }
1734 catch {close $refd}
1735 set mainhead {}
1736 set mainheadid {}
1737 catch {
1738 set mainheadid [exec git rev-parse HEAD]
1739 set thehead [exec git symbolic-ref HEAD]
1740 if {[string match "refs/heads/*" $thehead]} {
1741 set mainhead [string range $thehead 11 end]
1742 }
1743 }
1744 set selectheadid {}
1745 if {$selecthead ne {}} {
1746 catch {
1747 set selectheadid [exec git rev-parse --verify $selecthead]
1748 }
1749 }
1750 }
1751
1752 # skip over fake commits
1753 proc first_real_row {} {
1754 global nullid nullid2 numcommits
1755
1756 for {set row 0} {$row < $numcommits} {incr row} {
1757 set id [commitonrow $row]
1758 if {$id ne $nullid && $id ne $nullid2} {
1759 break
1760 }
1761 }
1762 return $row
1763 }
1764
1765 # update things for a head moved to a child of its previous location
1766 proc movehead {id name} {
1767 global headids idheads
1768
1769 removehead $headids($name) $name
1770 set headids($name) $id
1771 lappend idheads($id) $name
1772 }
1773
1774 # update things when a head has been removed
1775 proc removehead {id name} {
1776 global headids idheads
1777
1778 if {$idheads($id) eq $name} {
1779 unset idheads($id)
1780 } else {
1781 set i [lsearch -exact $idheads($id) $name]
1782 if {$i >= 0} {
1783 set idheads($id) [lreplace $idheads($id) $i $i]
1784 }
1785 }
1786 unset headids($name)
1787 }
1788
1789 proc ttk_toplevel {w args} {
1790 global use_ttk
1791 eval [linsert $args 0 ::toplevel $w]
1792 if {$use_ttk} {
1793 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1794 }
1795 return $w
1796 }
1797
1798 proc make_transient {window origin} {
1799 global have_tk85
1800
1801 # In MacOS Tk 8.4 transient appears to work by setting
1802 # overrideredirect, which is utterly useless, since the
1803 # windows get no border, and are not even kept above
1804 # the parent.
1805 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1806
1807 wm transient $window $origin
1808
1809 # Windows fails to place transient windows normally, so
1810 # schedule a callback to center them on the parent.
1811 if {[tk windowingsystem] eq {win32}} {
1812 after idle [list tk::PlaceWindow $window widget $origin]
1813 }
1814 }
1815
1816 proc show_error {w top msg {mc mc}} {
1817 global NS
1818 if {![info exists NS]} {set NS ""}
1819 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1820 message $w.m -text $msg -justify center -aspect 400
1821 pack $w.m -side top -fill x -padx 20 -pady 20
1822 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1823 pack $w.ok -side bottom -fill x
1824 bind $top <Visibility> "grab $top; focus $top"
1825 bind $top <Key-Return> "destroy $top"
1826 bind $top <Key-space> "destroy $top"
1827 bind $top <Key-Escape> "destroy $top"
1828 tkwait window $top
1829 }
1830
1831 proc error_popup {msg {owner .}} {
1832 if {[tk windowingsystem] eq "win32"} {
1833 tk_messageBox -icon error -type ok -title [wm title .] \
1834 -parent $owner -message $msg
1835 } else {
1836 set w .error
1837 ttk_toplevel $w
1838 make_transient $w $owner
1839 show_error $w $w $msg
1840 }
1841 }
1842
1843 proc confirm_popup {msg {owner .}} {
1844 global confirm_ok NS
1845 set confirm_ok 0
1846 set w .confirm
1847 ttk_toplevel $w
1848 make_transient $w $owner
1849 message $w.m -text $msg -justify center -aspect 400
1850 pack $w.m -side top -fill x -padx 20 -pady 20
1851 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1852 pack $w.ok -side left -fill x
1853 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1854 pack $w.cancel -side right -fill x
1855 bind $w <Visibility> "grab $w; focus $w"
1856 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1857 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1858 bind $w <Key-Escape> "destroy $w"
1859 tk::PlaceWindow $w widget $owner
1860 tkwait window $w
1861 return $confirm_ok
1862 }
1863
1864 proc setoptions {} {
1865 if {[tk windowingsystem] ne "win32"} {
1866 option add *Panedwindow.showHandle 1 startupFile
1867 option add *Panedwindow.sashRelief raised startupFile
1868 if {[tk windowingsystem] ne "aqua"} {
1869 option add *Menu.font uifont startupFile
1870 }
1871 } else {
1872 option add *Menu.TearOff 0 startupFile
1873 }
1874 option add *Button.font uifont startupFile
1875 option add *Checkbutton.font uifont startupFile
1876 option add *Radiobutton.font uifont startupFile
1877 option add *Menubutton.font uifont startupFile
1878 option add *Label.font uifont startupFile
1879 option add *Message.font uifont startupFile
1880 option add *Entry.font uifont startupFile
1881 option add *Labelframe.font uifont startupFile
1882 }
1883
1884 # Make a menu and submenus.
1885 # m is the window name for the menu, items is the list of menu items to add.
1886 # Each item is a list {mc label type description options...}
1887 # mc is ignored; it's so we can put mc there to alert xgettext
1888 # label is the string that appears in the menu
1889 # type is cascade, command or radiobutton (should add checkbutton)
1890 # description depends on type; it's the sublist for cascade, the
1891 # command to invoke for command, or {variable value} for radiobutton
1892 proc makemenu {m items} {
1893 menu $m
1894 if {[tk windowingsystem] eq {aqua}} {
1895 set Meta1 Cmd
1896 } else {
1897 set Meta1 Ctrl
1898 }
1899 foreach i $items {
1900 set name [mc [lindex $i 1]]
1901 set type [lindex $i 2]
1902 set thing [lindex $i 3]
1903 set params [list $type]
1904 if {$name ne {}} {
1905 set u [string first "&" [string map {&& x} $name]]
1906 lappend params -label [string map {&& & & {}} $name]
1907 if {$u >= 0} {
1908 lappend params -underline $u
1909 }
1910 }
1911 switch -- $type {
1912 "cascade" {
1913 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1914 lappend params -menu $m.$submenu
1915 }
1916 "command" {
1917 lappend params -command $thing
1918 }
1919 "radiobutton" {
1920 lappend params -variable [lindex $thing 0] \
1921 -value [lindex $thing 1]
1922 }
1923 }
1924 set tail [lrange $i 4 end]
1925 regsub -all {\yMeta1\y} $tail $Meta1 tail
1926 eval $m add $params $tail
1927 if {$type eq "cascade"} {
1928 makemenu $m.$submenu $thing
1929 }
1930 }
1931 }
1932
1933 # translate string and remove ampersands
1934 proc mca {str} {
1935 return [string map {&& & & {}} [mc $str]]
1936 }
1937
1938 proc makedroplist {w varname args} {
1939 global use_ttk
1940 if {$use_ttk} {
1941 set width 0
1942 foreach label $args {
1943 set cx [string length $label]
1944 if {$cx > $width} {set width $cx}
1945 }
1946 set gm [ttk::combobox $w -width $width -state readonly\
1947 -textvariable $varname -values $args]
1948 } else {
1949 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1950 }
1951 return $gm
1952 }
1953
1954 proc makewindow {} {
1955 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1956 global tabstop
1957 global findtype findtypemenu findloc findstring fstring geometry
1958 global entries sha1entry sha1string sha1but
1959 global diffcontextstring diffcontext
1960 global ignorespace
1961 global maincursor textcursor curtextcursor
1962 global rowctxmenu fakerowmenu mergemax wrapcomment
1963 global highlight_files gdttype
1964 global searchstring sstring
1965 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1966 global headctxmenu progresscanv progressitem progresscoords statusw
1967 global fprogitem fprogcoord lastprogupdate progupdatepending
1968 global rprogitem rprogcoord rownumsel numcommits
1969 global have_tk85 use_ttk NS
1970
1971 # The "mc" arguments here are purely so that xgettext
1972 # sees the following string as needing to be translated
1973 set file {
1974 mc "File" cascade {
1975 {mc "Update" command updatecommits -accelerator F5}
1976 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1977 {mc "Reread references" command rereadrefs}
1978 {mc "List references" command showrefs -accelerator F2}
1979 {xx "" separator}
1980 {mc "Start git gui" command {exec git gui &}}
1981 {xx "" separator}
1982 {mc "Quit" command doquit -accelerator Meta1-Q}
1983 }}
1984 set edit {
1985 mc "Edit" cascade {
1986 {mc "Preferences" command doprefs}
1987 }}
1988 set view {
1989 mc "View" cascade {
1990 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1991 {mc "Edit view..." command editview -state disabled -accelerator F4}
1992 {mc "Delete view" command delview -state disabled}
1993 {xx "" separator}
1994 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1995 }}
1996 if {[tk windowingsystem] ne "aqua"} {
1997 set help {
1998 mc "Help" cascade {
1999 {mc "About gitk" command about}
2000 {mc "Key bindings" command keys}
2001 }}
2002 set bar [list $file $edit $view $help]
2003 } else {
2004 proc ::tk::mac::ShowPreferences {} {doprefs}
2005 proc ::tk::mac::Quit {} {doquit}
2006 lset file end [lreplace [lindex $file end] end-1 end]
2007 set apple {
2008 xx "Apple" cascade {
2009 {mc "About gitk" command about}
2010 {xx "" separator}
2011 }}
2012 set help {
2013 mc "Help" cascade {
2014 {mc "Key bindings" command keys}
2015 }}
2016 set bar [list $apple $file $view $help]
2017 }
2018 makemenu .bar $bar
2019 . configure -menu .bar
2020
2021 if {$use_ttk} {
2022 # cover the non-themed toplevel with a themed frame.
2023 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2024 }
2025
2026 # the gui has upper and lower half, parts of a paned window.
2027 ${NS}::panedwindow .ctop -orient vertical
2028
2029 # possibly use assumed geometry
2030 if {![info exists geometry(pwsash0)]} {
2031 set geometry(topheight) [expr {15 * $linespc}]
2032 set geometry(topwidth) [expr {80 * $charspc}]
2033 set geometry(botheight) [expr {15 * $linespc}]
2034 set geometry(botwidth) [expr {50 * $charspc}]
2035 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2036 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2037 }
2038
2039 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2040 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2041 ${NS}::frame .tf.histframe
2042 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2043 if {!$use_ttk} {
2044 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2045 }
2046
2047 # create three canvases
2048 set cscroll .tf.histframe.csb
2049 set canv .tf.histframe.pwclist.canv
2050 canvas $canv \
2051 -selectbackground $selectbgcolor \
2052 -background $bgcolor -bd 0 \
2053 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2054 .tf.histframe.pwclist add $canv
2055 set canv2 .tf.histframe.pwclist.canv2
2056 canvas $canv2 \
2057 -selectbackground $selectbgcolor \
2058 -background $bgcolor -bd 0 -yscrollincr $linespc
2059 .tf.histframe.pwclist add $canv2
2060 set canv3 .tf.histframe.pwclist.canv3
2061 canvas $canv3 \
2062 -selectbackground $selectbgcolor \
2063 -background $bgcolor -bd 0 -yscrollincr $linespc
2064 .tf.histframe.pwclist add $canv3
2065 if {$use_ttk} {
2066 bind .tf.histframe.pwclist <Map> {
2067 bind %W <Map> {}
2068 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2069 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2070 }
2071 } else {
2072 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2073 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2074 }
2075
2076 # a scroll bar to rule them
2077 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2078 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2079 pack $cscroll -side right -fill y
2080 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2081 lappend bglist $canv $canv2 $canv3
2082 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2083
2084 # we have two button bars at bottom of top frame. Bar 1
2085 ${NS}::frame .tf.bar
2086 ${NS}::frame .tf.lbar -height 15
2087
2088 set sha1entry .tf.bar.sha1
2089 set entries $sha1entry
2090 set sha1but .tf.bar.sha1label
2091 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2092 -command gotocommit -width 8
2093 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2094 pack .tf.bar.sha1label -side left
2095 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2096 trace add variable sha1string write sha1change
2097 pack $sha1entry -side left -pady 2
2098
2099 image create bitmap bm-left -data {
2100 #define left_width 16
2101 #define left_height 16
2102 static unsigned char left_bits[] = {
2103 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2104 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2105 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2106 }
2107 image create bitmap bm-right -data {
2108 #define right_width 16
2109 #define right_height 16
2110 static unsigned char right_bits[] = {
2111 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2112 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2113 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2114 }
2115 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2116 -state disabled -width 26
2117 pack .tf.bar.leftbut -side left -fill y
2118 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2119 -state disabled -width 26
2120 pack .tf.bar.rightbut -side left -fill y
2121
2122 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2123 set rownumsel {}
2124 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2125 -relief sunken -anchor e
2126 ${NS}::label .tf.bar.rowlabel2 -text "/"
2127 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2128 -relief sunken -anchor e
2129 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2130 -side left
2131 if {!$use_ttk} {
2132 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2133 }
2134 global selectedline
2135 trace add variable selectedline write selectedline_change
2136
2137 # Status label and progress bar
2138 set statusw .tf.bar.status
2139 ${NS}::label $statusw -width 15 -relief sunken
2140 pack $statusw -side left -padx 5
2141 if {$use_ttk} {
2142 set progresscanv [ttk::progressbar .tf.bar.progress]
2143 } else {
2144 set h [expr {[font metrics uifont -linespace] + 2}]
2145 set progresscanv .tf.bar.progress
2146 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2147 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2148 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2149 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2150 }
2151 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2152 set progresscoords {0 0}
2153 set fprogcoord 0
2154 set rprogcoord 0
2155 bind $progresscanv <Configure> adjustprogress
2156 set lastprogupdate [clock clicks -milliseconds]
2157 set progupdatepending 0
2158
2159 # build up the bottom bar of upper window
2160 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2161 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2162 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2163 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2164 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2165 -side left -fill y
2166 set gdttype [mc "containing:"]
2167 set gm [makedroplist .tf.lbar.gdttype gdttype \
2168 [mc "containing:"] \
2169 [mc "touching paths:"] \
2170 [mc "adding/removing string:"]]
2171 trace add variable gdttype write gdttype_change
2172 pack .tf.lbar.gdttype -side left -fill y
2173
2174 set findstring {}
2175 set fstring .tf.lbar.findstring
2176 lappend entries $fstring
2177 ${NS}::entry $fstring -width 30 -font textfont -textvariable findstring
2178 trace add variable findstring write find_change
2179 set findtype [mc "Exact"]
2180 set findtypemenu [makedroplist .tf.lbar.findtype \
2181 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2182 trace add variable findtype write findcom_change
2183 set findloc [mc "All fields"]
2184 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2185 [mc "Comments"] [mc "Author"] [mc "Committer"]
2186 trace add variable findloc write find_change
2187 pack .tf.lbar.findloc -side right
2188 pack .tf.lbar.findtype -side right
2189 pack $fstring -side left -expand 1 -fill x
2190
2191 # Finish putting the upper half of the viewer together
2192 pack .tf.lbar -in .tf -side bottom -fill x
2193 pack .tf.bar -in .tf -side bottom -fill x
2194 pack .tf.histframe -fill both -side top -expand 1
2195 .ctop add .tf
2196 if {!$use_ttk} {
2197 .ctop paneconfigure .tf -height $geometry(topheight)
2198 .ctop paneconfigure .tf -width $geometry(topwidth)
2199 }
2200
2201 # now build up the bottom
2202 ${NS}::panedwindow .pwbottom -orient horizontal
2203
2204 # lower left, a text box over search bar, scroll bar to the right
2205 # if we know window height, then that will set the lower text height, otherwise
2206 # we set lower text height which will drive window height
2207 if {[info exists geometry(main)]} {
2208 ${NS}::frame .bleft -width $geometry(botwidth)
2209 } else {
2210 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2211 }
2212 ${NS}::frame .bleft.top
2213 ${NS}::frame .bleft.mid
2214 ${NS}::frame .bleft.bottom
2215
2216 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2217 pack .bleft.top.search -side left -padx 5
2218 set sstring .bleft.top.sstring
2219 set searchstring ""
2220 ${NS}::entry $sstring -width 20 -font textfont -textvariable searchstring
2221 lappend entries $sstring
2222 trace add variable searchstring write incrsearch
2223 pack $sstring -side left -expand 1 -fill x
2224 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2225 -command changediffdisp -variable diffelide -value {0 0}
2226 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2227 -command changediffdisp -variable diffelide -value {0 1}
2228 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2229 -command changediffdisp -variable diffelide -value {1 0}
2230 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2231 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2232 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2233 -from 0 -increment 1 -to 10000000 \
2234 -validate all -validatecommand "diffcontextvalidate %P" \
2235 -textvariable diffcontextstring
2236 .bleft.mid.diffcontext set $diffcontext
2237 trace add variable diffcontextstring write diffcontextchange
2238 lappend entries .bleft.mid.diffcontext
2239 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2240 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2241 -command changeignorespace -variable ignorespace
2242 pack .bleft.mid.ignspace -side left -padx 5
2243 set ctext .bleft.bottom.ctext
2244 text $ctext -background $bgcolor -foreground $fgcolor \
2245 -state disabled -font textfont \
2246 -yscrollcommand scrolltext -wrap none \
2247 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2248 if {$have_tk85} {
2249 $ctext conf -tabstyle wordprocessor
2250 }
2251 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2252 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2253 pack .bleft.top -side top -fill x
2254 pack .bleft.mid -side top -fill x
2255 grid $ctext .bleft.bottom.sb -sticky nsew
2256 grid .bleft.bottom.sbhorizontal -sticky ew
2257 grid columnconfigure .bleft.bottom 0 -weight 1
2258 grid rowconfigure .bleft.bottom 0 -weight 1
2259 grid rowconfigure .bleft.bottom 1 -weight 0
2260 pack .bleft.bottom -side top -fill both -expand 1
2261 lappend bglist $ctext
2262 lappend fglist $ctext
2263
2264 $ctext tag conf comment -wrap $wrapcomment
2265 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2266 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2267 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2268 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2269 $ctext tag conf m0 -fore red
2270 $ctext tag conf m1 -fore blue
2271 $ctext tag conf m2 -fore green
2272 $ctext tag conf m3 -fore purple
2273 $ctext tag conf m4 -fore brown
2274 $ctext tag conf m5 -fore "#009090"
2275 $ctext tag conf m6 -fore magenta
2276 $ctext tag conf m7 -fore "#808000"
2277 $ctext tag conf m8 -fore "#009000"
2278 $ctext tag conf m9 -fore "#ff0080"
2279 $ctext tag conf m10 -fore cyan
2280 $ctext tag conf m11 -fore "#b07070"
2281 $ctext tag conf m12 -fore "#70b0f0"
2282 $ctext tag conf m13 -fore "#70f0b0"
2283 $ctext tag conf m14 -fore "#f0b070"
2284 $ctext tag conf m15 -fore "#ff70b0"
2285 $ctext tag conf mmax -fore darkgrey
2286 set mergemax 16
2287 $ctext tag conf mresult -font textfontbold
2288 $ctext tag conf msep -font textfontbold
2289 $ctext tag conf found -back yellow
2290
2291 .pwbottom add .bleft
2292 if {!$use_ttk} {
2293 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2294 }
2295
2296 # lower right
2297 ${NS}::frame .bright
2298 ${NS}::frame .bright.mode
2299 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2300 -command reselectline -variable cmitmode -value "patch"
2301 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2302 -command reselectline -variable cmitmode -value "tree"
2303 grid .bright.mode.patch .bright.mode.tree -sticky ew
2304 pack .bright.mode -side top -fill x
2305 set cflist .bright.cfiles
2306 set indent [font measure mainfont "nn"]
2307 text $cflist \
2308 -selectbackground $selectbgcolor \
2309 -background $bgcolor -foreground $fgcolor \
2310 -font mainfont \
2311 -tabs [list $indent [expr {2 * $indent}]] \
2312 -yscrollcommand ".bright.sb set" \
2313 -cursor [. cget -cursor] \
2314 -spacing1 1 -spacing3 1
2315 lappend bglist $cflist
2316 lappend fglist $cflist
2317 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2318 pack .bright.sb -side right -fill y
2319 pack $cflist -side left -fill both -expand 1
2320 $cflist tag configure highlight \
2321 -background [$cflist cget -selectbackground]
2322 $cflist tag configure bold -font mainfontbold
2323
2324 .pwbottom add .bright
2325 .ctop add .pwbottom
2326
2327 # restore window width & height if known
2328 if {[info exists geometry(main)]} {
2329 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2330 if {$w > [winfo screenwidth .]} {
2331 set w [winfo screenwidth .]
2332 }
2333 if {$h > [winfo screenheight .]} {
2334 set h [winfo screenheight .]
2335 }
2336 wm geometry . "${w}x$h"
2337 }
2338 }
2339
2340 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2341 wm state . $geometry(state)
2342 }
2343
2344 if {[tk windowingsystem] eq {aqua}} {
2345 set M1B M1
2346 set ::BM "3"
2347 } else {
2348 set M1B Control
2349 set ::BM "2"
2350 }
2351
2352 if {$use_ttk} {
2353 bind .ctop <Map> {
2354 bind %W <Map> {}
2355 %W sashpos 0 $::geometry(topheight)
2356 }
2357 bind .pwbottom <Map> {
2358 bind %W <Map> {}
2359 %W sashpos 0 $::geometry(botwidth)
2360 }
2361 }
2362
2363 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2364 pack .ctop -fill both -expand 1
2365 bindall <1> {selcanvline %W %x %y}
2366 #bindall <B1-Motion> {selcanvline %W %x %y}
2367 if {[tk windowingsystem] == "win32"} {
2368 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2369 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2370 } else {
2371 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2372 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2373 if {[tk windowingsystem] eq "aqua"} {
2374 bindall <MouseWheel> {
2375 set delta [expr {- (%D)}]
2376 allcanvs yview scroll $delta units
2377 }
2378 bindall <Shift-MouseWheel> {
2379 set delta [expr {- (%D)}]
2380 $canv xview scroll $delta units
2381 }
2382 }
2383 }
2384 bindall <$::BM> "canvscan mark %W %x %y"
2385 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2386 bindkey <Home> selfirstline
2387 bindkey <End> sellastline
2388 bind . <Key-Up> "selnextline -1"
2389 bind . <Key-Down> "selnextline 1"
2390 bind . <Shift-Key-Up> "dofind -1 0"
2391 bind . <Shift-Key-Down> "dofind 1 0"
2392 bindkey <Key-Right> "goforw"
2393 bindkey <Key-Left> "goback"
2394 bind . <Key-Prior> "selnextpage -1"
2395 bind . <Key-Next> "selnextpage 1"
2396 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2397 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2398 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2399 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2400 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2401 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2402 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2403 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2404 bindkey <Key-space> "$ctext yview scroll 1 pages"
2405 bindkey p "selnextline -1"
2406 bindkey n "selnextline 1"
2407 bindkey z "goback"
2408 bindkey x "goforw"
2409 bindkey i "selnextline -1"
2410 bindkey k "selnextline 1"
2411 bindkey j "goback"
2412 bindkey l "goforw"
2413 bindkey b prevfile
2414 bindkey d "$ctext yview scroll 18 units"
2415 bindkey u "$ctext yview scroll -18 units"
2416 bindkey / {focus $fstring}
2417 bindkey <Key-KP_Divide> {focus $fstring}
2418 bindkey <Key-Return> {dofind 1 1}
2419 bindkey ? {dofind -1 1}
2420 bindkey f nextfile
2421 bind . <F5> updatecommits
2422 bind . <$M1B-F5> reloadcommits
2423 bind . <F2> showrefs
2424 bind . <Shift-F4> {newview 0}
2425 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2426 bind . <F4> edit_or_newview
2427 bind . <$M1B-q> doquit
2428 bind . <$M1B-f> {dofind 1 1}
2429 bind . <$M1B-g> {dofind 1 0}
2430 bind . <$M1B-r> dosearchback
2431 bind . <$M1B-s> dosearch
2432 bind . <$M1B-equal> {incrfont 1}
2433 bind . <$M1B-plus> {incrfont 1}
2434 bind . <$M1B-KP_Add> {incrfont 1}
2435 bind . <$M1B-minus> {incrfont -1}
2436 bind . <$M1B-KP_Subtract> {incrfont -1}
2437 wm protocol . WM_DELETE_WINDOW doquit
2438 bind . <Destroy> {stop_backends}
2439 bind . <Button-1> "click %W"
2440 bind $fstring <Key-Return> {dofind 1 1}
2441 bind $sha1entry <Key-Return> {gotocommit; break}
2442 bind $sha1entry <<PasteSelection>> clearsha1
2443 bind $cflist <1> {sel_flist %W %x %y; break}
2444 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2445 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2446 global ctxbut
2447 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2448 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2449
2450 set maincursor [. cget -cursor]
2451 set textcursor [$ctext cget -cursor]
2452 set curtextcursor $textcursor
2453
2454 set rowctxmenu .rowctxmenu
2455 makemenu $rowctxmenu {
2456 {mc "Diff this -> selected" command {diffvssel 0}}
2457 {mc "Diff selected -> this" command {diffvssel 1}}
2458 {mc "Make patch" command mkpatch}
2459 {mc "Create tag" command mktag}
2460 {mc "Write commit to file" command writecommit}
2461 {mc "Create new branch" command mkbranch}
2462 {mc "Cherry-pick this commit" command cherrypick}
2463 {mc "Reset HEAD branch to here" command resethead}
2464 {mc "Mark this commit" command markhere}
2465 {mc "Return to mark" command gotomark}
2466 {mc "Find descendant of this and mark" command find_common_desc}
2467 {mc "Compare with marked commit" command compare_commits}
2468 }
2469 $rowctxmenu configure -tearoff 0
2470
2471 set fakerowmenu .fakerowmenu
2472 makemenu $fakerowmenu {
2473 {mc "Diff this -> selected" command {diffvssel 0}}
2474 {mc "Diff selected -> this" command {diffvssel 1}}
2475 {mc "Make patch" command mkpatch}
2476 }
2477 $fakerowmenu configure -tearoff 0
2478
2479 set headctxmenu .headctxmenu
2480 makemenu $headctxmenu {
2481 {mc "Check out this branch" command cobranch}
2482 {mc "Remove this branch" command rmbranch}
2483 }
2484 $headctxmenu configure -tearoff 0
2485
2486 global flist_menu
2487 set flist_menu .flistctxmenu
2488 makemenu $flist_menu {
2489 {mc "Highlight this too" command {flist_hl 0}}
2490 {mc "Highlight this only" command {flist_hl 1}}
2491 {mc "External diff" command {external_diff}}
2492 {mc "Blame parent commit" command {external_blame 1}}
2493 }
2494 $flist_menu configure -tearoff 0
2495
2496 global diff_menu
2497 set diff_menu .diffctxmenu
2498 makemenu $diff_menu {
2499 {mc "Show origin of this line" command show_line_source}
2500 {mc "Run git gui blame on this line" command {external_blame_diff}}
2501 }
2502 $diff_menu configure -tearoff 0
2503 }
2504
2505 # Windows sends all mouse wheel events to the current focused window, not
2506 # the one where the mouse hovers, so bind those events here and redirect
2507 # to the correct window
2508 proc windows_mousewheel_redirector {W X Y D} {
2509 global canv canv2 canv3
2510 set w [winfo containing -displayof $W $X $Y]
2511 if {$w ne ""} {
2512 set u [expr {$D < 0 ? 5 : -5}]
2513 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2514 allcanvs yview scroll $u units
2515 } else {
2516 catch {
2517 $w yview scroll $u units
2518 }
2519 }
2520 }
2521 }
2522
2523 # Update row number label when selectedline changes
2524 proc selectedline_change {n1 n2 op} {
2525 global selectedline rownumsel
2526
2527 if {$selectedline eq {}} {
2528 set rownumsel {}
2529 } else {
2530 set rownumsel [expr {$selectedline + 1}]
2531 }
2532 }
2533
2534 # mouse-2 makes all windows scan vertically, but only the one
2535 # the cursor is in scans horizontally
2536 proc canvscan {op w x y} {
2537 global canv canv2 canv3
2538 foreach c [list $canv $canv2 $canv3] {
2539 if {$c == $w} {
2540 $c scan $op $x $y
2541 } else {
2542 $c scan $op 0 $y
2543 }
2544 }
2545 }
2546
2547 proc scrollcanv {cscroll f0 f1} {
2548 $cscroll set $f0 $f1
2549 drawvisible
2550 flushhighlights
2551 }
2552
2553 # when we make a key binding for the toplevel, make sure
2554 # it doesn't get triggered when that key is pressed in the
2555 # find string entry widget.
2556 proc bindkey {ev script} {
2557 global entries
2558 bind . $ev $script
2559 set escript [bind Entry $ev]
2560 if {$escript == {}} {
2561 set escript [bind Entry <Key>]
2562 }
2563 foreach e $entries {
2564 bind $e $ev "$escript; break"
2565 }
2566 }
2567
2568 # set the focus back to the toplevel for any click outside
2569 # the entry widgets
2570 proc click {w} {
2571 global ctext entries
2572 foreach e [concat $entries $ctext] {
2573 if {$w == $e} return
2574 }
2575 focus .
2576 }
2577
2578 # Adjust the progress bar for a change in requested extent or canvas size
2579 proc adjustprogress {} {
2580 global progresscanv progressitem progresscoords
2581 global fprogitem fprogcoord lastprogupdate progupdatepending
2582 global rprogitem rprogcoord use_ttk
2583
2584 if {$use_ttk} {
2585 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2586 return
2587 }
2588
2589 set w [expr {[winfo width $progresscanv] - 4}]
2590 set x0 [expr {$w * [lindex $progresscoords 0]}]
2591 set x1 [expr {$w * [lindex $progresscoords 1]}]
2592 set h [winfo height $progresscanv]
2593 $progresscanv coords $progressitem $x0 0 $x1 $h
2594 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2595 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2596 set now [clock clicks -milliseconds]
2597 if {$now >= $lastprogupdate + 100} {
2598 set progupdatepending 0
2599 update
2600 } elseif {!$progupdatepending} {
2601 set progupdatepending 1
2602 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2603 }
2604 }
2605
2606 proc doprogupdate {} {
2607 global lastprogupdate progupdatepending
2608
2609 if {$progupdatepending} {
2610 set progupdatepending 0
2611 set lastprogupdate [clock clicks -milliseconds]
2612 update
2613 }
2614 }
2615
2616 proc savestuff {w} {
2617 global canv canv2 canv3 mainfont textfont uifont tabstop
2618 global stuffsaved findmergefiles maxgraphpct
2619 global maxwidth showneartags showlocalchanges
2620 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2621 global cmitmode wrapcomment datetimeformat limitdiffs
2622 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2623 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2624 global hideremotes want_ttk
2625
2626 if {$stuffsaved} return
2627 if {![winfo viewable .]} return
2628 catch {
2629 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2630 set f [open "~/.gitk-new" w]
2631 if {$::tcl_platform(platform) eq {windows}} {
2632 file attributes "~/.gitk-new" -hidden true
2633 }
2634 puts $f [list set mainfont $mainfont]
2635 puts $f [list set textfont $textfont]
2636 puts $f [list set uifont $uifont]
2637 puts $f [list set tabstop $tabstop]
2638 puts $f [list set findmergefiles $findmergefiles]
2639 puts $f [list set maxgraphpct $maxgraphpct]
2640 puts $f [list set maxwidth $maxwidth]
2641 puts $f [list set cmitmode $cmitmode]
2642 puts $f [list set wrapcomment $wrapcomment]
2643 puts $f [list set autoselect $autoselect]
2644 puts $f [list set showneartags $showneartags]
2645 puts $f [list set hideremotes $hideremotes]
2646 puts $f [list set showlocalchanges $showlocalchanges]
2647 puts $f [list set datetimeformat $datetimeformat]
2648 puts $f [list set limitdiffs $limitdiffs]
2649 puts $f [list set uicolor $uicolor]
2650 puts $f [list set want_ttk $want_ttk]
2651 puts $f [list set bgcolor $bgcolor]
2652 puts $f [list set fgcolor $fgcolor]
2653 puts $f [list set colors $colors]
2654 puts $f [list set diffcolors $diffcolors]
2655 puts $f [list set markbgcolor $markbgcolor]
2656 puts $f [list set diffcontext $diffcontext]
2657 puts $f [list set selectbgcolor $selectbgcolor]
2658 puts $f [list set extdifftool $extdifftool]
2659 puts $f [list set perfile_attrs $perfile_attrs]
2660
2661 puts $f "set geometry(main) [wm geometry .]"
2662 puts $f "set geometry(state) [wm state .]"
2663 puts $f "set geometry(topwidth) [winfo width .tf]"
2664 puts $f "set geometry(topheight) [winfo height .tf]"
2665 if {$use_ttk} {
2666 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2667 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2668 } else {
2669 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2670 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2671 }
2672 puts $f "set geometry(botwidth) [winfo width .bleft]"
2673 puts $f "set geometry(botheight) [winfo height .bleft]"
2674
2675 puts -nonewline $f "set permviews {"
2676 for {set v 0} {$v < $nextviewnum} {incr v} {
2677 if {$viewperm($v)} {
2678 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2679 }
2680 }
2681 puts $f "}"
2682 close $f
2683 file rename -force "~/.gitk-new" "~/.gitk"
2684 }
2685 set stuffsaved 1
2686 }
2687
2688 proc resizeclistpanes {win w} {
2689 global oldwidth use_ttk
2690 if {[info exists oldwidth($win)]} {
2691 if {$use_ttk} {
2692 set s0 [$win sashpos 0]
2693 set s1 [$win sashpos 1]
2694 } else {
2695 set s0 [$win sash coord 0]
2696 set s1 [$win sash coord 1]
2697 }
2698 if {$w < 60} {
2699 set sash0 [expr {int($w/2 - 2)}]
2700 set sash1 [expr {int($w*5/6 - 2)}]
2701 } else {
2702 set factor [expr {1.0 * $w / $oldwidth($win)}]
2703 set sash0 [expr {int($factor * [lindex $s0 0])}]
2704 set sash1 [expr {int($factor * [lindex $s1 0])}]
2705 if {$sash0 < 30} {
2706 set sash0 30
2707 }
2708 if {$sash1 < $sash0 + 20} {
2709 set sash1 [expr {$sash0 + 20}]
2710 }
2711 if {$sash1 > $w - 10} {
2712 set sash1 [expr {$w - 10}]
2713 if {$sash0 > $sash1 - 20} {
2714 set sash0 [expr {$sash1 - 20}]
2715 }
2716 }
2717 }
2718 if {$use_ttk} {
2719 $win sashpos 0 $sash0
2720 $win sashpos 1 $sash1
2721 } else {
2722 $win sash place 0 $sash0 [lindex $s0 1]
2723 $win sash place 1 $sash1 [lindex $s1 1]
2724 }
2725 }
2726 set oldwidth($win) $w
2727 }
2728
2729 proc resizecdetpanes {win w} {
2730 global oldwidth use_ttk
2731 if {[info exists oldwidth($win)]} {
2732 if {$use_ttk} {
2733 set s0 [$win sashpos 0]
2734 } else {
2735 set s0 [$win sash coord 0]
2736 }
2737 if {$w < 60} {
2738 set sash0 [expr {int($w*3/4 - 2)}]
2739 } else {
2740 set factor [expr {1.0 * $w / $oldwidth($win)}]
2741 set sash0 [expr {int($factor * [lindex $s0 0])}]
2742 if {$sash0 < 45} {
2743 set sash0 45
2744 }
2745 if {$sash0 > $w - 15} {
2746 set sash0 [expr {$w - 15}]
2747 }
2748 }
2749 if {$use_ttk} {
2750 $win sashpos 0 $sash0
2751 } else {
2752 $win sash place 0 $sash0 [lindex $s0 1]
2753 }
2754 }
2755 set oldwidth($win) $w
2756 }
2757
2758 proc allcanvs args {
2759 global canv canv2 canv3
2760 eval $canv $args
2761 eval $canv2 $args
2762 eval $canv3 $args
2763 }
2764
2765 proc bindall {event action} {
2766 global canv canv2 canv3
2767 bind $canv $event $action
2768 bind $canv2 $event $action
2769 bind $canv3 $event $action
2770 }
2771
2772 proc about {} {
2773 global uifont NS
2774 set w .about
2775 if {[winfo exists $w]} {
2776 raise $w
2777 return
2778 }
2779 ttk_toplevel $w
2780 wm title $w [mc "About gitk"]
2781 make_transient $w .
2782 message $w.m -text [mc "
2783 Gitk - a commit viewer for git
2784
2785 Copyright \u00a9 2005-2009 Paul Mackerras
2786
2787 Use and redistribute under the terms of the GNU General Public License"] \
2788 -justify center -aspect 400 -border 2 -bg white -relief groove
2789 pack $w.m -side top -fill x -padx 2 -pady 2
2790 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2791 pack $w.ok -side bottom
2792 bind $w <Visibility> "focus $w.ok"
2793 bind $w <Key-Escape> "destroy $w"
2794 bind $w <Key-Return> "destroy $w"
2795 tk::PlaceWindow $w widget .
2796 }
2797
2798 proc keys {} {
2799 global NS
2800 set w .keys
2801 if {[winfo exists $w]} {
2802 raise $w
2803 return
2804 }
2805 if {[tk windowingsystem] eq {aqua}} {
2806 set M1T Cmd
2807 } else {
2808 set M1T Ctrl
2809 }
2810 ttk_toplevel $w
2811 wm title $w [mc "Gitk key bindings"]
2812 make_transient $w .
2813 message $w.m -text "
2814 [mc "Gitk key bindings:"]
2815
2816 [mc "<%s-Q> Quit" $M1T]
2817 [mc "<Home> Move to first commit"]
2818 [mc "<End> Move to last commit"]
2819 [mc "<Up>, p, i Move up one commit"]
2820 [mc "<Down>, n, k Move down one commit"]
2821 [mc "<Left>, z, j Go back in history list"]
2822 [mc "<Right>, x, l Go forward in history list"]
2823 [mc "<PageUp> Move up one page in commit list"]
2824 [mc "<PageDown> Move down one page in commit list"]
2825 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2826 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2827 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2828 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2829 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2830 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2831 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2832 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2833 [mc "<Delete>, b Scroll diff view up one page"]
2834 [mc "<Backspace> Scroll diff view up one page"]
2835 [mc "<Space> Scroll diff view down one page"]
2836 [mc "u Scroll diff view up 18 lines"]
2837 [mc "d Scroll diff view down 18 lines"]
2838 [mc "<%s-F> Find" $M1T]
2839 [mc "<%s-G> Move to next find hit" $M1T]
2840 [mc "<Return> Move to next find hit"]
2841 [mc "/ Focus the search box"]
2842 [mc "? Move to previous find hit"]
2843 [mc "f Scroll diff view to next file"]
2844 [mc "<%s-S> Search for next hit in diff view" $M1T]
2845 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2846 [mc "<%s-KP+> Increase font size" $M1T]
2847 [mc "<%s-plus> Increase font size" $M1T]
2848 [mc "<%s-KP-> Decrease font size" $M1T]
2849 [mc "<%s-minus> Decrease font size" $M1T]
2850 [mc "<F5> Update"]
2851 " \
2852 -justify left -bg white -border 2 -relief groove
2853 pack $w.m -side top -fill both -padx 2 -pady 2
2854 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2855 bind $w <Key-Escape> [list destroy $w]
2856 pack $w.ok -side bottom
2857 bind $w <Visibility> "focus $w.ok"
2858 bind $w <Key-Escape> "destroy $w"
2859 bind $w <Key-Return> "destroy $w"
2860 }
2861
2862 # Procedures for manipulating the file list window at the
2863 # bottom right of the overall window.
2864
2865 proc treeview {w l openlevs} {
2866 global treecontents treediropen treeheight treeparent treeindex
2867
2868 set ix 0
2869 set treeindex() 0
2870 set lev 0
2871 set prefix {}
2872 set prefixend -1
2873 set prefendstack {}
2874 set htstack {}
2875 set ht 0
2876 set treecontents() {}
2877 $w conf -state normal
2878 foreach f $l {
2879 while {[string range $f 0 $prefixend] ne $prefix} {
2880 if {$lev <= $openlevs} {
2881 $w mark set e:$treeindex($prefix) "end -1c"
2882 $w mark gravity e:$treeindex($prefix) left
2883 }
2884 set treeheight($prefix) $ht
2885 incr ht [lindex $htstack end]
2886 set htstack [lreplace $htstack end end]
2887 set prefixend [lindex $prefendstack end]
2888 set prefendstack [lreplace $prefendstack end end]
2889 set prefix [string range $prefix 0 $prefixend]
2890 incr lev -1
2891 }
2892 set tail [string range $f [expr {$prefixend+1}] end]
2893 while {[set slash [string first "/" $tail]] >= 0} {
2894 lappend htstack $ht
2895 set ht 0
2896 lappend prefendstack $prefixend
2897 incr prefixend [expr {$slash + 1}]
2898 set d [string range $tail 0 $slash]
2899 lappend treecontents($prefix) $d
2900 set oldprefix $prefix
2901 append prefix $d
2902 set treecontents($prefix) {}
2903 set treeindex($prefix) [incr ix]
2904 set treeparent($prefix) $oldprefix
2905 set tail [string range $tail [expr {$slash+1}] end]
2906 if {$lev <= $openlevs} {
2907 set ht 1
2908 set treediropen($prefix) [expr {$lev < $openlevs}]
2909 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2910 $w mark set d:$ix "end -1c"
2911 $w mark gravity d:$ix left
2912 set str "\n"
2913 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2914 $w insert end $str
2915 $w image create end -align center -image $bm -padx 1 \
2916 -name a:$ix
2917 $w insert end $d [highlight_tag $prefix]
2918 $w mark set s:$ix "end -1c"
2919 $w mark gravity s:$ix left
2920 }
2921 incr lev
2922 }
2923 if {$tail ne {}} {
2924 if {$lev <= $openlevs} {
2925 incr ht
2926 set str "\n"
2927 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2928 $w insert end $str
2929 $w insert end $tail [highlight_tag $f]
2930 }
2931 lappend treecontents($prefix) $tail
2932 }
2933 }
2934 while {$htstack ne {}} {
2935 set treeheight($prefix) $ht
2936 incr ht [lindex $htstack end]
2937 set htstack [lreplace $htstack end end]
2938 set prefixend [lindex $prefendstack end]
2939 set prefendstack [lreplace $prefendstack end end]
2940 set prefix [string range $prefix 0 $prefixend]
2941 }
2942 $w conf -state disabled
2943 }
2944
2945 proc linetoelt {l} {
2946 global treeheight treecontents
2947
2948 set y 2
2949 set prefix {}
2950 while {1} {
2951 foreach e $treecontents($prefix) {
2952 if {$y == $l} {
2953 return "$prefix$e"
2954 }
2955 set n 1
2956 if {[string index $e end] eq "/"} {
2957 set n $treeheight($prefix$e)
2958 if {$y + $n > $l} {
2959 append prefix $e
2960 incr y
2961 break
2962 }
2963 }
2964 incr y $n
2965 }
2966 }
2967 }
2968
2969 proc highlight_tree {y prefix} {
2970 global treeheight treecontents cflist
2971
2972 foreach e $treecontents($prefix) {
2973 set path $prefix$e
2974 if {[highlight_tag $path] ne {}} {
2975 $cflist tag add bold $y.0 "$y.0 lineend"
2976 }
2977 incr y
2978 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2979 set y [highlight_tree $y $path]
2980 }
2981 }
2982 return $y
2983 }
2984
2985 proc treeclosedir {w dir} {
2986 global treediropen treeheight treeparent treeindex
2987
2988 set ix $treeindex($dir)
2989 $w conf -state normal
2990 $w delete s:$ix e:$ix
2991 set treediropen($dir) 0
2992 $w image configure a:$ix -image tri-rt
2993 $w conf -state disabled
2994 set n [expr {1 - $treeheight($dir)}]
2995 while {$dir ne {}} {
2996 incr treeheight($dir) $n
2997 set dir $treeparent($dir)
2998 }
2999 }
3000
3001 proc treeopendir {w dir} {
3002 global treediropen treeheight treeparent treecontents treeindex
3003
3004 set ix $treeindex($dir)
3005 $w conf -state normal
3006 $w image configure a:$ix -image tri-dn
3007 $w mark set e:$ix s:$ix
3008 $w mark gravity e:$ix right
3009 set lev 0
3010 set str "\n"
3011 set n [llength $treecontents($dir)]
3012 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3013 incr lev
3014 append str "\t"
3015 incr treeheight($x) $n
3016 }
3017 foreach e $treecontents($dir) {
3018 set de $dir$e
3019 if {[string index $e end] eq "/"} {
3020 set iy $treeindex($de)
3021 $w mark set d:$iy e:$ix
3022 $w mark gravity d:$iy left
3023 $w insert e:$ix $str
3024 set treediropen($de) 0
3025 $w image create e:$ix -align center -image tri-rt -padx 1 \
3026 -name a:$iy
3027 $w insert e:$ix $e [highlight_tag $de]
3028 $w mark set s:$iy e:$ix
3029 $w mark gravity s:$iy left
3030 set treeheight($de) 1
3031 } else {
3032 $w insert e:$ix $str
3033 $w insert e:$ix $e [highlight_tag $de]
3034 }
3035 }
3036 $w mark gravity e:$ix right
3037 $w conf -state disabled
3038 set treediropen($dir) 1
3039 set top [lindex [split [$w index @0,0] .] 0]
3040 set ht [$w cget -height]
3041 set l [lindex [split [$w index s:$ix] .] 0]
3042 if {$l < $top} {
3043 $w yview $l.0
3044 } elseif {$l + $n + 1 > $top + $ht} {
3045 set top [expr {$l + $n + 2 - $ht}]
3046 if {$l < $top} {
3047 set top $l
3048 }
3049 $w yview $top.0
3050 }
3051 }
3052
3053 proc treeclick {w x y} {
3054 global treediropen cmitmode ctext cflist cflist_top
3055
3056 if {$cmitmode ne "tree"} return
3057 if {![info exists cflist_top]} return
3058 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3059 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3060 $cflist tag add highlight $l.0 "$l.0 lineend"
3061 set cflist_top $l
3062 if {$l == 1} {
3063 $ctext yview 1.0
3064 return
3065 }
3066 set e [linetoelt $l]
3067 if {[string index $e end] ne "/"} {
3068 showfile $e
3069 } elseif {$treediropen($e)} {
3070 treeclosedir $w $e
3071 } else {
3072 treeopendir $w $e
3073 }
3074 }
3075
3076 proc setfilelist {id} {
3077 global treefilelist cflist jump_to_here
3078
3079 treeview $cflist $treefilelist($id) 0
3080 if {$jump_to_here ne {}} {
3081 set f [lindex $jump_to_here 0]
3082 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3083 showfile $f
3084 }
3085 }
3086 }
3087
3088 image create bitmap tri-rt -background black -foreground blue -data {
3089 #define tri-rt_width 13
3090 #define tri-rt_height 13
3091 static unsigned char tri-rt_bits[] = {
3092 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3093 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3094 0x00, 0x00};
3095 } -maskdata {
3096 #define tri-rt-mask_width 13
3097 #define tri-rt-mask_height 13
3098 static unsigned char tri-rt-mask_bits[] = {
3099 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3100 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3101 0x08, 0x00};
3102 }
3103 image create bitmap tri-dn -background black -foreground blue -data {
3104 #define tri-dn_width 13
3105 #define tri-dn_height 13
3106 static unsigned char tri-dn_bits[] = {
3107 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3108 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3109 0x00, 0x00};
3110 } -maskdata {
3111 #define tri-dn-mask_width 13
3112 #define tri-dn-mask_height 13
3113 static unsigned char tri-dn-mask_bits[] = {
3114 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3115 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3116 0x00, 0x00};
3117 }
3118
3119 image create bitmap reficon-T -background black -foreground yellow -data {
3120 #define tagicon_width 13
3121 #define tagicon_height 9
3122 static unsigned char tagicon_bits[] = {
3123 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3124 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3125 } -maskdata {
3126 #define tagicon-mask_width 13
3127 #define tagicon-mask_height 9
3128 static unsigned char tagicon-mask_bits[] = {
3129 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3130 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3131 }
3132 set rectdata {
3133 #define headicon_width 13
3134 #define headicon_height 9
3135 static unsigned char headicon_bits[] = {
3136 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3137 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3138 }
3139 set rectmask {
3140 #define headicon-mask_width 13
3141 #define headicon-mask_height 9
3142 static unsigned char headicon-mask_bits[] = {
3143 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3144 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3145 }
3146 image create bitmap reficon-H -background black -foreground green \
3147 -data $rectdata -maskdata $rectmask
3148 image create bitmap reficon-o -background black -foreground "#ddddff" \
3149 -data $rectdata -maskdata $rectmask
3150
3151 proc init_flist {first} {
3152 global cflist cflist_top difffilestart
3153
3154 $cflist conf -state normal
3155 $cflist delete 0.0 end
3156 if {$first ne {}} {
3157 $cflist insert end $first
3158 set cflist_top 1
3159 $cflist tag add highlight 1.0 "1.0 lineend"
3160 } else {
3161 catch {unset cflist_top}
3162 }
3163 $cflist conf -state disabled
3164 set difffilestart {}
3165 }
3166
3167 proc highlight_tag {f} {
3168 global highlight_paths
3169
3170 foreach p $highlight_paths {
3171 if {[string match $p $f]} {
3172 return "bold"
3173 }
3174 }
3175 return {}
3176 }
3177
3178 proc highlight_filelist {} {
3179 global cmitmode cflist
3180
3181 $cflist conf -state normal
3182 if {$cmitmode ne "tree"} {
3183 set end [lindex [split [$cflist index end] .] 0]
3184 for {set l 2} {$l < $end} {incr l} {
3185 set line [$cflist get $l.0 "$l.0 lineend"]
3186 if {[highlight_tag $line] ne {}} {
3187 $cflist tag add bold $l.0 "$l.0 lineend"
3188 }
3189 }
3190 } else {
3191 highlight_tree 2 {}
3192 }
3193 $cflist conf -state disabled
3194 }
3195
3196 proc unhighlight_filelist {} {
3197 global cflist
3198
3199 $cflist conf -state normal
3200 $cflist tag remove bold 1.0 end
3201 $cflist conf -state disabled
3202 }
3203
3204 proc add_flist {fl} {
3205 global cflist
3206
3207 $cflist conf -state normal
3208 foreach f $fl {
3209 $cflist insert end "\n"
3210 $cflist insert end $f [highlight_tag $f]
3211 }
3212 $cflist conf -state disabled
3213 }
3214
3215 proc sel_flist {w x y} {
3216 global ctext difffilestart cflist cflist_top cmitmode
3217
3218 if {$cmitmode eq "tree"} return
3219 if {![info exists cflist_top]} return
3220 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3221 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3222 $cflist tag add highlight $l.0 "$l.0 lineend"
3223 set cflist_top $l
3224 if {$l == 1} {
3225 $ctext yview 1.0
3226 } else {
3227 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3228 }
3229 }
3230
3231 proc pop_flist_menu {w X Y x y} {
3232 global ctext cflist cmitmode flist_menu flist_menu_file
3233 global treediffs diffids
3234
3235 stopfinding
3236 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3237 if {$l <= 1} return
3238 if {$cmitmode eq "tree"} {
3239 set e [linetoelt $l]
3240 if {[string index $e end] eq "/"} return
3241 } else {
3242 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3243 }
3244 set flist_menu_file $e
3245 set xdiffstate "normal"
3246 if {$cmitmode eq "tree"} {
3247 set xdiffstate "disabled"
3248 }
3249 # Disable "External diff" item in tree mode
3250 $flist_menu entryconf 2 -state $xdiffstate
3251 tk_popup $flist_menu $X $Y
3252 }
3253
3254 proc find_ctext_fileinfo {line} {
3255 global ctext_file_names ctext_file_lines
3256
3257 set ok [bsearch $ctext_file_lines $line]
3258 set tline [lindex $ctext_file_lines $ok]
3259
3260 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3261 return {}
3262 } else {
3263 return [list [lindex $ctext_file_names $ok] $tline]
3264 }
3265 }
3266
3267 proc pop_diff_menu {w X Y x y} {
3268 global ctext diff_menu flist_menu_file
3269 global diff_menu_txtpos diff_menu_line
3270 global diff_menu_filebase
3271
3272 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3273 set diff_menu_line [lindex $diff_menu_txtpos 0]
3274 # don't pop up the menu on hunk-separator or file-separator lines
3275 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3276 return
3277 }
3278 stopfinding
3279 set f [find_ctext_fileinfo $diff_menu_line]
3280 if {$f eq {}} return
3281 set flist_menu_file [lindex $f 0]
3282 set diff_menu_filebase [lindex $f 1]
3283 tk_popup $diff_menu $X $Y
3284 }
3285
3286 proc flist_hl {only} {
3287 global flist_menu_file findstring gdttype
3288
3289 set x [shellquote $flist_menu_file]
3290 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3291 set findstring $x
3292 } else {
3293 append findstring " " $x
3294 }
3295 set gdttype [mc "touching paths:"]
3296 }
3297
3298 proc gitknewtmpdir {} {
3299 global diffnum gitktmpdir gitdir
3300
3301 if {![info exists gitktmpdir]} {
3302 set gitktmpdir [file join [file dirname $gitdir] \
3303 [format ".gitk-tmp.%s" [pid]]]
3304 if {[catch {file mkdir $gitktmpdir} err]} {
3305 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3306 unset gitktmpdir
3307 return {}
3308 }
3309 set diffnum 0
3310 }
3311 incr diffnum
3312 set diffdir [file join $gitktmpdir $diffnum]
3313 if {[catch {file mkdir $diffdir} err]} {
3314 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3315 return {}
3316 }
3317 return $diffdir
3318 }
3319
3320 proc save_file_from_commit {filename output what} {
3321 global nullfile
3322
3323 if {[catch {exec git show $filename -- > $output} err]} {
3324 if {[string match "fatal: bad revision *" $err]} {
3325 return $nullfile
3326 }
3327 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3328 return {}
3329 }
3330 return $output
3331 }
3332
3333 proc external_diff_get_one_file {diffid filename diffdir} {
3334 global nullid nullid2 nullfile
3335 global gitdir
3336
3337 if {$diffid == $nullid} {
3338 set difffile [file join [file dirname $gitdir] $filename]
3339 if {[file exists $difffile]} {
3340 return $difffile
3341 }
3342 return $nullfile
3343 }
3344 if {$diffid == $nullid2} {
3345 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3346 return [save_file_from_commit :$filename $difffile index]
3347 }
3348 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3349 return [save_file_from_commit $diffid:$filename $difffile \
3350 "revision $diffid"]
3351 }
3352
3353 proc external_diff {} {
3354 global nullid nullid2
3355 global flist_menu_file
3356 global diffids
3357 global extdifftool
3358
3359 if {[llength $diffids] == 1} {
3360 # no reference commit given
3361 set diffidto [lindex $diffids 0]
3362 if {$diffidto eq $nullid} {
3363 # diffing working copy with index
3364 set diffidfrom $nullid2
3365 } elseif {$diffidto eq $nullid2} {
3366 # diffing index with HEAD
3367 set diffidfrom "HEAD"
3368 } else {
3369 # use first parent commit
3370 global parentlist selectedline
3371 set diffidfrom [lindex $parentlist $selectedline 0]
3372 }
3373 } else {
3374 set diffidfrom [lindex $diffids 0]
3375 set diffidto [lindex $diffids 1]
3376 }
3377
3378 # make sure that several diffs wont collide
3379 set diffdir [gitknewtmpdir]
3380 if {$diffdir eq {}} return
3381
3382 # gather files to diff
3383 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3384 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3385
3386 if {$difffromfile ne {} && $difftofile ne {}} {
3387 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3388 if {[catch {set fl [open |$cmd r]} err]} {
3389 file delete -force $diffdir
3390 error_popup "$extdifftool: [mc "command failed:"] $err"
3391 } else {
3392 fconfigure $fl -blocking 0
3393 filerun $fl [list delete_at_eof $fl $diffdir]
3394 }
3395 }
3396 }
3397
3398 proc find_hunk_blamespec {base line} {
3399 global ctext
3400
3401 # Find and parse the hunk header
3402 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3403 if {$s_lix eq {}} return
3404
3405 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3406 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3407 s_line old_specs osz osz1 new_line nsz]} {
3408 return
3409 }
3410
3411 # base lines for the parents
3412 set base_lines [list $new_line]
3413 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3414 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3415 old_spec old_line osz]} {
3416 return
3417 }
3418 lappend base_lines $old_line
3419 }
3420
3421 # Now scan the lines to determine offset within the hunk
3422 set max_parent [expr {[llength $base_lines]-2}]
3423 set dline 0
3424 set s_lno [lindex [split $s_lix "."] 0]
3425
3426 # Determine if the line is removed
3427 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3428 if {[string match {[-+ ]*} $chunk]} {
3429 set removed_idx [string first "-" $chunk]
3430 # Choose a parent index
3431 if {$removed_idx >= 0} {
3432 set parent $removed_idx
3433 } else {
3434 set unchanged_idx [string first " " $chunk]
3435 if {$unchanged_idx >= 0} {
3436 set parent $unchanged_idx
3437 } else {
3438 # blame the current commit
3439 set parent -1
3440 }
3441 }
3442 # then count other lines that belong to it
3443 for {set i $line} {[incr i -1] > $s_lno} {} {
3444 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3445 # Determine if the line is removed
3446 set removed_idx [string first "-" $chunk]
3447 if {$parent >= 0} {
3448 set code [string index $chunk $parent]
3449 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3450 incr dline
3451 }
3452 } else {
3453 if {$removed_idx < 0} {
3454 incr dline
3455 }
3456 }
3457 }
3458 incr parent
3459 } else {
3460 set parent 0
3461 }
3462
3463 incr dline [lindex $base_lines $parent]
3464 return [list $parent $dline]
3465 }
3466
3467 proc external_blame_diff {} {
3468 global currentid cmitmode
3469 global diff_menu_txtpos diff_menu_line
3470 global diff_menu_filebase flist_menu_file
3471
3472 if {$cmitmode eq "tree"} {
3473 set parent_idx 0
3474 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3475 } else {
3476 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3477 if {$hinfo ne {}} {
3478 set parent_idx [lindex $hinfo 0]
3479 set line [lindex $hinfo 1]
3480 } else {
3481 set parent_idx 0
3482 set line 0
3483 }
3484 }
3485
3486 external_blame $parent_idx $line
3487 }
3488
3489 # Find the SHA1 ID of the blob for file $fname in the index
3490 # at stage 0 or 2
3491 proc index_sha1 {fname} {
3492 set f [open [list | git ls-files -s $fname] r]
3493 while {[gets $f line] >= 0} {
3494 set info [lindex [split $line "\t"] 0]
3495 set stage [lindex $info 2]
3496 if {$stage eq "0" || $stage eq "2"} {
3497 close $f
3498 return [lindex $info 1]
3499 }
3500 }
3501 close $f
3502 return {}
3503 }
3504
3505 # Turn an absolute path into one relative to the current directory
3506 proc make_relative {f} {
3507 if {[file pathtype $f] eq "relative"} {
3508 return $f
3509 }
3510 set elts [file split $f]
3511 set here [file split [pwd]]
3512 set ei 0
3513 set hi 0
3514 set res {}
3515 foreach d $here {
3516 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3517 lappend res ".."
3518 } else {
3519 incr ei
3520 }
3521 incr hi
3522 }
3523 set elts [concat $res [lrange $elts $ei end]]
3524 return [eval file join $elts]
3525 }
3526
3527 proc external_blame {parent_idx {line {}}} {
3528 global flist_menu_file gitdir
3529 global nullid nullid2
3530 global parentlist selectedline currentid
3531
3532 if {$parent_idx > 0} {
3533 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3534 } else {
3535 set base_commit $currentid
3536 }
3537
3538 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3539 error_popup [mc "No such commit"]
3540 return
3541 }
3542
3543 set cmdline [list git gui blame]
3544 if {$line ne {} && $line > 1} {
3545 lappend cmdline "--line=$line"
3546 }
3547 set f [file join [file dirname $gitdir] $flist_menu_file]
3548 # Unfortunately it seems git gui blame doesn't like
3549 # being given an absolute path...
3550 set f [make_relative $f]
3551 lappend cmdline $base_commit $f
3552 if {[catch {eval exec $cmdline &} err]} {
3553 error_popup "[mc "git gui blame: command failed:"] $err"
3554 }
3555 }
3556
3557 proc show_line_source {} {
3558 global cmitmode currentid parents curview blamestuff blameinst
3559 global diff_menu_line diff_menu_filebase flist_menu_file
3560 global nullid nullid2 gitdir
3561
3562 set from_index {}
3563 if {$cmitmode eq "tree"} {
3564 set id $currentid
3565 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3566 } else {
3567 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3568 if {$h eq {}} return
3569 set pi [lindex $h 0]
3570 if {$pi == 0} {
3571 mark_ctext_line $diff_menu_line
3572 return
3573 }
3574 incr pi -1
3575 if {$currentid eq $nullid} {
3576 if {$pi > 0} {
3577 # must be a merge in progress...
3578 if {[catch {
3579 # get the last line from .git/MERGE_HEAD
3580 set f [open [file join $gitdir MERGE_HEAD] r]
3581 set id [lindex [split [read $f] "\n"] end-1]
3582 close $f
3583 } err]} {
3584 error_popup [mc "Couldn't read merge head: %s" $err]
3585 return
3586 }
3587 } elseif {$parents($curview,$currentid) eq $nullid2} {
3588 # need to do the blame from the index
3589 if {[catch {
3590 set from_index [index_sha1 $flist_menu_file]
3591 } err]} {
3592 error_popup [mc "Error reading index: %s" $err]
3593 return
3594 }
3595 } else {
3596 set id $parents($curview,$currentid)
3597 }
3598 } else {
3599 set id [lindex $parents($curview,$currentid) $pi]
3600 }
3601 set line [lindex $h 1]
3602 }
3603 set blameargs {}
3604 if {$from_index ne {}} {
3605 lappend blameargs | git cat-file blob $from_index
3606 }
3607 lappend blameargs | git blame -p -L$line,+1
3608 if {$from_index ne {}} {
3609 lappend blameargs --contents -
3610 } else {
3611 lappend blameargs $id
3612 }
3613 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3614 if {[catch {
3615 set f [open $blameargs r]
3616 } err]} {
3617 error_popup [mc "Couldn't start git blame: %s" $err]
3618 return
3619 }
3620 nowbusy blaming [mc "Searching"]
3621 fconfigure $f -blocking 0
3622 set i [reg_instance $f]
3623 set blamestuff($i) {}
3624 set blameinst $i
3625 filerun $f [list read_line_source $f $i]
3626 }
3627
3628 proc stopblaming {} {
3629 global blameinst
3630
3631 if {[info exists blameinst]} {
3632 stop_instance $blameinst
3633 unset blameinst
3634 notbusy blaming
3635 }
3636 }
3637
3638 proc read_line_source {fd inst} {
3639 global blamestuff curview commfd blameinst nullid nullid2
3640
3641 while {[gets $fd line] >= 0} {
3642 lappend blamestuff($inst) $line
3643 }
3644 if {![eof $fd]} {
3645 return 1
3646 }
3647 unset commfd($inst)
3648 unset blameinst
3649 notbusy blaming
3650 fconfigure $fd -blocking 1
3651 if {[catch {close $fd} err]} {
3652 error_popup [mc "Error running git blame: %s" $err]
3653 return 0
3654 }
3655
3656 set fname {}
3657 set line [split [lindex $blamestuff($inst) 0] " "]
3658 set id [lindex $line 0]
3659 set lnum [lindex $line 1]
3660 if {[string length $id] == 40 && [string is xdigit $id] &&
3661 [string is digit -strict $lnum]} {
3662 # look for "filename" line
3663 foreach l $blamestuff($inst) {
3664 if {[string match "filename *" $l]} {
3665 set fname [string range $l 9 end]
3666 break
3667 }
3668 }
3669 }
3670 if {$fname ne {}} {
3671 # all looks good, select it
3672 if {$id eq $nullid} {
3673 # blame uses all-zeroes to mean not committed,
3674 # which would mean a change in the index
3675 set id $nullid2
3676 }
3677 if {[commitinview $id $curview]} {
3678 selectline [rowofcommit $id] 1 [list $fname $lnum]
3679 } else {
3680 error_popup [mc "That line comes from commit %s, \
3681 which is not in this view" [shortids $id]]
3682 }
3683 } else {
3684 puts "oops couldn't parse git blame output"
3685 }
3686 return 0
3687 }
3688
3689 # delete $dir when we see eof on $f (presumably because the child has exited)
3690 proc delete_at_eof {f dir} {
3691 while {[gets $f line] >= 0} {}
3692 if {[eof $f]} {
3693 if {[catch {close $f} err]} {
3694 error_popup "[mc "External diff viewer failed:"] $err"
3695 }
3696 file delete -force $dir
3697 return 0
3698 }
3699 return 1
3700 }
3701
3702 # Functions for adding and removing shell-type quoting
3703
3704 proc shellquote {str} {
3705 if {![string match "*\['\"\\ \t]*" $str]} {
3706 return $str
3707 }
3708 if {![string match "*\['\"\\]*" $str]} {
3709 return "\"$str\""
3710 }
3711 if {![string match "*'*" $str]} {
3712 return "'$str'"
3713 }
3714 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3715 }
3716
3717 proc shellarglist {l} {
3718 set str {}
3719 foreach a $l {
3720 if {$str ne {}} {
3721 append str " "
3722 }
3723 append str [shellquote $a]
3724 }
3725 return $str
3726 }
3727
3728 proc shelldequote {str} {
3729 set ret {}
3730 set used -1
3731 while {1} {
3732 incr used
3733 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3734 append ret [string range $str $used end]
3735 set used [string length $str]
3736 break
3737 }
3738 set first [lindex $first 0]
3739 set ch [string index $str $first]
3740 if {$first > $used} {
3741 append ret [string range $str $used [expr {$first - 1}]]
3742 set used $first
3743 }
3744 if {$ch eq " " || $ch eq "\t"} break
3745 incr used
3746 if {$ch eq "'"} {
3747 set first [string first "'" $str $used]
3748 if {$first < 0} {
3749 error "unmatched single-quote"
3750 }
3751 append ret [string range $str $used [expr {$first - 1}]]
3752 set used $first
3753 continue
3754 }
3755 if {$ch eq "\\"} {
3756 if {$used >= [string length $str]} {
3757 error "trailing backslash"
3758 }
3759 append ret [string index $str $used]
3760 continue
3761 }
3762 # here ch == "\""
3763 while {1} {
3764 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3765 error "unmatched double-quote"
3766 }
3767 set first [lindex $first 0]
3768 set ch [string index $str $first]
3769 if {$first > $used} {
3770 append ret [string range $str $used [expr {$first - 1}]]
3771 set used $first
3772 }
3773 if {$ch eq "\""} break
3774 incr used
3775 append ret [string index $str $used]
3776 incr used
3777 }
3778 }
3779 return [list $used $ret]
3780 }
3781
3782 proc shellsplit {str} {
3783 set l {}
3784 while {1} {
3785 set str [string trimleft $str]
3786 if {$str eq {}} break
3787 set dq [shelldequote $str]
3788 set n [lindex $dq 0]
3789 set word [lindex $dq 1]
3790 set str [string range $str $n end]
3791 lappend l $word
3792 }
3793 return $l
3794 }
3795
3796 # Code to implement multiple views
3797
3798 proc newview {ishighlight} {
3799 global nextviewnum newviewname newishighlight
3800 global revtreeargs viewargscmd newviewopts curview
3801
3802 set newishighlight $ishighlight
3803 set top .gitkview
3804 if {[winfo exists $top]} {
3805 raise $top
3806 return
3807 }
3808 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3809 set newviewopts($nextviewnum,perm) 0
3810 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3811 decode_view_opts $nextviewnum $revtreeargs
3812 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3813 }
3814
3815 set known_view_options {
3816 {perm b . {} {mc "Remember this view"}}
3817 {reflabel l + {} {mc "References (space separated list):"}}
3818 {refs t15 .. {} {mc "Branches & tags:"}}
3819 {allrefs b *. "--all" {mc "All refs"}}
3820 {branches b . "--branches" {mc "All (local) branches"}}
3821 {tags b . "--tags" {mc "All tags"}}
3822 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3823 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3824 {author t15 .. "--author=*" {mc "Author:"}}
3825 {committer t15 . "--committer=*" {mc "Committer:"}}
3826 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3827 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3828 {changes_l l + {} {mc "Changes to Files:"}}
3829 {pickaxe_s r0 . {} {mc "Fixed String"}}
3830 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3831 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3832 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3833 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3834 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3835 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3836 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3837 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3838 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3839 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3840 {lright b . "--left-right" {mc "Mark branch sides"}}
3841 {first b . "--first-parent" {mc "Limit to first parent"}}
3842 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3843 {args t50 *. {} {mc "Additional arguments to git log:"}}
3844 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3845 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3846 }
3847
3848 proc encode_view_opts {n} {
3849 global known_view_options newviewopts
3850
3851 set rargs [list]
3852 foreach opt $known_view_options {
3853 set patterns [lindex $opt 3]
3854 if {$patterns eq {}} continue
3855 set pattern [lindex $patterns 0]
3856
3857 if {[lindex $opt 1] eq "b"} {
3858 set val $newviewopts($n,[lindex $opt 0])
3859 if {$val} {
3860 lappend rargs $pattern
3861 }
3862 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3863 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3864 set val $newviewopts($n,$button_id)
3865 if {$val eq $value} {
3866 lappend rargs $pattern