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