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