gitk: Reorganize processing of arguments for git log
[git/mingw.git] / gitk
blob4f8397707021ff2fe7a2a13cf3c9afc181bd9e3c
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set repeat [eval $script]
71 set t1 [clock clicks -milliseconds]
72 set t [expr {$t1 - $t0}]
73 set runq [lrange $runq 1 end]
74 if {$repeat ne {} && $repeat} {
75 if {$fd eq {} || $repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq [list $fd $script]
79 } else {
80 fileevent $fd readable [list filereadable $fd $script]
82 } elseif {$fd eq {}} {
83 unset isonrunq($script)
85 set t0 $t1
86 if {$t1 - $tstart >= 80} break
88 if {$runq ne {}} {
89 after idle dorunq
93 proc unmerged_files {files} {
94 global nr_unmerged
96 # find the list of unmerged files
97 set mlist {}
98 set nr_unmerged 0
99 if {[catch {
100 set fd [open "| git ls-files -u" r]
101 } err]} {
102 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
103 exit 1
105 while {[gets $fd line] >= 0} {
106 set i [string first "\t" $line]
107 if {$i < 0} continue
108 set fname [string range $line [expr {$i+1}] end]
109 if {[lsearch -exact $mlist $fname] >= 0} continue
110 incr nr_unmerged
111 if {$files eq {} || [path_filter $files $fname]} {
112 lappend mlist $fname
115 catch {close $fd}
116 return $mlist
119 proc parseviewargs {n arglist} {
120 global viewargs vdatemode vmergeonly
122 set vdatemode($n) 0
123 set vmergeonly($n) 0
124 set glargs {}
125 foreach arg $viewargs($n) {
126 switch -glob -- $arg {
127 "-d" -
128 "--date-order" {
129 set vdatemode($n) 1
131 "--merge" {
132 set vmergeonly($n) 1
133 lappend glargs $arg
135 default {
136 lappend glargs $arg
140 return $glargs
143 # Start off a git log process and arrange to read its output
144 proc start_rev_list {view} {
145 global startmsecs commitidx viewcomplete
146 global commfd leftover tclencoding
147 global viewargs viewargscmd vactualargs viewfiles vfilelimit
148 global showlocalchanges commitinterest mainheadid
149 global progressdirn progresscoords proglastnc curview
150 global viewactive loginstance viewinstances vmergeonly
151 global pending_select mainheadid
153 set startmsecs [clock clicks -milliseconds]
154 set commitidx($view) 0
155 # these are set this way for the error exits
156 set viewcomplete($view) 1
157 set viewactive($view) 0
158 varcinit $view
160 set args $viewargs($view)
161 if {$viewargscmd($view) ne {}} {
162 if {[catch {
163 set str [exec sh -c $viewargscmd($view)]
164 } err]} {
165 error_popup "Error executing --argscmd command: $err"
166 return 0
168 set args [concat $args [split $str "\n"]]
170 set args [parseviewargs $view $args]
171 set vactualargs($view) $args
173 set files $viewfiles($view)
174 if {$vmergeonly($view)} {
175 set files [unmerged_files $files]
176 if {$files eq {}} {
177 global nr_unmerged
178 if {$nr_unmerged == 0} {
179 error_popup [mc "No files selected: --merge specified but\
180 no files are unmerged."]
181 } else {
182 error_popup [mc "No files selected: --merge specified but\
183 no unmerged files are within file limit."]
185 return 0
188 set vfilelimit($view) $files
190 if {[catch {
191 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
192 --boundary $args "--" $files] r]
193 } err]} {
194 error_popup "[mc "Error executing git log:"] $err"
195 return 0
197 set i [incr loginstance]
198 set viewinstances($view) [list $i]
199 set commfd($i) $fd
200 set leftover($i) {}
201 if {$showlocalchanges} {
202 lappend commitinterest($mainheadid) {dodiffindex}
204 fconfigure $fd -blocking 0 -translation lf -eofchar {}
205 if {$tclencoding != {}} {
206 fconfigure $fd -encoding $tclencoding
208 filerun $fd [list getcommitlines $fd $i $view 0]
209 nowbusy $view [mc "Reading"]
210 if {$view == $curview} {
211 set progressdirn 1
212 set progresscoords {0 0}
213 set proglastnc 0
214 set pending_select $mainheadid
216 set viewcomplete($view) 0
217 set viewactive($view) 1
218 return 1
221 proc stop_rev_list {view} {
222 global commfd viewinstances leftover
224 foreach inst $viewinstances($view) {
225 set fd $commfd($inst)
226 catch {
227 set pid [pid $fd]
228 exec kill $pid
230 catch {close $fd}
231 nukefile $fd
232 unset commfd($inst)
233 unset leftover($inst)
235 set viewinstances($view) {}
238 proc getcommits {} {
239 global canv curview need_redisplay viewactive
241 initlayout
242 if {[start_rev_list $curview]} {
243 show_status [mc "Reading commits..."]
244 set need_redisplay 1
245 } else {
246 show_status [mc "No commits selected"]
250 proc updatecommits {} {
251 global curview vactualargs vfilelimit viewinstances
252 global viewactive viewcomplete loginstance tclencoding mainheadid
253 global startmsecs commfd showneartags showlocalchanges leftover
254 global mainheadid pending_select
255 global isworktree
257 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
258 set oldmainid $mainheadid
259 rereadrefs
260 if {$showlocalchanges} {
261 if {$mainheadid ne $oldmainid} {
262 dohidelocalchanges
264 if {[commitinview $mainheadid $curview]} {
265 dodiffindex
268 set view $curview
269 if {[catch {
270 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
271 --boundary $vactualargs($view) --not [seeds $view] \
272 "--" $vfilelimit($view)] r]
273 } err]} {
274 error_popup "Error executing git log: $err"
275 exit 1
277 if {$viewactive($view) == 0} {
278 set startmsecs [clock clicks -milliseconds]
280 set i [incr loginstance]
281 lappend viewinstances($view) $i
282 set commfd($i) $fd
283 set leftover($i) {}
284 fconfigure $fd -blocking 0 -translation lf -eofchar {}
285 if {$tclencoding != {}} {
286 fconfigure $fd -encoding $tclencoding
288 filerun $fd [list getcommitlines $fd $i $view 1]
289 incr viewactive($view)
290 set viewcomplete($view) 0
291 set pending_select $mainheadid
292 nowbusy $view "Reading"
293 if {$showneartags} {
294 getallcommits
298 proc reloadcommits {} {
299 global curview viewcomplete selectedline currentid thickerline
300 global showneartags treediffs commitinterest cached_commitrow
301 global progresscoords targetid
303 if {!$viewcomplete($curview)} {
304 stop_rev_list $curview
305 set progresscoords {0 0}
306 adjustprogress
308 resetvarcs $curview
309 catch {unset selectedline}
310 catch {unset currentid}
311 catch {unset thickerline}
312 catch {unset treediffs}
313 readrefs
314 changedrefs
315 if {$showneartags} {
316 getallcommits
318 clear_display
319 catch {unset commitinterest}
320 catch {unset cached_commitrow}
321 catch {unset targetid}
322 setcanvscroll
323 getcommits
324 return 0
327 # This makes a string representation of a positive integer which
328 # sorts as a string in numerical order
329 proc strrep {n} {
330 if {$n < 16} {
331 return [format "%x" $n]
332 } elseif {$n < 256} {
333 return [format "x%.2x" $n]
334 } elseif {$n < 65536} {
335 return [format "y%.4x" $n]
337 return [format "z%.8x" $n]
340 # Procedures used in reordering commits from git log (without
341 # --topo-order) into the order for display.
343 proc varcinit {view} {
344 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
345 global vtokmod varcmod vrowmod varcix vlastins
347 set varcstart($view) {{}}
348 set vupptr($view) {0}
349 set vdownptr($view) {0}
350 set vleftptr($view) {0}
351 set vbackptr($view) {0}
352 set varctok($view) {{}}
353 set varcrow($view) {{}}
354 set vtokmod($view) {}
355 set varcmod($view) 0
356 set vrowmod($view) 0
357 set varcix($view) {{}}
358 set vlastins($view) {0}
361 proc resetvarcs {view} {
362 global varcid varccommits parents children vseedcount ordertok
364 foreach vid [array names varcid $view,*] {
365 unset varcid($vid)
366 unset children($vid)
367 unset parents($vid)
369 # some commits might have children but haven't been seen yet
370 foreach vid [array names children $view,*] {
371 unset children($vid)
373 foreach va [array names varccommits $view,*] {
374 unset varccommits($va)
376 foreach vd [array names vseedcount $view,*] {
377 unset vseedcount($vd)
379 catch {unset ordertok}
382 # returns a list of the commits with no children
383 proc seeds {v} {
384 global vdownptr vleftptr varcstart
386 set ret {}
387 set a [lindex $vdownptr($v) 0]
388 while {$a != 0} {
389 lappend ret [lindex $varcstart($v) $a]
390 set a [lindex $vleftptr($v) $a]
392 return $ret
395 proc newvarc {view id} {
396 global varcid varctok parents children vdatemode
397 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
398 global commitdata commitinfo vseedcount varccommits vlastins
400 set a [llength $varctok($view)]
401 set vid $view,$id
402 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
403 if {![info exists commitinfo($id)]} {
404 parsecommit $id $commitdata($id) 1
406 set cdate [lindex $commitinfo($id) 4]
407 if {![string is integer -strict $cdate]} {
408 set cdate 0
410 if {![info exists vseedcount($view,$cdate)]} {
411 set vseedcount($view,$cdate) -1
413 set c [incr vseedcount($view,$cdate)]
414 set cdate [expr {$cdate ^ 0xffffffff}]
415 set tok "s[strrep $cdate][strrep $c]"
416 } else {
417 set tok {}
419 set ka 0
420 if {[llength $children($vid)] > 0} {
421 set kid [lindex $children($vid) end]
422 set k $varcid($view,$kid)
423 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
424 set ki $kid
425 set ka $k
426 set tok [lindex $varctok($view) $k]
429 if {$ka != 0} {
430 set i [lsearch -exact $parents($view,$ki) $id]
431 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
432 append tok [strrep $j]
434 set c [lindex $vlastins($view) $ka]
435 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
436 set c $ka
437 set b [lindex $vdownptr($view) $ka]
438 } else {
439 set b [lindex $vleftptr($view) $c]
441 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
442 set c $b
443 set b [lindex $vleftptr($view) $c]
445 if {$c == $ka} {
446 lset vdownptr($view) $ka $a
447 lappend vbackptr($view) 0
448 } else {
449 lset vleftptr($view) $c $a
450 lappend vbackptr($view) $c
452 lset vlastins($view) $ka $a
453 lappend vupptr($view) $ka
454 lappend vleftptr($view) $b
455 if {$b != 0} {
456 lset vbackptr($view) $b $a
458 lappend varctok($view) $tok
459 lappend varcstart($view) $id
460 lappend vdownptr($view) 0
461 lappend varcrow($view) {}
462 lappend varcix($view) {}
463 set varccommits($view,$a) {}
464 lappend vlastins($view) 0
465 return $a
468 proc splitvarc {p v} {
469 global varcid varcstart varccommits varctok
470 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
472 set oa $varcid($v,$p)
473 set ac $varccommits($v,$oa)
474 set i [lsearch -exact $varccommits($v,$oa) $p]
475 if {$i <= 0} return
476 set na [llength $varctok($v)]
477 # "%" sorts before "0"...
478 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
479 lappend varctok($v) $tok
480 lappend varcrow($v) {}
481 lappend varcix($v) {}
482 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
483 set varccommits($v,$na) [lrange $ac $i end]
484 lappend varcstart($v) $p
485 foreach id $varccommits($v,$na) {
486 set varcid($v,$id) $na
488 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
489 lappend vlastins($v) [lindex $vlastins($v) $oa]
490 lset vdownptr($v) $oa $na
491 lset vlastins($v) $oa 0
492 lappend vupptr($v) $oa
493 lappend vleftptr($v) 0
494 lappend vbackptr($v) 0
495 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
496 lset vupptr($v) $b $na
500 proc renumbervarc {a v} {
501 global parents children varctok varcstart varccommits
502 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
504 set t1 [clock clicks -milliseconds]
505 set todo {}
506 set isrelated($a) 1
507 set kidchanged($a) 1
508 set ntot 0
509 while {$a != 0} {
510 if {[info exists isrelated($a)]} {
511 lappend todo $a
512 set id [lindex $varccommits($v,$a) end]
513 foreach p $parents($v,$id) {
514 if {[info exists varcid($v,$p)]} {
515 set isrelated($varcid($v,$p)) 1
519 incr ntot
520 set b [lindex $vdownptr($v) $a]
521 if {$b == 0} {
522 while {$a != 0} {
523 set b [lindex $vleftptr($v) $a]
524 if {$b != 0} break
525 set a [lindex $vupptr($v) $a]
528 set a $b
530 foreach a $todo {
531 if {![info exists kidchanged($a)]} continue
532 set id [lindex $varcstart($v) $a]
533 if {[llength $children($v,$id)] > 1} {
534 set children($v,$id) [lsort -command [list vtokcmp $v] \
535 $children($v,$id)]
537 set oldtok [lindex $varctok($v) $a]
538 if {!$vdatemode($v)} {
539 set tok {}
540 } else {
541 set tok $oldtok
543 set ka 0
544 set kid [last_real_child $v,$id]
545 if {$kid ne {}} {
546 set k $varcid($v,$kid)
547 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
548 set ki $kid
549 set ka $k
550 set tok [lindex $varctok($v) $k]
553 if {$ka != 0} {
554 set i [lsearch -exact $parents($v,$ki) $id]
555 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
556 append tok [strrep $j]
558 if {$tok eq $oldtok} {
559 continue
561 set id [lindex $varccommits($v,$a) end]
562 foreach p $parents($v,$id) {
563 if {[info exists varcid($v,$p)]} {
564 set kidchanged($varcid($v,$p)) 1
565 } else {
566 set sortkids($p) 1
569 lset varctok($v) $a $tok
570 set b [lindex $vupptr($v) $a]
571 if {$b != $ka} {
572 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
573 modify_arc $v $ka
575 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
576 modify_arc $v $b
578 set c [lindex $vbackptr($v) $a]
579 set d [lindex $vleftptr($v) $a]
580 if {$c == 0} {
581 lset vdownptr($v) $b $d
582 } else {
583 lset vleftptr($v) $c $d
585 if {$d != 0} {
586 lset vbackptr($v) $d $c
588 if {[lindex $vlastins($v) $b] == $a} {
589 lset vlastins($v) $b $c
591 lset vupptr($v) $a $ka
592 set c [lindex $vlastins($v) $ka]
593 if {$c == 0 || \
594 [string compare $tok [lindex $varctok($v) $c]] < 0} {
595 set c $ka
596 set b [lindex $vdownptr($v) $ka]
597 } else {
598 set b [lindex $vleftptr($v) $c]
600 while {$b != 0 && \
601 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
602 set c $b
603 set b [lindex $vleftptr($v) $c]
605 if {$c == $ka} {
606 lset vdownptr($v) $ka $a
607 lset vbackptr($v) $a 0
608 } else {
609 lset vleftptr($v) $c $a
610 lset vbackptr($v) $a $c
612 lset vleftptr($v) $a $b
613 if {$b != 0} {
614 lset vbackptr($v) $b $a
616 lset vlastins($v) $ka $a
619 foreach id [array names sortkids] {
620 if {[llength $children($v,$id)] > 1} {
621 set children($v,$id) [lsort -command [list vtokcmp $v] \
622 $children($v,$id)]
625 set t2 [clock clicks -milliseconds]
626 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
629 # Fix up the graph after we have found out that in view $v,
630 # $p (a commit that we have already seen) is actually the parent
631 # of the last commit in arc $a.
632 proc fix_reversal {p a v} {
633 global varcid varcstart varctok vupptr
635 set pa $varcid($v,$p)
636 if {$p ne [lindex $varcstart($v) $pa]} {
637 splitvarc $p $v
638 set pa $varcid($v,$p)
640 # seeds always need to be renumbered
641 if {[lindex $vupptr($v) $pa] == 0 ||
642 [string compare [lindex $varctok($v) $a] \
643 [lindex $varctok($v) $pa]] > 0} {
644 renumbervarc $pa $v
648 proc insertrow {id p v} {
649 global cmitlisted children parents varcid varctok vtokmod
650 global varccommits ordertok commitidx numcommits curview
651 global targetid targetrow
653 readcommit $id
654 set vid $v,$id
655 set cmitlisted($vid) 1
656 set children($vid) {}
657 set parents($vid) [list $p]
658 set a [newvarc $v $id]
659 set varcid($vid) $a
660 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
661 modify_arc $v $a
663 lappend varccommits($v,$a) $id
664 set vp $v,$p
665 if {[llength [lappend children($vp) $id]] > 1} {
666 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
667 catch {unset ordertok}
669 fix_reversal $p $a $v
670 incr commitidx($v)
671 if {$v == $curview} {
672 set numcommits $commitidx($v)
673 setcanvscroll
674 if {[info exists targetid]} {
675 if {![comes_before $targetid $p]} {
676 incr targetrow
682 proc insertfakerow {id p} {
683 global varcid varccommits parents children cmitlisted
684 global commitidx varctok vtokmod targetid targetrow curview numcommits
686 set v $curview
687 set a $varcid($v,$p)
688 set i [lsearch -exact $varccommits($v,$a) $p]
689 if {$i < 0} {
690 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
691 return
693 set children($v,$id) {}
694 set parents($v,$id) [list $p]
695 set varcid($v,$id) $a
696 lappend children($v,$p) $id
697 set cmitlisted($v,$id) 1
698 set numcommits [incr commitidx($v)]
699 # note we deliberately don't update varcstart($v) even if $i == 0
700 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
701 modify_arc $v $a $i
702 if {[info exists targetid]} {
703 if {![comes_before $targetid $p]} {
704 incr targetrow
707 setcanvscroll
708 drawvisible
711 proc removefakerow {id} {
712 global varcid varccommits parents children commitidx
713 global varctok vtokmod cmitlisted currentid selectedline
714 global targetid curview numcommits
716 set v $curview
717 if {[llength $parents($v,$id)] != 1} {
718 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
719 return
721 set p [lindex $parents($v,$id) 0]
722 set a $varcid($v,$id)
723 set i [lsearch -exact $varccommits($v,$a) $id]
724 if {$i < 0} {
725 puts "oops: removefakerow can't find [shortids $id] on arc $a"
726 return
728 unset varcid($v,$id)
729 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
730 unset parents($v,$id)
731 unset children($v,$id)
732 unset cmitlisted($v,$id)
733 set numcommits [incr commitidx($v) -1]
734 set j [lsearch -exact $children($v,$p) $id]
735 if {$j >= 0} {
736 set children($v,$p) [lreplace $children($v,$p) $j $j]
738 modify_arc $v $a $i
739 if {[info exist currentid] && $id eq $currentid} {
740 unset currentid
741 unset selectedline
743 if {[info exists targetid] && $targetid eq $id} {
744 set targetid $p
746 setcanvscroll
747 drawvisible
750 proc first_real_child {vp} {
751 global children nullid nullid2
753 foreach id $children($vp) {
754 if {$id ne $nullid && $id ne $nullid2} {
755 return $id
758 return {}
761 proc last_real_child {vp} {
762 global children nullid nullid2
764 set kids $children($vp)
765 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
766 set id [lindex $kids $i]
767 if {$id ne $nullid && $id ne $nullid2} {
768 return $id
771 return {}
774 proc vtokcmp {v a b} {
775 global varctok varcid
777 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
778 [lindex $varctok($v) $varcid($v,$b)]]
781 # This assumes that if lim is not given, the caller has checked that
782 # arc a's token is less than $vtokmod($v)
783 proc modify_arc {v a {lim {}}} {
784 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
786 if {$lim ne {}} {
787 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
788 if {$c > 0} return
789 if {$c == 0} {
790 set r [lindex $varcrow($v) $a]
791 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
794 set vtokmod($v) [lindex $varctok($v) $a]
795 set varcmod($v) $a
796 if {$v == $curview} {
797 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
798 set a [lindex $vupptr($v) $a]
799 set lim {}
801 set r 0
802 if {$a != 0} {
803 if {$lim eq {}} {
804 set lim [llength $varccommits($v,$a)]
806 set r [expr {[lindex $varcrow($v) $a] + $lim}]
808 set vrowmod($v) $r
809 undolayout $r
813 proc update_arcrows {v} {
814 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
815 global varcid vrownum varcorder varcix varccommits
816 global vupptr vdownptr vleftptr varctok
817 global displayorder parentlist curview cached_commitrow
819 if {$vrowmod($v) == $commitidx($v)} return
820 if {$v == $curview} {
821 if {[llength $displayorder] > $vrowmod($v)} {
822 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
823 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
825 catch {unset cached_commitrow}
827 set narctot [expr {[llength $varctok($v)] - 1}]
828 set a $varcmod($v)
829 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
830 # go up the tree until we find something that has a row number,
831 # or we get to a seed
832 set a [lindex $vupptr($v) $a]
834 if {$a == 0} {
835 set a [lindex $vdownptr($v) 0]
836 if {$a == 0} return
837 set vrownum($v) {0}
838 set varcorder($v) [list $a]
839 lset varcix($v) $a 0
840 lset varcrow($v) $a 0
841 set arcn 0
842 set row 0
843 } else {
844 set arcn [lindex $varcix($v) $a]
845 if {[llength $vrownum($v)] > $arcn + 1} {
846 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
847 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
849 set row [lindex $varcrow($v) $a]
851 while {1} {
852 set p $a
853 incr row [llength $varccommits($v,$a)]
854 # go down if possible
855 set b [lindex $vdownptr($v) $a]
856 if {$b == 0} {
857 # if not, go left, or go up until we can go left
858 while {$a != 0} {
859 set b [lindex $vleftptr($v) $a]
860 if {$b != 0} break
861 set a [lindex $vupptr($v) $a]
863 if {$a == 0} break
865 set a $b
866 incr arcn
867 lappend vrownum($v) $row
868 lappend varcorder($v) $a
869 lset varcix($v) $a $arcn
870 lset varcrow($v) $a $row
872 set vtokmod($v) [lindex $varctok($v) $p]
873 set varcmod($v) $p
874 set vrowmod($v) $row
875 if {[info exists currentid]} {
876 set selectedline [rowofcommit $currentid]
880 # Test whether view $v contains commit $id
881 proc commitinview {id v} {
882 global varcid
884 return [info exists varcid($v,$id)]
887 # Return the row number for commit $id in the current view
888 proc rowofcommit {id} {
889 global varcid varccommits varcrow curview cached_commitrow
890 global varctok vtokmod
892 set v $curview
893 if {![info exists varcid($v,$id)]} {
894 puts "oops rowofcommit no arc for [shortids $id]"
895 return {}
897 set a $varcid($v,$id)
898 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
899 update_arcrows $v
901 if {[info exists cached_commitrow($id)]} {
902 return $cached_commitrow($id)
904 set i [lsearch -exact $varccommits($v,$a) $id]
905 if {$i < 0} {
906 puts "oops didn't find commit [shortids $id] in arc $a"
907 return {}
909 incr i [lindex $varcrow($v) $a]
910 set cached_commitrow($id) $i
911 return $i
914 # Returns 1 if a is on an earlier row than b, otherwise 0
915 proc comes_before {a b} {
916 global varcid varctok curview
918 set v $curview
919 if {$a eq $b || ![info exists varcid($v,$a)] || \
920 ![info exists varcid($v,$b)]} {
921 return 0
923 if {$varcid($v,$a) != $varcid($v,$b)} {
924 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
925 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
927 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
930 proc bsearch {l elt} {
931 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
932 return 0
934 set lo 0
935 set hi [llength $l]
936 while {$hi - $lo > 1} {
937 set mid [expr {int(($lo + $hi) / 2)}]
938 set t [lindex $l $mid]
939 if {$elt < $t} {
940 set hi $mid
941 } elseif {$elt > $t} {
942 set lo $mid
943 } else {
944 return $mid
947 return $lo
950 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
951 proc make_disporder {start end} {
952 global vrownum curview commitidx displayorder parentlist
953 global varccommits varcorder parents vrowmod varcrow
954 global d_valid_start d_valid_end
956 if {$end > $vrowmod($curview)} {
957 update_arcrows $curview
959 set ai [bsearch $vrownum($curview) $start]
960 set start [lindex $vrownum($curview) $ai]
961 set narc [llength $vrownum($curview)]
962 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
963 set a [lindex $varcorder($curview) $ai]
964 set l [llength $displayorder]
965 set al [llength $varccommits($curview,$a)]
966 if {$l < $r + $al} {
967 if {$l < $r} {
968 set pad [ntimes [expr {$r - $l}] {}]
969 set displayorder [concat $displayorder $pad]
970 set parentlist [concat $parentlist $pad]
971 } elseif {$l > $r} {
972 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
973 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
975 foreach id $varccommits($curview,$a) {
976 lappend displayorder $id
977 lappend parentlist $parents($curview,$id)
979 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
980 set i $r
981 foreach id $varccommits($curview,$a) {
982 lset displayorder $i $id
983 lset parentlist $i $parents($curview,$id)
984 incr i
987 incr r $al
991 proc commitonrow {row} {
992 global displayorder
994 set id [lindex $displayorder $row]
995 if {$id eq {}} {
996 make_disporder $row [expr {$row + 1}]
997 set id [lindex $displayorder $row]
999 return $id
1002 proc closevarcs {v} {
1003 global varctok varccommits varcid parents children
1004 global cmitlisted commitidx commitinterest vtokmod
1006 set missing_parents 0
1007 set scripts {}
1008 set narcs [llength $varctok($v)]
1009 for {set a 1} {$a < $narcs} {incr a} {
1010 set id [lindex $varccommits($v,$a) end]
1011 foreach p $parents($v,$id) {
1012 if {[info exists varcid($v,$p)]} continue
1013 # add p as a new commit
1014 incr missing_parents
1015 set cmitlisted($v,$p) 0
1016 set parents($v,$p) {}
1017 if {[llength $children($v,$p)] == 1 &&
1018 [llength $parents($v,$id)] == 1} {
1019 set b $a
1020 } else {
1021 set b [newvarc $v $p]
1023 set varcid($v,$p) $b
1024 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1025 modify_arc $v $b
1027 lappend varccommits($v,$b) $p
1028 incr commitidx($v)
1029 if {[info exists commitinterest($p)]} {
1030 foreach script $commitinterest($p) {
1031 lappend scripts [string map [list "%I" $p] $script]
1033 unset commitinterest($id)
1037 if {$missing_parents > 0} {
1038 foreach s $scripts {
1039 eval $s
1044 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1045 # Assumes we already have an arc for $rwid.
1046 proc rewrite_commit {v id rwid} {
1047 global children parents varcid varctok vtokmod varccommits
1049 foreach ch $children($v,$id) {
1050 # make $rwid be $ch's parent in place of $id
1051 set i [lsearch -exact $parents($v,$ch) $id]
1052 if {$i < 0} {
1053 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1055 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1056 # add $ch to $rwid's children and sort the list if necessary
1057 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1058 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1059 $children($v,$rwid)]
1061 # fix the graph after joining $id to $rwid
1062 set a $varcid($v,$ch)
1063 fix_reversal $rwid $a $v
1064 # parentlist is wrong for the last element of arc $a
1065 # even if displayorder is right, hence the 3rd arg here
1066 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1070 proc getcommitlines {fd inst view updating} {
1071 global cmitlisted commitinterest leftover
1072 global commitidx commitdata vdatemode
1073 global parents children curview hlview
1074 global idpending ordertok
1075 global varccommits varcid varctok vtokmod vfilelimit
1077 set stuff [read $fd 500000]
1078 # git log doesn't terminate the last commit with a null...
1079 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1080 set stuff "\0"
1082 if {$stuff == {}} {
1083 if {![eof $fd]} {
1084 return 1
1086 global commfd viewcomplete viewactive viewname progresscoords
1087 global viewinstances
1088 unset commfd($inst)
1089 set i [lsearch -exact $viewinstances($view) $inst]
1090 if {$i >= 0} {
1091 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1093 # set it blocking so we wait for the process to terminate
1094 fconfigure $fd -blocking 1
1095 if {[catch {close $fd} err]} {
1096 set fv {}
1097 if {$view != $curview} {
1098 set fv " for the \"$viewname($view)\" view"
1100 if {[string range $err 0 4] == "usage"} {
1101 set err "Gitk: error reading commits$fv:\
1102 bad arguments to git log."
1103 if {$viewname($view) eq "Command line"} {
1104 append err \
1105 " (Note: arguments to gitk are passed to git log\
1106 to allow selection of commits to be displayed.)"
1108 } else {
1109 set err "Error reading commits$fv: $err"
1111 error_popup $err
1113 if {[incr viewactive($view) -1] <= 0} {
1114 set viewcomplete($view) 1
1115 # Check if we have seen any ids listed as parents that haven't
1116 # appeared in the list
1117 closevarcs $view
1118 notbusy $view
1119 set progresscoords {0 0}
1120 adjustprogress
1122 if {$view == $curview} {
1123 run chewcommits
1125 return 0
1127 set start 0
1128 set gotsome 0
1129 set scripts {}
1130 while 1 {
1131 set i [string first "\0" $stuff $start]
1132 if {$i < 0} {
1133 append leftover($inst) [string range $stuff $start end]
1134 break
1136 if {$start == 0} {
1137 set cmit $leftover($inst)
1138 append cmit [string range $stuff 0 [expr {$i - 1}]]
1139 set leftover($inst) {}
1140 } else {
1141 set cmit [string range $stuff $start [expr {$i - 1}]]
1143 set start [expr {$i + 1}]
1144 set j [string first "\n" $cmit]
1145 set ok 0
1146 set listed 1
1147 if {$j >= 0 && [string match "commit *" $cmit]} {
1148 set ids [string range $cmit 7 [expr {$j - 1}]]
1149 if {[string match {[-^<>]*} $ids]} {
1150 switch -- [string index $ids 0] {
1151 "-" {set listed 0}
1152 "^" {set listed 2}
1153 "<" {set listed 3}
1154 ">" {set listed 4}
1156 set ids [string range $ids 1 end]
1158 set ok 1
1159 foreach id $ids {
1160 if {[string length $id] != 40} {
1161 set ok 0
1162 break
1166 if {!$ok} {
1167 set shortcmit $cmit
1168 if {[string length $shortcmit] > 80} {
1169 set shortcmit "[string range $shortcmit 0 80]..."
1171 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1172 exit 1
1174 set id [lindex $ids 0]
1175 set vid $view,$id
1177 if {!$listed && $updating && ![info exists varcid($vid)] &&
1178 $vfilelimit($view) ne {}} {
1179 # git log doesn't rewrite parents for unlisted commits
1180 # when doing path limiting, so work around that here
1181 # by working out the rewritten parent with git rev-list
1182 # and if we already know about it, using the rewritten
1183 # parent as a substitute parent for $id's children.
1184 if {![catch {
1185 set rwid [exec git rev-list --first-parent --max-count=1 \
1186 $id -- $vfilelimit($view)]
1187 }]} {
1188 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1189 # use $rwid in place of $id
1190 rewrite_commit $view $id $rwid
1191 continue
1196 set a 0
1197 if {[info exists varcid($vid)]} {
1198 if {$cmitlisted($vid) || !$listed} continue
1199 set a $varcid($vid)
1201 if {$listed} {
1202 set olds [lrange $ids 1 end]
1203 } else {
1204 set olds {}
1206 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1207 set cmitlisted($vid) $listed
1208 set parents($vid) $olds
1209 if {![info exists children($vid)]} {
1210 set children($vid) {}
1211 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1212 set k [lindex $children($vid) 0]
1213 if {[llength $parents($view,$k)] == 1 &&
1214 (!$vdatemode($view) ||
1215 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1216 set a $varcid($view,$k)
1219 if {$a == 0} {
1220 # new arc
1221 set a [newvarc $view $id]
1223 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1224 modify_arc $view $a
1226 if {![info exists varcid($vid)]} {
1227 set varcid($vid) $a
1228 lappend varccommits($view,$a) $id
1229 incr commitidx($view)
1232 set i 0
1233 foreach p $olds {
1234 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1235 set vp $view,$p
1236 if {[llength [lappend children($vp) $id]] > 1 &&
1237 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1238 set children($vp) [lsort -command [list vtokcmp $view] \
1239 $children($vp)]
1240 catch {unset ordertok}
1242 if {[info exists varcid($view,$p)]} {
1243 fix_reversal $p $a $view
1246 incr i
1249 if {[info exists commitinterest($id)]} {
1250 foreach script $commitinterest($id) {
1251 lappend scripts [string map [list "%I" $id] $script]
1253 unset commitinterest($id)
1255 set gotsome 1
1257 if {$gotsome} {
1258 global numcommits hlview
1260 if {$view == $curview} {
1261 set numcommits $commitidx($view)
1262 run chewcommits
1264 if {[info exists hlview] && $view == $hlview} {
1265 # we never actually get here...
1266 run vhighlightmore
1268 foreach s $scripts {
1269 eval $s
1271 if {$view == $curview} {
1272 # update progress bar
1273 global progressdirn progresscoords proglastnc
1274 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1275 set proglastnc $commitidx($view)
1276 set l [lindex $progresscoords 0]
1277 set r [lindex $progresscoords 1]
1278 if {$progressdirn} {
1279 set r [expr {$r + $inc}]
1280 if {$r >= 1.0} {
1281 set r 1.0
1282 set progressdirn 0
1284 if {$r > 0.2} {
1285 set l [expr {$r - 0.2}]
1287 } else {
1288 set l [expr {$l - $inc}]
1289 if {$l <= 0.0} {
1290 set l 0.0
1291 set progressdirn 1
1293 set r [expr {$l + 0.2}]
1295 set progresscoords [list $l $r]
1296 adjustprogress
1299 return 2
1302 proc chewcommits {} {
1303 global curview hlview viewcomplete
1304 global pending_select
1306 layoutmore
1307 if {$viewcomplete($curview)} {
1308 global commitidx varctok
1309 global numcommits startmsecs
1310 global mainheadid nullid
1312 if {[info exists pending_select]} {
1313 set row [first_real_row]
1314 selectline $row 1
1316 if {$commitidx($curview) > 0} {
1317 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1318 #puts "overall $ms ms for $numcommits commits"
1319 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1320 } else {
1321 show_status [mc "No commits selected"]
1323 notbusy layout
1325 return 0
1328 proc readcommit {id} {
1329 if {[catch {set contents [exec git cat-file commit $id]}]} return
1330 parsecommit $id $contents 0
1333 proc parsecommit {id contents listed} {
1334 global commitinfo cdate
1336 set inhdr 1
1337 set comment {}
1338 set headline {}
1339 set auname {}
1340 set audate {}
1341 set comname {}
1342 set comdate {}
1343 set hdrend [string first "\n\n" $contents]
1344 if {$hdrend < 0} {
1345 # should never happen...
1346 set hdrend [string length $contents]
1348 set header [string range $contents 0 [expr {$hdrend - 1}]]
1349 set comment [string range $contents [expr {$hdrend + 2}] end]
1350 foreach line [split $header "\n"] {
1351 set tag [lindex $line 0]
1352 if {$tag == "author"} {
1353 set audate [lindex $line end-1]
1354 set auname [lrange $line 1 end-2]
1355 } elseif {$tag == "committer"} {
1356 set comdate [lindex $line end-1]
1357 set comname [lrange $line 1 end-2]
1360 set headline {}
1361 # take the first non-blank line of the comment as the headline
1362 set headline [string trimleft $comment]
1363 set i [string first "\n" $headline]
1364 if {$i >= 0} {
1365 set headline [string range $headline 0 $i]
1367 set headline [string trimright $headline]
1368 set i [string first "\r" $headline]
1369 if {$i >= 0} {
1370 set headline [string trimright [string range $headline 0 $i]]
1372 if {!$listed} {
1373 # git log indents the comment by 4 spaces;
1374 # if we got this via git cat-file, add the indentation
1375 set newcomment {}
1376 foreach line [split $comment "\n"] {
1377 append newcomment " "
1378 append newcomment $line
1379 append newcomment "\n"
1381 set comment $newcomment
1383 if {$comdate != {}} {
1384 set cdate($id) $comdate
1386 set commitinfo($id) [list $headline $auname $audate \
1387 $comname $comdate $comment]
1390 proc getcommit {id} {
1391 global commitdata commitinfo
1393 if {[info exists commitdata($id)]} {
1394 parsecommit $id $commitdata($id) 1
1395 } else {
1396 readcommit $id
1397 if {![info exists commitinfo($id)]} {
1398 set commitinfo($id) [list [mc "No commit information available"]]
1401 return 1
1404 proc readrefs {} {
1405 global tagids idtags headids idheads tagobjid
1406 global otherrefids idotherrefs mainhead mainheadid
1408 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1409 catch {unset $v}
1411 set refd [open [list | git show-ref -d] r]
1412 while {[gets $refd line] >= 0} {
1413 if {[string index $line 40] ne " "} continue
1414 set id [string range $line 0 39]
1415 set ref [string range $line 41 end]
1416 if {![string match "refs/*" $ref]} continue
1417 set name [string range $ref 5 end]
1418 if {[string match "remotes/*" $name]} {
1419 if {![string match "*/HEAD" $name]} {
1420 set headids($name) $id
1421 lappend idheads($id) $name
1423 } elseif {[string match "heads/*" $name]} {
1424 set name [string range $name 6 end]
1425 set headids($name) $id
1426 lappend idheads($id) $name
1427 } elseif {[string match "tags/*" $name]} {
1428 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1429 # which is what we want since the former is the commit ID
1430 set name [string range $name 5 end]
1431 if {[string match "*^{}" $name]} {
1432 set name [string range $name 0 end-3]
1433 } else {
1434 set tagobjid($name) $id
1436 set tagids($name) $id
1437 lappend idtags($id) $name
1438 } else {
1439 set otherrefids($name) $id
1440 lappend idotherrefs($id) $name
1443 catch {close $refd}
1444 set mainhead {}
1445 set mainheadid {}
1446 catch {
1447 set thehead [exec git symbolic-ref HEAD]
1448 if {[string match "refs/heads/*" $thehead]} {
1449 set mainhead [string range $thehead 11 end]
1450 if {[info exists headids($mainhead)]} {
1451 set mainheadid $headids($mainhead)
1457 # skip over fake commits
1458 proc first_real_row {} {
1459 global nullid nullid2 numcommits
1461 for {set row 0} {$row < $numcommits} {incr row} {
1462 set id [commitonrow $row]
1463 if {$id ne $nullid && $id ne $nullid2} {
1464 break
1467 return $row
1470 # update things for a head moved to a child of its previous location
1471 proc movehead {id name} {
1472 global headids idheads
1474 removehead $headids($name) $name
1475 set headids($name) $id
1476 lappend idheads($id) $name
1479 # update things when a head has been removed
1480 proc removehead {id name} {
1481 global headids idheads
1483 if {$idheads($id) eq $name} {
1484 unset idheads($id)
1485 } else {
1486 set i [lsearch -exact $idheads($id) $name]
1487 if {$i >= 0} {
1488 set idheads($id) [lreplace $idheads($id) $i $i]
1491 unset headids($name)
1494 proc show_error {w top msg} {
1495 message $w.m -text $msg -justify center -aspect 400
1496 pack $w.m -side top -fill x -padx 20 -pady 20
1497 button $w.ok -text [mc OK] -command "destroy $top"
1498 pack $w.ok -side bottom -fill x
1499 bind $top <Visibility> "grab $top; focus $top"
1500 bind $top <Key-Return> "destroy $top"
1501 tkwait window $top
1504 proc error_popup msg {
1505 set w .error
1506 toplevel $w
1507 wm transient $w .
1508 show_error $w $w $msg
1511 proc confirm_popup msg {
1512 global confirm_ok
1513 set confirm_ok 0
1514 set w .confirm
1515 toplevel $w
1516 wm transient $w .
1517 message $w.m -text $msg -justify center -aspect 400
1518 pack $w.m -side top -fill x -padx 20 -pady 20
1519 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1520 pack $w.ok -side left -fill x
1521 button $w.cancel -text [mc Cancel] -command "destroy $w"
1522 pack $w.cancel -side right -fill x
1523 bind $w <Visibility> "grab $w; focus $w"
1524 tkwait window $w
1525 return $confirm_ok
1528 proc setoptions {} {
1529 option add *Panedwindow.showHandle 1 startupFile
1530 option add *Panedwindow.sashRelief raised startupFile
1531 option add *Button.font uifont startupFile
1532 option add *Checkbutton.font uifont startupFile
1533 option add *Radiobutton.font uifont startupFile
1534 option add *Menu.font uifont startupFile
1535 option add *Menubutton.font uifont startupFile
1536 option add *Label.font uifont startupFile
1537 option add *Message.font uifont startupFile
1538 option add *Entry.font uifont startupFile
1541 proc makewindow {} {
1542 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1543 global tabstop
1544 global findtype findtypemenu findloc findstring fstring geometry
1545 global entries sha1entry sha1string sha1but
1546 global diffcontextstring diffcontext
1547 global ignorespace
1548 global maincursor textcursor curtextcursor
1549 global rowctxmenu fakerowmenu mergemax wrapcomment
1550 global highlight_files gdttype
1551 global searchstring sstring
1552 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1553 global headctxmenu progresscanv progressitem progresscoords statusw
1554 global fprogitem fprogcoord lastprogupdate progupdatepending
1555 global rprogitem rprogcoord
1556 global have_tk85
1558 menu .bar
1559 .bar add cascade -label [mc "File"] -menu .bar.file
1560 menu .bar.file
1561 .bar.file add command -label [mc "Update"] -command updatecommits
1562 .bar.file add command -label [mc "Reload"] -command reloadcommits
1563 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1564 .bar.file add command -label [mc "List references"] -command showrefs
1565 .bar.file add command -label [mc "Quit"] -command doquit
1566 menu .bar.edit
1567 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1568 .bar.edit add command -label [mc "Preferences"] -command doprefs
1570 menu .bar.view
1571 .bar add cascade -label [mc "View"] -menu .bar.view
1572 .bar.view add command -label [mc "New view..."] -command {newview 0}
1573 .bar.view add command -label [mc "Edit view..."] -command editview \
1574 -state disabled
1575 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1576 .bar.view add separator
1577 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1578 -variable selectedview -value 0
1580 menu .bar.help
1581 .bar add cascade -label [mc "Help"] -menu .bar.help
1582 .bar.help add command -label [mc "About gitk"] -command about
1583 .bar.help add command -label [mc "Key bindings"] -command keys
1584 .bar.help configure
1585 . configure -menu .bar
1587 # the gui has upper and lower half, parts of a paned window.
1588 panedwindow .ctop -orient vertical
1590 # possibly use assumed geometry
1591 if {![info exists geometry(pwsash0)]} {
1592 set geometry(topheight) [expr {15 * $linespc}]
1593 set geometry(topwidth) [expr {80 * $charspc}]
1594 set geometry(botheight) [expr {15 * $linespc}]
1595 set geometry(botwidth) [expr {50 * $charspc}]
1596 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1597 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1600 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1601 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1602 frame .tf.histframe
1603 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1605 # create three canvases
1606 set cscroll .tf.histframe.csb
1607 set canv .tf.histframe.pwclist.canv
1608 canvas $canv \
1609 -selectbackground $selectbgcolor \
1610 -background $bgcolor -bd 0 \
1611 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1612 .tf.histframe.pwclist add $canv
1613 set canv2 .tf.histframe.pwclist.canv2
1614 canvas $canv2 \
1615 -selectbackground $selectbgcolor \
1616 -background $bgcolor -bd 0 -yscrollincr $linespc
1617 .tf.histframe.pwclist add $canv2
1618 set canv3 .tf.histframe.pwclist.canv3
1619 canvas $canv3 \
1620 -selectbackground $selectbgcolor \
1621 -background $bgcolor -bd 0 -yscrollincr $linespc
1622 .tf.histframe.pwclist add $canv3
1623 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1624 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1626 # a scroll bar to rule them
1627 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1628 pack $cscroll -side right -fill y
1629 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1630 lappend bglist $canv $canv2 $canv3
1631 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1633 # we have two button bars at bottom of top frame. Bar 1
1634 frame .tf.bar
1635 frame .tf.lbar -height 15
1637 set sha1entry .tf.bar.sha1
1638 set entries $sha1entry
1639 set sha1but .tf.bar.sha1label
1640 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1641 -command gotocommit -width 8
1642 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1643 pack .tf.bar.sha1label -side left
1644 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1645 trace add variable sha1string write sha1change
1646 pack $sha1entry -side left -pady 2
1648 image create bitmap bm-left -data {
1649 #define left_width 16
1650 #define left_height 16
1651 static unsigned char left_bits[] = {
1652 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1653 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1654 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1656 image create bitmap bm-right -data {
1657 #define right_width 16
1658 #define right_height 16
1659 static unsigned char right_bits[] = {
1660 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1661 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1662 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1664 button .tf.bar.leftbut -image bm-left -command goback \
1665 -state disabled -width 26
1666 pack .tf.bar.leftbut -side left -fill y
1667 button .tf.bar.rightbut -image bm-right -command goforw \
1668 -state disabled -width 26
1669 pack .tf.bar.rightbut -side left -fill y
1671 # Status label and progress bar
1672 set statusw .tf.bar.status
1673 label $statusw -width 15 -relief sunken
1674 pack $statusw -side left -padx 5
1675 set h [expr {[font metrics uifont -linespace] + 2}]
1676 set progresscanv .tf.bar.progress
1677 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1678 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1679 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1680 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1681 pack $progresscanv -side right -expand 1 -fill x
1682 set progresscoords {0 0}
1683 set fprogcoord 0
1684 set rprogcoord 0
1685 bind $progresscanv <Configure> adjustprogress
1686 set lastprogupdate [clock clicks -milliseconds]
1687 set progupdatepending 0
1689 # build up the bottom bar of upper window
1690 label .tf.lbar.flabel -text "[mc "Find"] "
1691 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1692 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1693 label .tf.lbar.flab2 -text " [mc "commit"] "
1694 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1695 -side left -fill y
1696 set gdttype [mc "containing:"]
1697 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1698 [mc "containing:"] \
1699 [mc "touching paths:"] \
1700 [mc "adding/removing string:"]]
1701 trace add variable gdttype write gdttype_change
1702 pack .tf.lbar.gdttype -side left -fill y
1704 set findstring {}
1705 set fstring .tf.lbar.findstring
1706 lappend entries $fstring
1707 entry $fstring -width 30 -font textfont -textvariable findstring
1708 trace add variable findstring write find_change
1709 set findtype [mc "Exact"]
1710 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1711 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1712 trace add variable findtype write findcom_change
1713 set findloc [mc "All fields"]
1714 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1715 [mc "Comments"] [mc "Author"] [mc "Committer"]
1716 trace add variable findloc write find_change
1717 pack .tf.lbar.findloc -side right
1718 pack .tf.lbar.findtype -side right
1719 pack $fstring -side left -expand 1 -fill x
1721 # Finish putting the upper half of the viewer together
1722 pack .tf.lbar -in .tf -side bottom -fill x
1723 pack .tf.bar -in .tf -side bottom -fill x
1724 pack .tf.histframe -fill both -side top -expand 1
1725 .ctop add .tf
1726 .ctop paneconfigure .tf -height $geometry(topheight)
1727 .ctop paneconfigure .tf -width $geometry(topwidth)
1729 # now build up the bottom
1730 panedwindow .pwbottom -orient horizontal
1732 # lower left, a text box over search bar, scroll bar to the right
1733 # if we know window height, then that will set the lower text height, otherwise
1734 # we set lower text height which will drive window height
1735 if {[info exists geometry(main)]} {
1736 frame .bleft -width $geometry(botwidth)
1737 } else {
1738 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1740 frame .bleft.top
1741 frame .bleft.mid
1742 frame .bleft.bottom
1744 button .bleft.top.search -text [mc "Search"] -command dosearch
1745 pack .bleft.top.search -side left -padx 5
1746 set sstring .bleft.top.sstring
1747 entry $sstring -width 20 -font textfont -textvariable searchstring
1748 lappend entries $sstring
1749 trace add variable searchstring write incrsearch
1750 pack $sstring -side left -expand 1 -fill x
1751 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1752 -command changediffdisp -variable diffelide -value {0 0}
1753 radiobutton .bleft.mid.old -text [mc "Old version"] \
1754 -command changediffdisp -variable diffelide -value {0 1}
1755 radiobutton .bleft.mid.new -text [mc "New version"] \
1756 -command changediffdisp -variable diffelide -value {1 0}
1757 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1758 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1759 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1760 -from 1 -increment 1 -to 10000000 \
1761 -validate all -validatecommand "diffcontextvalidate %P" \
1762 -textvariable diffcontextstring
1763 .bleft.mid.diffcontext set $diffcontext
1764 trace add variable diffcontextstring write diffcontextchange
1765 lappend entries .bleft.mid.diffcontext
1766 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1767 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1768 -command changeignorespace -variable ignorespace
1769 pack .bleft.mid.ignspace -side left -padx 5
1770 set ctext .bleft.bottom.ctext
1771 text $ctext -background $bgcolor -foreground $fgcolor \
1772 -state disabled -font textfont \
1773 -yscrollcommand scrolltext -wrap none \
1774 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1775 if {$have_tk85} {
1776 $ctext conf -tabstyle wordprocessor
1778 scrollbar .bleft.bottom.sb -command "$ctext yview"
1779 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1780 -width 10
1781 pack .bleft.top -side top -fill x
1782 pack .bleft.mid -side top -fill x
1783 grid $ctext .bleft.bottom.sb -sticky nsew
1784 grid .bleft.bottom.sbhorizontal -sticky ew
1785 grid columnconfigure .bleft.bottom 0 -weight 1
1786 grid rowconfigure .bleft.bottom 0 -weight 1
1787 grid rowconfigure .bleft.bottom 1 -weight 0
1788 pack .bleft.bottom -side top -fill both -expand 1
1789 lappend bglist $ctext
1790 lappend fglist $ctext
1792 $ctext tag conf comment -wrap $wrapcomment
1793 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1794 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1795 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1796 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1797 $ctext tag conf m0 -fore red
1798 $ctext tag conf m1 -fore blue
1799 $ctext tag conf m2 -fore green
1800 $ctext tag conf m3 -fore purple
1801 $ctext tag conf m4 -fore brown
1802 $ctext tag conf m5 -fore "#009090"
1803 $ctext tag conf m6 -fore magenta
1804 $ctext tag conf m7 -fore "#808000"
1805 $ctext tag conf m8 -fore "#009000"
1806 $ctext tag conf m9 -fore "#ff0080"
1807 $ctext tag conf m10 -fore cyan
1808 $ctext tag conf m11 -fore "#b07070"
1809 $ctext tag conf m12 -fore "#70b0f0"
1810 $ctext tag conf m13 -fore "#70f0b0"
1811 $ctext tag conf m14 -fore "#f0b070"
1812 $ctext tag conf m15 -fore "#ff70b0"
1813 $ctext tag conf mmax -fore darkgrey
1814 set mergemax 16
1815 $ctext tag conf mresult -font textfontbold
1816 $ctext tag conf msep -font textfontbold
1817 $ctext tag conf found -back yellow
1819 .pwbottom add .bleft
1820 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1822 # lower right
1823 frame .bright
1824 frame .bright.mode
1825 radiobutton .bright.mode.patch -text [mc "Patch"] \
1826 -command reselectline -variable cmitmode -value "patch"
1827 radiobutton .bright.mode.tree -text [mc "Tree"] \
1828 -command reselectline -variable cmitmode -value "tree"
1829 grid .bright.mode.patch .bright.mode.tree -sticky ew
1830 pack .bright.mode -side top -fill x
1831 set cflist .bright.cfiles
1832 set indent [font measure mainfont "nn"]
1833 text $cflist \
1834 -selectbackground $selectbgcolor \
1835 -background $bgcolor -foreground $fgcolor \
1836 -font mainfont \
1837 -tabs [list $indent [expr {2 * $indent}]] \
1838 -yscrollcommand ".bright.sb set" \
1839 -cursor [. cget -cursor] \
1840 -spacing1 1 -spacing3 1
1841 lappend bglist $cflist
1842 lappend fglist $cflist
1843 scrollbar .bright.sb -command "$cflist yview"
1844 pack .bright.sb -side right -fill y
1845 pack $cflist -side left -fill both -expand 1
1846 $cflist tag configure highlight \
1847 -background [$cflist cget -selectbackground]
1848 $cflist tag configure bold -font mainfontbold
1850 .pwbottom add .bright
1851 .ctop add .pwbottom
1853 # restore window width & height if known
1854 if {[info exists geometry(main)]} {
1855 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
1856 if {$w > [winfo screenwidth .]} {
1857 set w [winfo screenwidth .]
1859 if {$h > [winfo screenheight .]} {
1860 set h [winfo screenheight .]
1862 wm geometry . "${w}x$h"
1866 if {[tk windowingsystem] eq {aqua}} {
1867 set M1B M1
1868 } else {
1869 set M1B Control
1872 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1873 pack .ctop -fill both -expand 1
1874 bindall <1> {selcanvline %W %x %y}
1875 #bindall <B1-Motion> {selcanvline %W %x %y}
1876 if {[tk windowingsystem] == "win32"} {
1877 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1878 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1879 } else {
1880 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1881 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1882 if {[tk windowingsystem] eq "aqua"} {
1883 bindall <MouseWheel> {
1884 set delta [expr {- (%D)}]
1885 allcanvs yview scroll $delta units
1889 bindall <2> "canvscan mark %W %x %y"
1890 bindall <B2-Motion> "canvscan dragto %W %x %y"
1891 bindkey <Home> selfirstline
1892 bindkey <End> sellastline
1893 bind . <Key-Up> "selnextline -1"
1894 bind . <Key-Down> "selnextline 1"
1895 bind . <Shift-Key-Up> "dofind -1 0"
1896 bind . <Shift-Key-Down> "dofind 1 0"
1897 bindkey <Key-Right> "goforw"
1898 bindkey <Key-Left> "goback"
1899 bind . <Key-Prior> "selnextpage -1"
1900 bind . <Key-Next> "selnextpage 1"
1901 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1902 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1903 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1904 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1905 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1906 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1907 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1908 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1909 bindkey <Key-space> "$ctext yview scroll 1 pages"
1910 bindkey p "selnextline -1"
1911 bindkey n "selnextline 1"
1912 bindkey z "goback"
1913 bindkey x "goforw"
1914 bindkey i "selnextline -1"
1915 bindkey k "selnextline 1"
1916 bindkey j "goback"
1917 bindkey l "goforw"
1918 bindkey b "$ctext yview scroll -1 pages"
1919 bindkey d "$ctext yview scroll 18 units"
1920 bindkey u "$ctext yview scroll -18 units"
1921 bindkey / {dofind 1 1}
1922 bindkey <Key-Return> {dofind 1 1}
1923 bindkey ? {dofind -1 1}
1924 bindkey f nextfile
1925 bindkey <F5> updatecommits
1926 bind . <$M1B-q> doquit
1927 bind . <$M1B-f> {dofind 1 1}
1928 bind . <$M1B-g> {dofind 1 0}
1929 bind . <$M1B-r> dosearchback
1930 bind . <$M1B-s> dosearch
1931 bind . <$M1B-equal> {incrfont 1}
1932 bind . <$M1B-plus> {incrfont 1}
1933 bind . <$M1B-KP_Add> {incrfont 1}
1934 bind . <$M1B-minus> {incrfont -1}
1935 bind . <$M1B-KP_Subtract> {incrfont -1}
1936 wm protocol . WM_DELETE_WINDOW doquit
1937 bind . <Button-1> "click %W"
1938 bind $fstring <Key-Return> {dofind 1 1}
1939 bind $sha1entry <Key-Return> gotocommit
1940 bind $sha1entry <<PasteSelection>> clearsha1
1941 bind $cflist <1> {sel_flist %W %x %y; break}
1942 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1943 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1944 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1946 set maincursor [. cget -cursor]
1947 set textcursor [$ctext cget -cursor]
1948 set curtextcursor $textcursor
1950 set rowctxmenu .rowctxmenu
1951 menu $rowctxmenu -tearoff 0
1952 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1953 -command {diffvssel 0}
1954 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1955 -command {diffvssel 1}
1956 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1957 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1958 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1959 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1960 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1961 -command cherrypick
1962 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1963 -command resethead
1965 set fakerowmenu .fakerowmenu
1966 menu $fakerowmenu -tearoff 0
1967 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1968 -command {diffvssel 0}
1969 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1970 -command {diffvssel 1}
1971 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1972 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1973 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1974 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1976 set headctxmenu .headctxmenu
1977 menu $headctxmenu -tearoff 0
1978 $headctxmenu add command -label [mc "Check out this branch"] \
1979 -command cobranch
1980 $headctxmenu add command -label [mc "Remove this branch"] \
1981 -command rmbranch
1983 global flist_menu
1984 set flist_menu .flistctxmenu
1985 menu $flist_menu -tearoff 0
1986 $flist_menu add command -label [mc "Highlight this too"] \
1987 -command {flist_hl 0}
1988 $flist_menu add command -label [mc "Highlight this only"] \
1989 -command {flist_hl 1}
1992 # Windows sends all mouse wheel events to the current focused window, not
1993 # the one where the mouse hovers, so bind those events here and redirect
1994 # to the correct window
1995 proc windows_mousewheel_redirector {W X Y D} {
1996 global canv canv2 canv3
1997 set w [winfo containing -displayof $W $X $Y]
1998 if {$w ne ""} {
1999 set u [expr {$D < 0 ? 5 : -5}]
2000 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2001 allcanvs yview scroll $u units
2002 } else {
2003 catch {
2004 $w yview scroll $u units
2010 # mouse-2 makes all windows scan vertically, but only the one
2011 # the cursor is in scans horizontally
2012 proc canvscan {op w x y} {
2013 global canv canv2 canv3
2014 foreach c [list $canv $canv2 $canv3] {
2015 if {$c == $w} {
2016 $c scan $op $x $y
2017 } else {
2018 $c scan $op 0 $y
2023 proc scrollcanv {cscroll f0 f1} {
2024 $cscroll set $f0 $f1
2025 drawvisible
2026 flushhighlights
2029 # when we make a key binding for the toplevel, make sure
2030 # it doesn't get triggered when that key is pressed in the
2031 # find string entry widget.
2032 proc bindkey {ev script} {
2033 global entries
2034 bind . $ev $script
2035 set escript [bind Entry $ev]
2036 if {$escript == {}} {
2037 set escript [bind Entry <Key>]
2039 foreach e $entries {
2040 bind $e $ev "$escript; break"
2044 # set the focus back to the toplevel for any click outside
2045 # the entry widgets
2046 proc click {w} {
2047 global ctext entries
2048 foreach e [concat $entries $ctext] {
2049 if {$w == $e} return
2051 focus .
2054 # Adjust the progress bar for a change in requested extent or canvas size
2055 proc adjustprogress {} {
2056 global progresscanv progressitem progresscoords
2057 global fprogitem fprogcoord lastprogupdate progupdatepending
2058 global rprogitem rprogcoord
2060 set w [expr {[winfo width $progresscanv] - 4}]
2061 set x0 [expr {$w * [lindex $progresscoords 0]}]
2062 set x1 [expr {$w * [lindex $progresscoords 1]}]
2063 set h [winfo height $progresscanv]
2064 $progresscanv coords $progressitem $x0 0 $x1 $h
2065 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2066 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2067 set now [clock clicks -milliseconds]
2068 if {$now >= $lastprogupdate + 100} {
2069 set progupdatepending 0
2070 update
2071 } elseif {!$progupdatepending} {
2072 set progupdatepending 1
2073 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2077 proc doprogupdate {} {
2078 global lastprogupdate progupdatepending
2080 if {$progupdatepending} {
2081 set progupdatepending 0
2082 set lastprogupdate [clock clicks -milliseconds]
2083 update
2087 proc savestuff {w} {
2088 global canv canv2 canv3 mainfont textfont uifont tabstop
2089 global stuffsaved findmergefiles maxgraphpct
2090 global maxwidth showneartags showlocalchanges
2091 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2092 global cmitmode wrapcomment datetimeformat limitdiffs
2093 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2094 global autoselect
2096 if {$stuffsaved} return
2097 if {![winfo viewable .]} return
2098 catch {
2099 set f [open "~/.gitk-new" w]
2100 puts $f [list set mainfont $mainfont]
2101 puts $f [list set textfont $textfont]
2102 puts $f [list set uifont $uifont]
2103 puts $f [list set tabstop $tabstop]
2104 puts $f [list set findmergefiles $findmergefiles]
2105 puts $f [list set maxgraphpct $maxgraphpct]
2106 puts $f [list set maxwidth $maxwidth]
2107 puts $f [list set cmitmode $cmitmode]
2108 puts $f [list set wrapcomment $wrapcomment]
2109 puts $f [list set autoselect $autoselect]
2110 puts $f [list set showneartags $showneartags]
2111 puts $f [list set showlocalchanges $showlocalchanges]
2112 puts $f [list set datetimeformat $datetimeformat]
2113 puts $f [list set limitdiffs $limitdiffs]
2114 puts $f [list set bgcolor $bgcolor]
2115 puts $f [list set fgcolor $fgcolor]
2116 puts $f [list set colors $colors]
2117 puts $f [list set diffcolors $diffcolors]
2118 puts $f [list set diffcontext $diffcontext]
2119 puts $f [list set selectbgcolor $selectbgcolor]
2121 puts $f "set geometry(main) [wm geometry .]"
2122 puts $f "set geometry(topwidth) [winfo width .tf]"
2123 puts $f "set geometry(topheight) [winfo height .tf]"
2124 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2125 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2126 puts $f "set geometry(botwidth) [winfo width .bleft]"
2127 puts $f "set geometry(botheight) [winfo height .bleft]"
2129 puts -nonewline $f "set permviews {"
2130 for {set v 0} {$v < $nextviewnum} {incr v} {
2131 if {$viewperm($v)} {
2132 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2135 puts $f "}"
2136 close $f
2137 file rename -force "~/.gitk-new" "~/.gitk"
2139 set stuffsaved 1
2142 proc resizeclistpanes {win w} {
2143 global oldwidth
2144 if {[info exists oldwidth($win)]} {
2145 set s0 [$win sash coord 0]
2146 set s1 [$win sash coord 1]
2147 if {$w < 60} {
2148 set sash0 [expr {int($w/2 - 2)}]
2149 set sash1 [expr {int($w*5/6 - 2)}]
2150 } else {
2151 set factor [expr {1.0 * $w / $oldwidth($win)}]
2152 set sash0 [expr {int($factor * [lindex $s0 0])}]
2153 set sash1 [expr {int($factor * [lindex $s1 0])}]
2154 if {$sash0 < 30} {
2155 set sash0 30
2157 if {$sash1 < $sash0 + 20} {
2158 set sash1 [expr {$sash0 + 20}]
2160 if {$sash1 > $w - 10} {
2161 set sash1 [expr {$w - 10}]
2162 if {$sash0 > $sash1 - 20} {
2163 set sash0 [expr {$sash1 - 20}]
2167 $win sash place 0 $sash0 [lindex $s0 1]
2168 $win sash place 1 $sash1 [lindex $s1 1]
2170 set oldwidth($win) $w
2173 proc resizecdetpanes {win w} {
2174 global oldwidth
2175 if {[info exists oldwidth($win)]} {
2176 set s0 [$win sash coord 0]
2177 if {$w < 60} {
2178 set sash0 [expr {int($w*3/4 - 2)}]
2179 } else {
2180 set factor [expr {1.0 * $w / $oldwidth($win)}]
2181 set sash0 [expr {int($factor * [lindex $s0 0])}]
2182 if {$sash0 < 45} {
2183 set sash0 45
2185 if {$sash0 > $w - 15} {
2186 set sash0 [expr {$w - 15}]
2189 $win sash place 0 $sash0 [lindex $s0 1]
2191 set oldwidth($win) $w
2194 proc allcanvs args {
2195 global canv canv2 canv3
2196 eval $canv $args
2197 eval $canv2 $args
2198 eval $canv3 $args
2201 proc bindall {event action} {
2202 global canv canv2 canv3
2203 bind $canv $event $action
2204 bind $canv2 $event $action
2205 bind $canv3 $event $action
2208 proc about {} {
2209 global uifont
2210 set w .about
2211 if {[winfo exists $w]} {
2212 raise $w
2213 return
2215 toplevel $w
2216 wm title $w [mc "About gitk"]
2217 message $w.m -text [mc "
2218 Gitk - a commit viewer for git
2220 Copyright © 2005-2006 Paul Mackerras
2222 Use and redistribute under the terms of the GNU General Public License"] \
2223 -justify center -aspect 400 -border 2 -bg white -relief groove
2224 pack $w.m -side top -fill x -padx 2 -pady 2
2225 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2226 pack $w.ok -side bottom
2227 bind $w <Visibility> "focus $w.ok"
2228 bind $w <Key-Escape> "destroy $w"
2229 bind $w <Key-Return> "destroy $w"
2232 proc keys {} {
2233 set w .keys
2234 if {[winfo exists $w]} {
2235 raise $w
2236 return
2238 if {[tk windowingsystem] eq {aqua}} {
2239 set M1T Cmd
2240 } else {
2241 set M1T Ctrl
2243 toplevel $w
2244 wm title $w [mc "Gitk key bindings"]
2245 message $w.m -text "
2246 [mc "Gitk key bindings:"]
2248 [mc "<%s-Q> Quit" $M1T]
2249 [mc "<Home> Move to first commit"]
2250 [mc "<End> Move to last commit"]
2251 [mc "<Up>, p, i Move up one commit"]
2252 [mc "<Down>, n, k Move down one commit"]
2253 [mc "<Left>, z, j Go back in history list"]
2254 [mc "<Right>, x, l Go forward in history list"]
2255 [mc "<PageUp> Move up one page in commit list"]
2256 [mc "<PageDown> Move down one page in commit list"]
2257 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2258 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2259 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2260 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2261 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2262 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2263 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2264 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2265 [mc "<Delete>, b Scroll diff view up one page"]
2266 [mc "<Backspace> Scroll diff view up one page"]
2267 [mc "<Space> Scroll diff view down one page"]
2268 [mc "u Scroll diff view up 18 lines"]
2269 [mc "d Scroll diff view down 18 lines"]
2270 [mc "<%s-F> Find" $M1T]
2271 [mc "<%s-G> Move to next find hit" $M1T]
2272 [mc "<Return> Move to next find hit"]
2273 [mc "/ Move to next find hit, or redo find"]
2274 [mc "? Move to previous find hit"]
2275 [mc "f Scroll diff view to next file"]
2276 [mc "<%s-S> Search for next hit in diff view" $M1T]
2277 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2278 [mc "<%s-KP+> Increase font size" $M1T]
2279 [mc "<%s-plus> Increase font size" $M1T]
2280 [mc "<%s-KP-> Decrease font size" $M1T]
2281 [mc "<%s-minus> Decrease font size" $M1T]
2282 [mc "<F5> Update"]
2284 -justify left -bg white -border 2 -relief groove
2285 pack $w.m -side top -fill both -padx 2 -pady 2
2286 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2287 pack $w.ok -side bottom
2288 bind $w <Visibility> "focus $w.ok"
2289 bind $w <Key-Escape> "destroy $w"
2290 bind $w <Key-Return> "destroy $w"
2293 # Procedures for manipulating the file list window at the
2294 # bottom right of the overall window.
2296 proc treeview {w l openlevs} {
2297 global treecontents treediropen treeheight treeparent treeindex
2299 set ix 0
2300 set treeindex() 0
2301 set lev 0
2302 set prefix {}
2303 set prefixend -1
2304 set prefendstack {}
2305 set htstack {}
2306 set ht 0
2307 set treecontents() {}
2308 $w conf -state normal
2309 foreach f $l {
2310 while {[string range $f 0 $prefixend] ne $prefix} {
2311 if {$lev <= $openlevs} {
2312 $w mark set e:$treeindex($prefix) "end -1c"
2313 $w mark gravity e:$treeindex($prefix) left
2315 set treeheight($prefix) $ht
2316 incr ht [lindex $htstack end]
2317 set htstack [lreplace $htstack end end]
2318 set prefixend [lindex $prefendstack end]
2319 set prefendstack [lreplace $prefendstack end end]
2320 set prefix [string range $prefix 0 $prefixend]
2321 incr lev -1
2323 set tail [string range $f [expr {$prefixend+1}] end]
2324 while {[set slash [string first "/" $tail]] >= 0} {
2325 lappend htstack $ht
2326 set ht 0
2327 lappend prefendstack $prefixend
2328 incr prefixend [expr {$slash + 1}]
2329 set d [string range $tail 0 $slash]
2330 lappend treecontents($prefix) $d
2331 set oldprefix $prefix
2332 append prefix $d
2333 set treecontents($prefix) {}
2334 set treeindex($prefix) [incr ix]
2335 set treeparent($prefix) $oldprefix
2336 set tail [string range $tail [expr {$slash+1}] end]
2337 if {$lev <= $openlevs} {
2338 set ht 1
2339 set treediropen($prefix) [expr {$lev < $openlevs}]
2340 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2341 $w mark set d:$ix "end -1c"
2342 $w mark gravity d:$ix left
2343 set str "\n"
2344 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2345 $w insert end $str
2346 $w image create end -align center -image $bm -padx 1 \
2347 -name a:$ix
2348 $w insert end $d [highlight_tag $prefix]
2349 $w mark set s:$ix "end -1c"
2350 $w mark gravity s:$ix left
2352 incr lev
2354 if {$tail ne {}} {
2355 if {$lev <= $openlevs} {
2356 incr ht
2357 set str "\n"
2358 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2359 $w insert end $str
2360 $w insert end $tail [highlight_tag $f]
2362 lappend treecontents($prefix) $tail
2365 while {$htstack ne {}} {
2366 set treeheight($prefix) $ht
2367 incr ht [lindex $htstack end]
2368 set htstack [lreplace $htstack end end]
2369 set prefixend [lindex $prefendstack end]
2370 set prefendstack [lreplace $prefendstack end end]
2371 set prefix [string range $prefix 0 $prefixend]
2373 $w conf -state disabled
2376 proc linetoelt {l} {
2377 global treeheight treecontents
2379 set y 2
2380 set prefix {}
2381 while {1} {
2382 foreach e $treecontents($prefix) {
2383 if {$y == $l} {
2384 return "$prefix$e"
2386 set n 1
2387 if {[string index $e end] eq "/"} {
2388 set n $treeheight($prefix$e)
2389 if {$y + $n > $l} {
2390 append prefix $e
2391 incr y
2392 break
2395 incr y $n
2400 proc highlight_tree {y prefix} {
2401 global treeheight treecontents cflist
2403 foreach e $treecontents($prefix) {
2404 set path $prefix$e
2405 if {[highlight_tag $path] ne {}} {
2406 $cflist tag add bold $y.0 "$y.0 lineend"
2408 incr y
2409 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2410 set y [highlight_tree $y $path]
2413 return $y
2416 proc treeclosedir {w dir} {
2417 global treediropen treeheight treeparent treeindex
2419 set ix $treeindex($dir)
2420 $w conf -state normal
2421 $w delete s:$ix e:$ix
2422 set treediropen($dir) 0
2423 $w image configure a:$ix -image tri-rt
2424 $w conf -state disabled
2425 set n [expr {1 - $treeheight($dir)}]
2426 while {$dir ne {}} {
2427 incr treeheight($dir) $n
2428 set dir $treeparent($dir)
2432 proc treeopendir {w dir} {
2433 global treediropen treeheight treeparent treecontents treeindex
2435 set ix $treeindex($dir)
2436 $w conf -state normal
2437 $w image configure a:$ix -image tri-dn
2438 $w mark set e:$ix s:$ix
2439 $w mark gravity e:$ix right
2440 set lev 0
2441 set str "\n"
2442 set n [llength $treecontents($dir)]
2443 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2444 incr lev
2445 append str "\t"
2446 incr treeheight($x) $n
2448 foreach e $treecontents($dir) {
2449 set de $dir$e
2450 if {[string index $e end] eq "/"} {
2451 set iy $treeindex($de)
2452 $w mark set d:$iy e:$ix
2453 $w mark gravity d:$iy left
2454 $w insert e:$ix $str
2455 set treediropen($de) 0
2456 $w image create e:$ix -align center -image tri-rt -padx 1 \
2457 -name a:$iy
2458 $w insert e:$ix $e [highlight_tag $de]
2459 $w mark set s:$iy e:$ix
2460 $w mark gravity s:$iy left
2461 set treeheight($de) 1
2462 } else {
2463 $w insert e:$ix $str
2464 $w insert e:$ix $e [highlight_tag $de]
2467 $w mark gravity e:$ix left
2468 $w conf -state disabled
2469 set treediropen($dir) 1
2470 set top [lindex [split [$w index @0,0] .] 0]
2471 set ht [$w cget -height]
2472 set l [lindex [split [$w index s:$ix] .] 0]
2473 if {$l < $top} {
2474 $w yview $l.0
2475 } elseif {$l + $n + 1 > $top + $ht} {
2476 set top [expr {$l + $n + 2 - $ht}]
2477 if {$l < $top} {
2478 set top $l
2480 $w yview $top.0
2484 proc treeclick {w x y} {
2485 global treediropen cmitmode ctext cflist cflist_top
2487 if {$cmitmode ne "tree"} return
2488 if {![info exists cflist_top]} return
2489 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2490 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2491 $cflist tag add highlight $l.0 "$l.0 lineend"
2492 set cflist_top $l
2493 if {$l == 1} {
2494 $ctext yview 1.0
2495 return
2497 set e [linetoelt $l]
2498 if {[string index $e end] ne "/"} {
2499 showfile $e
2500 } elseif {$treediropen($e)} {
2501 treeclosedir $w $e
2502 } else {
2503 treeopendir $w $e
2507 proc setfilelist {id} {
2508 global treefilelist cflist
2510 treeview $cflist $treefilelist($id) 0
2513 image create bitmap tri-rt -background black -foreground blue -data {
2514 #define tri-rt_width 13
2515 #define tri-rt_height 13
2516 static unsigned char tri-rt_bits[] = {
2517 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2518 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2519 0x00, 0x00};
2520 } -maskdata {
2521 #define tri-rt-mask_width 13
2522 #define tri-rt-mask_height 13
2523 static unsigned char tri-rt-mask_bits[] = {
2524 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2525 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2526 0x08, 0x00};
2528 image create bitmap tri-dn -background black -foreground blue -data {
2529 #define tri-dn_width 13
2530 #define tri-dn_height 13
2531 static unsigned char tri-dn_bits[] = {
2532 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2533 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2534 0x00, 0x00};
2535 } -maskdata {
2536 #define tri-dn-mask_width 13
2537 #define tri-dn-mask_height 13
2538 static unsigned char tri-dn-mask_bits[] = {
2539 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2540 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2541 0x00, 0x00};
2544 image create bitmap reficon-T -background black -foreground yellow -data {
2545 #define tagicon_width 13
2546 #define tagicon_height 9
2547 static unsigned char tagicon_bits[] = {
2548 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2549 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2550 } -maskdata {
2551 #define tagicon-mask_width 13
2552 #define tagicon-mask_height 9
2553 static unsigned char tagicon-mask_bits[] = {
2554 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2555 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2557 set rectdata {
2558 #define headicon_width 13
2559 #define headicon_height 9
2560 static unsigned char headicon_bits[] = {
2561 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2562 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2564 set rectmask {
2565 #define headicon-mask_width 13
2566 #define headicon-mask_height 9
2567 static unsigned char headicon-mask_bits[] = {
2568 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2569 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2571 image create bitmap reficon-H -background black -foreground green \
2572 -data $rectdata -maskdata $rectmask
2573 image create bitmap reficon-o -background black -foreground "#ddddff" \
2574 -data $rectdata -maskdata $rectmask
2576 proc init_flist {first} {
2577 global cflist cflist_top difffilestart
2579 $cflist conf -state normal
2580 $cflist delete 0.0 end
2581 if {$first ne {}} {
2582 $cflist insert end $first
2583 set cflist_top 1
2584 $cflist tag add highlight 1.0 "1.0 lineend"
2585 } else {
2586 catch {unset cflist_top}
2588 $cflist conf -state disabled
2589 set difffilestart {}
2592 proc highlight_tag {f} {
2593 global highlight_paths
2595 foreach p $highlight_paths {
2596 if {[string match $p $f]} {
2597 return "bold"
2600 return {}
2603 proc highlight_filelist {} {
2604 global cmitmode cflist
2606 $cflist conf -state normal
2607 if {$cmitmode ne "tree"} {
2608 set end [lindex [split [$cflist index end] .] 0]
2609 for {set l 2} {$l < $end} {incr l} {
2610 set line [$cflist get $l.0 "$l.0 lineend"]
2611 if {[highlight_tag $line] ne {}} {
2612 $cflist tag add bold $l.0 "$l.0 lineend"
2615 } else {
2616 highlight_tree 2 {}
2618 $cflist conf -state disabled
2621 proc unhighlight_filelist {} {
2622 global cflist
2624 $cflist conf -state normal
2625 $cflist tag remove bold 1.0 end
2626 $cflist conf -state disabled
2629 proc add_flist {fl} {
2630 global cflist
2632 $cflist conf -state normal
2633 foreach f $fl {
2634 $cflist insert end "\n"
2635 $cflist insert end $f [highlight_tag $f]
2637 $cflist conf -state disabled
2640 proc sel_flist {w x y} {
2641 global ctext difffilestart cflist cflist_top cmitmode
2643 if {$cmitmode eq "tree"} return
2644 if {![info exists cflist_top]} return
2645 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2646 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2647 $cflist tag add highlight $l.0 "$l.0 lineend"
2648 set cflist_top $l
2649 if {$l == 1} {
2650 $ctext yview 1.0
2651 } else {
2652 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2656 proc pop_flist_menu {w X Y x y} {
2657 global ctext cflist cmitmode flist_menu flist_menu_file
2658 global treediffs diffids
2660 stopfinding
2661 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2662 if {$l <= 1} return
2663 if {$cmitmode eq "tree"} {
2664 set e [linetoelt $l]
2665 if {[string index $e end] eq "/"} return
2666 } else {
2667 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2669 set flist_menu_file $e
2670 tk_popup $flist_menu $X $Y
2673 proc flist_hl {only} {
2674 global flist_menu_file findstring gdttype
2676 set x [shellquote $flist_menu_file]
2677 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2678 set findstring $x
2679 } else {
2680 append findstring " " $x
2682 set gdttype [mc "touching paths:"]
2685 # Functions for adding and removing shell-type quoting
2687 proc shellquote {str} {
2688 if {![string match "*\['\"\\ \t]*" $str]} {
2689 return $str
2691 if {![string match "*\['\"\\]*" $str]} {
2692 return "\"$str\""
2694 if {![string match "*'*" $str]} {
2695 return "'$str'"
2697 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2700 proc shellarglist {l} {
2701 set str {}
2702 foreach a $l {
2703 if {$str ne {}} {
2704 append str " "
2706 append str [shellquote $a]
2708 return $str
2711 proc shelldequote {str} {
2712 set ret {}
2713 set used -1
2714 while {1} {
2715 incr used
2716 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2717 append ret [string range $str $used end]
2718 set used [string length $str]
2719 break
2721 set first [lindex $first 0]
2722 set ch [string index $str $first]
2723 if {$first > $used} {
2724 append ret [string range $str $used [expr {$first - 1}]]
2725 set used $first
2727 if {$ch eq " " || $ch eq "\t"} break
2728 incr used
2729 if {$ch eq "'"} {
2730 set first [string first "'" $str $used]
2731 if {$first < 0} {
2732 error "unmatched single-quote"
2734 append ret [string range $str $used [expr {$first - 1}]]
2735 set used $first
2736 continue
2738 if {$ch eq "\\"} {
2739 if {$used >= [string length $str]} {
2740 error "trailing backslash"
2742 append ret [string index $str $used]
2743 continue
2745 # here ch == "\""
2746 while {1} {
2747 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2748 error "unmatched double-quote"
2750 set first [lindex $first 0]
2751 set ch [string index $str $first]
2752 if {$first > $used} {
2753 append ret [string range $str $used [expr {$first - 1}]]
2754 set used $first
2756 if {$ch eq "\""} break
2757 incr used
2758 append ret [string index $str $used]
2759 incr used
2762 return [list $used $ret]
2765 proc shellsplit {str} {
2766 set l {}
2767 while {1} {
2768 set str [string trimleft $str]
2769 if {$str eq {}} break
2770 set dq [shelldequote $str]
2771 set n [lindex $dq 0]
2772 set word [lindex $dq 1]
2773 set str [string range $str $n end]
2774 lappend l $word
2776 return $l
2779 # Code to implement multiple views
2781 proc newview {ishighlight} {
2782 global nextviewnum newviewname newviewperm newishighlight
2783 global newviewargs revtreeargs viewargscmd newviewargscmd curview
2785 set newishighlight $ishighlight
2786 set top .gitkview
2787 if {[winfo exists $top]} {
2788 raise $top
2789 return
2791 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
2792 set newviewperm($nextviewnum) 0
2793 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2794 set newviewargscmd($nextviewnum) $viewargscmd($curview)
2795 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2798 proc editview {} {
2799 global curview
2800 global viewname viewperm newviewname newviewperm
2801 global viewargs newviewargs viewargscmd newviewargscmd
2803 set top .gitkvedit-$curview
2804 if {[winfo exists $top]} {
2805 raise $top
2806 return
2808 set newviewname($curview) $viewname($curview)
2809 set newviewperm($curview) $viewperm($curview)
2810 set newviewargs($curview) [shellarglist $viewargs($curview)]
2811 set newviewargscmd($curview) $viewargscmd($curview)
2812 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2815 proc vieweditor {top n title} {
2816 global newviewname newviewperm viewfiles bgcolor
2818 toplevel $top
2819 wm title $top $title
2820 label $top.nl -text [mc "Name"]
2821 entry $top.name -width 20 -textvariable newviewname($n)
2822 grid $top.nl $top.name -sticky w -pady 5
2823 checkbutton $top.perm -text [mc "Remember this view"] \
2824 -variable newviewperm($n)
2825 grid $top.perm - -pady 5 -sticky w
2826 message $top.al -aspect 1000 \
2827 -text [mc "Commits to include (arguments to git log):"]
2828 grid $top.al - -sticky w -pady 5
2829 entry $top.args -width 50 -textvariable newviewargs($n) \
2830 -background $bgcolor
2831 grid $top.args - -sticky ew -padx 5
2833 message $top.ac -aspect 1000 \
2834 -text [mc "Command to generate more commits to include:"]
2835 grid $top.ac - -sticky w -pady 5
2836 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
2837 -background white
2838 grid $top.argscmd - -sticky ew -padx 5
2840 message $top.l -aspect 1000 \
2841 -text [mc "Enter files and directories to include, one per line:"]
2842 grid $top.l - -sticky w
2843 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2844 if {[info exists viewfiles($n)]} {
2845 foreach f $viewfiles($n) {
2846 $top.t insert end $f
2847 $top.t insert end "\n"
2849 $top.t delete {end - 1c} end
2850 $top.t mark set insert 0.0
2852 grid $top.t - -sticky ew -padx 5
2853 frame $top.buts
2854 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2855 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2856 grid $top.buts.ok $top.buts.can
2857 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2858 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2859 grid $top.buts - -pady 10 -sticky ew
2860 focus $top.t
2863 proc doviewmenu {m first cmd op argv} {
2864 set nmenu [$m index end]
2865 for {set i $first} {$i <= $nmenu} {incr i} {
2866 if {[$m entrycget $i -command] eq $cmd} {
2867 eval $m $op $i $argv
2868 break
2873 proc allviewmenus {n op args} {
2874 # global viewhlmenu
2876 doviewmenu .bar.view 5 [list showview $n] $op $args
2877 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2880 proc newviewok {top n} {
2881 global nextviewnum newviewperm newviewname newishighlight
2882 global viewname viewfiles viewperm selectedview curview
2883 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
2885 if {[catch {
2886 set newargs [shellsplit $newviewargs($n)]
2887 } err]} {
2888 error_popup "[mc "Error in commit selection arguments:"] $err"
2889 wm raise $top
2890 focus $top
2891 return
2893 set files {}
2894 foreach f [split [$top.t get 0.0 end] "\n"] {
2895 set ft [string trim $f]
2896 if {$ft ne {}} {
2897 lappend files $ft
2900 if {![info exists viewfiles($n)]} {
2901 # creating a new view
2902 incr nextviewnum
2903 set viewname($n) $newviewname($n)
2904 set viewperm($n) $newviewperm($n)
2905 set viewfiles($n) $files
2906 set viewargs($n) $newargs
2907 set viewargscmd($n) $newviewargscmd($n)
2908 addviewmenu $n
2909 if {!$newishighlight} {
2910 run showview $n
2911 } else {
2912 run addvhighlight $n
2914 } else {
2915 # editing an existing view
2916 set viewperm($n) $newviewperm($n)
2917 if {$newviewname($n) ne $viewname($n)} {
2918 set viewname($n) $newviewname($n)
2919 doviewmenu .bar.view 5 [list showview $n] \
2920 entryconf [list -label $viewname($n)]
2921 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2922 # entryconf [list -label $viewname($n) -value $viewname($n)]
2924 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
2925 $newviewargscmd($n) ne $viewargscmd($n)} {
2926 set viewfiles($n) $files
2927 set viewargs($n) $newargs
2928 set viewargscmd($n) $newviewargscmd($n)
2929 if {$curview == $n} {
2930 run reloadcommits
2934 catch {destroy $top}
2937 proc delview {} {
2938 global curview viewperm hlview selectedhlview
2940 if {$curview == 0} return
2941 if {[info exists hlview] && $hlview == $curview} {
2942 set selectedhlview [mc "None"]
2943 unset hlview
2945 allviewmenus $curview delete
2946 set viewperm($curview) 0
2947 showview 0
2950 proc addviewmenu {n} {
2951 global viewname viewhlmenu
2953 .bar.view add radiobutton -label $viewname($n) \
2954 -command [list showview $n] -variable selectedview -value $n
2955 #$viewhlmenu add radiobutton -label $viewname($n) \
2956 # -command [list addvhighlight $n] -variable selectedhlview
2959 proc showview {n} {
2960 global curview cached_commitrow ordertok
2961 global displayorder parentlist rowidlist rowisopt rowfinal
2962 global colormap rowtextx nextcolor canvxmax
2963 global numcommits viewcomplete
2964 global selectedline currentid canv canvy0
2965 global treediffs
2966 global pending_select mainheadid
2967 global commitidx
2968 global selectedview
2969 global hlview selectedhlview commitinterest
2971 if {$n == $curview} return
2972 set selid {}
2973 set ymax [lindex [$canv cget -scrollregion] 3]
2974 set span [$canv yview]
2975 set ytop [expr {[lindex $span 0] * $ymax}]
2976 set ybot [expr {[lindex $span 1] * $ymax}]
2977 set yscreen [expr {($ybot - $ytop) / 2}]
2978 if {[info exists selectedline]} {
2979 set selid $currentid
2980 set y [yc $selectedline]
2981 if {$ytop < $y && $y < $ybot} {
2982 set yscreen [expr {$y - $ytop}]
2984 } elseif {[info exists pending_select]} {
2985 set selid $pending_select
2986 unset pending_select
2988 unselectline
2989 normalline
2990 catch {unset treediffs}
2991 clear_display
2992 if {[info exists hlview] && $hlview == $n} {
2993 unset hlview
2994 set selectedhlview [mc "None"]
2996 catch {unset commitinterest}
2997 catch {unset cached_commitrow}
2998 catch {unset ordertok}
3000 set curview $n
3001 set selectedview $n
3002 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3003 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3005 run refill_reflist
3006 if {![info exists viewcomplete($n)]} {
3007 if {$selid ne {}} {
3008 set pending_select $selid
3010 getcommits
3011 return
3014 set displayorder {}
3015 set parentlist {}
3016 set rowidlist {}
3017 set rowisopt {}
3018 set rowfinal {}
3019 set numcommits $commitidx($n)
3021 catch {unset colormap}
3022 catch {unset rowtextx}
3023 set nextcolor 0
3024 set canvxmax [$canv cget -width]
3025 set curview $n
3026 set row 0
3027 setcanvscroll
3028 set yf 0
3029 set row {}
3030 if {$selid ne {} && [commitinview $selid $n]} {
3031 set row [rowofcommit $selid]
3032 # try to get the selected row in the same position on the screen
3033 set ymax [lindex [$canv cget -scrollregion] 3]
3034 set ytop [expr {[yc $row] - $yscreen}]
3035 if {$ytop < 0} {
3036 set ytop 0
3038 set yf [expr {$ytop * 1.0 / $ymax}]
3040 allcanvs yview moveto $yf
3041 drawvisible
3042 if {$row ne {}} {
3043 selectline $row 0
3044 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3045 selectline [rowofcommit $mainheadid] 1
3046 } elseif {!$viewcomplete($n)} {
3047 if {$selid ne {}} {
3048 set pending_select $selid
3049 } else {
3050 set pending_select $mainheadid
3052 } else {
3053 set row [first_real_row]
3054 if {$row < $numcommits} {
3055 selectline $row 0
3058 if {!$viewcomplete($n)} {
3059 if {$numcommits == 0} {
3060 show_status [mc "Reading commits..."]
3062 } elseif {$numcommits == 0} {
3063 show_status [mc "No commits selected"]
3067 # Stuff relating to the highlighting facility
3069 proc ishighlighted {id} {
3070 global vhighlights fhighlights nhighlights rhighlights
3072 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3073 return $nhighlights($id)
3075 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3076 return $vhighlights($id)
3078 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3079 return $fhighlights($id)
3081 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3082 return $rhighlights($id)
3084 return 0
3087 proc bolden {row font} {
3088 global canv linehtag selectedline boldrows
3090 lappend boldrows $row
3091 $canv itemconf $linehtag($row) -font $font
3092 if {[info exists selectedline] && $row == $selectedline} {
3093 $canv delete secsel
3094 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3095 -outline {{}} -tags secsel \
3096 -fill [$canv cget -selectbackground]]
3097 $canv lower $t
3101 proc bolden_name {row font} {
3102 global canv2 linentag selectedline boldnamerows
3104 lappend boldnamerows $row
3105 $canv2 itemconf $linentag($row) -font $font
3106 if {[info exists selectedline] && $row == $selectedline} {
3107 $canv2 delete secsel
3108 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3109 -outline {{}} -tags secsel \
3110 -fill [$canv2 cget -selectbackground]]
3111 $canv2 lower $t
3115 proc unbolden {} {
3116 global boldrows
3118 set stillbold {}
3119 foreach row $boldrows {
3120 if {![ishighlighted [commitonrow $row]]} {
3121 bolden $row mainfont
3122 } else {
3123 lappend stillbold $row
3126 set boldrows $stillbold
3129 proc addvhighlight {n} {
3130 global hlview viewcomplete curview vhl_done commitidx
3132 if {[info exists hlview]} {
3133 delvhighlight
3135 set hlview $n
3136 if {$n != $curview && ![info exists viewcomplete($n)]} {
3137 start_rev_list $n
3139 set vhl_done $commitidx($hlview)
3140 if {$vhl_done > 0} {
3141 drawvisible
3145 proc delvhighlight {} {
3146 global hlview vhighlights
3148 if {![info exists hlview]} return
3149 unset hlview
3150 catch {unset vhighlights}
3151 unbolden
3154 proc vhighlightmore {} {
3155 global hlview vhl_done commitidx vhighlights curview
3157 set max $commitidx($hlview)
3158 set vr [visiblerows]
3159 set r0 [lindex $vr 0]
3160 set r1 [lindex $vr 1]
3161 for {set i $vhl_done} {$i < $max} {incr i} {
3162 set id [commitonrow $i $hlview]
3163 if {[commitinview $id $curview]} {
3164 set row [rowofcommit $id]
3165 if {$r0 <= $row && $row <= $r1} {
3166 if {![highlighted $row]} {
3167 bolden $row mainfontbold
3169 set vhighlights($id) 1
3173 set vhl_done $max
3174 return 0
3177 proc askvhighlight {row id} {
3178 global hlview vhighlights iddrawn
3180 if {[commitinview $id $hlview]} {
3181 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3182 bolden $row mainfontbold
3184 set vhighlights($id) 1
3185 } else {
3186 set vhighlights($id) 0
3190 proc hfiles_change {} {
3191 global highlight_files filehighlight fhighlights fh_serial
3192 global highlight_paths gdttype
3194 if {[info exists filehighlight]} {
3195 # delete previous highlights
3196 catch {close $filehighlight}
3197 unset filehighlight
3198 catch {unset fhighlights}
3199 unbolden
3200 unhighlight_filelist
3202 set highlight_paths {}
3203 after cancel do_file_hl $fh_serial
3204 incr fh_serial
3205 if {$highlight_files ne {}} {
3206 after 300 do_file_hl $fh_serial
3210 proc gdttype_change {name ix op} {
3211 global gdttype highlight_files findstring findpattern
3213 stopfinding
3214 if {$findstring ne {}} {
3215 if {$gdttype eq [mc "containing:"]} {
3216 if {$highlight_files ne {}} {
3217 set highlight_files {}
3218 hfiles_change
3220 findcom_change
3221 } else {
3222 if {$findpattern ne {}} {
3223 set findpattern {}
3224 findcom_change
3226 set highlight_files $findstring
3227 hfiles_change
3229 drawvisible
3231 # enable/disable findtype/findloc menus too
3234 proc find_change {name ix op} {
3235 global gdttype findstring highlight_files
3237 stopfinding
3238 if {$gdttype eq [mc "containing:"]} {
3239 findcom_change
3240 } else {
3241 if {$highlight_files ne $findstring} {
3242 set highlight_files $findstring
3243 hfiles_change
3246 drawvisible
3249 proc findcom_change args {
3250 global nhighlights boldnamerows
3251 global findpattern findtype findstring gdttype
3253 stopfinding
3254 # delete previous highlights, if any
3255 foreach row $boldnamerows {
3256 bolden_name $row mainfont
3258 set boldnamerows {}
3259 catch {unset nhighlights}
3260 unbolden
3261 unmarkmatches
3262 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3263 set findpattern {}
3264 } elseif {$findtype eq [mc "Regexp"]} {
3265 set findpattern $findstring
3266 } else {
3267 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3268 $findstring]
3269 set findpattern "*$e*"
3273 proc makepatterns {l} {
3274 set ret {}
3275 foreach e $l {
3276 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3277 if {[string index $ee end] eq "/"} {
3278 lappend ret "$ee*"
3279 } else {
3280 lappend ret $ee
3281 lappend ret "$ee/*"
3284 return $ret
3287 proc do_file_hl {serial} {
3288 global highlight_files filehighlight highlight_paths gdttype fhl_list
3290 if {$gdttype eq [mc "touching paths:"]} {
3291 if {[catch {set paths [shellsplit $highlight_files]}]} return
3292 set highlight_paths [makepatterns $paths]
3293 highlight_filelist
3294 set gdtargs [concat -- $paths]
3295 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3296 set gdtargs [list "-S$highlight_files"]
3297 } else {
3298 # must be "containing:", i.e. we're searching commit info
3299 return
3301 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3302 set filehighlight [open $cmd r+]
3303 fconfigure $filehighlight -blocking 0
3304 filerun $filehighlight readfhighlight
3305 set fhl_list {}
3306 drawvisible
3307 flushhighlights
3310 proc flushhighlights {} {
3311 global filehighlight fhl_list
3313 if {[info exists filehighlight]} {
3314 lappend fhl_list {}
3315 puts $filehighlight ""
3316 flush $filehighlight
3320 proc askfilehighlight {row id} {
3321 global filehighlight fhighlights fhl_list
3323 lappend fhl_list $id
3324 set fhighlights($id) -1
3325 puts $filehighlight $id
3328 proc readfhighlight {} {
3329 global filehighlight fhighlights curview iddrawn
3330 global fhl_list find_dirn
3332 if {![info exists filehighlight]} {
3333 return 0
3335 set nr 0
3336 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3337 set line [string trim $line]
3338 set i [lsearch -exact $fhl_list $line]
3339 if {$i < 0} continue
3340 for {set j 0} {$j < $i} {incr j} {
3341 set id [lindex $fhl_list $j]
3342 set fhighlights($id) 0
3344 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3345 if {$line eq {}} continue
3346 if {![commitinview $line $curview]} continue
3347 set row [rowofcommit $line]
3348 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3349 bolden $row mainfontbold
3351 set fhighlights($line) 1
3353 if {[eof $filehighlight]} {
3354 # strange...
3355 puts "oops, git diff-tree died"
3356 catch {close $filehighlight}
3357 unset filehighlight
3358 return 0
3360 if {[info exists find_dirn]} {
3361 run findmore
3363 return 1
3366 proc doesmatch {f} {
3367 global findtype findpattern
3369 if {$findtype eq [mc "Regexp"]} {
3370 return [regexp $findpattern $f]
3371 } elseif {$findtype eq [mc "IgnCase"]} {
3372 return [string match -nocase $findpattern $f]
3373 } else {
3374 return [string match $findpattern $f]
3378 proc askfindhighlight {row id} {
3379 global nhighlights commitinfo iddrawn
3380 global findloc
3381 global markingmatches
3383 if {![info exists commitinfo($id)]} {
3384 getcommit $id
3386 set info $commitinfo($id)
3387 set isbold 0
3388 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3389 foreach f $info ty $fldtypes {
3390 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3391 [doesmatch $f]} {
3392 if {$ty eq [mc "Author"]} {
3393 set isbold 2
3394 break
3396 set isbold 1
3399 if {$isbold && [info exists iddrawn($id)]} {
3400 if {![ishighlighted $id]} {
3401 bolden $row mainfontbold
3402 if {$isbold > 1} {
3403 bolden_name $row mainfontbold
3406 if {$markingmatches} {
3407 markrowmatches $row $id
3410 set nhighlights($id) $isbold
3413 proc markrowmatches {row id} {
3414 global canv canv2 linehtag linentag commitinfo findloc
3416 set headline [lindex $commitinfo($id) 0]
3417 set author [lindex $commitinfo($id) 1]
3418 $canv delete match$row
3419 $canv2 delete match$row
3420 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3421 set m [findmatches $headline]
3422 if {$m ne {}} {
3423 markmatches $canv $row $headline $linehtag($row) $m \
3424 [$canv itemcget $linehtag($row) -font] $row
3427 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3428 set m [findmatches $author]
3429 if {$m ne {}} {
3430 markmatches $canv2 $row $author $linentag($row) $m \
3431 [$canv2 itemcget $linentag($row) -font] $row
3436 proc vrel_change {name ix op} {
3437 global highlight_related
3439 rhighlight_none
3440 if {$highlight_related ne [mc "None"]} {
3441 run drawvisible
3445 # prepare for testing whether commits are descendents or ancestors of a
3446 proc rhighlight_sel {a} {
3447 global descendent desc_todo ancestor anc_todo
3448 global highlight_related
3450 catch {unset descendent}
3451 set desc_todo [list $a]
3452 catch {unset ancestor}
3453 set anc_todo [list $a]
3454 if {$highlight_related ne [mc "None"]} {
3455 rhighlight_none
3456 run drawvisible
3460 proc rhighlight_none {} {
3461 global rhighlights
3463 catch {unset rhighlights}
3464 unbolden
3467 proc is_descendent {a} {
3468 global curview children descendent desc_todo
3470 set v $curview
3471 set la [rowofcommit $a]
3472 set todo $desc_todo
3473 set leftover {}
3474 set done 0
3475 for {set i 0} {$i < [llength $todo]} {incr i} {
3476 set do [lindex $todo $i]
3477 if {[rowofcommit $do] < $la} {
3478 lappend leftover $do
3479 continue
3481 foreach nk $children($v,$do) {
3482 if {![info exists descendent($nk)]} {
3483 set descendent($nk) 1
3484 lappend todo $nk
3485 if {$nk eq $a} {
3486 set done 1
3490 if {$done} {
3491 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3492 return
3495 set descendent($a) 0
3496 set desc_todo $leftover
3499 proc is_ancestor {a} {
3500 global curview parents ancestor anc_todo
3502 set v $curview
3503 set la [rowofcommit $a]
3504 set todo $anc_todo
3505 set leftover {}
3506 set done 0
3507 for {set i 0} {$i < [llength $todo]} {incr i} {
3508 set do [lindex $todo $i]
3509 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3510 lappend leftover $do
3511 continue
3513 foreach np $parents($v,$do) {
3514 if {![info exists ancestor($np)]} {
3515 set ancestor($np) 1
3516 lappend todo $np
3517 if {$np eq $a} {
3518 set done 1
3522 if {$done} {
3523 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3524 return
3527 set ancestor($a) 0
3528 set anc_todo $leftover
3531 proc askrelhighlight {row id} {
3532 global descendent highlight_related iddrawn rhighlights
3533 global selectedline ancestor
3535 if {![info exists selectedline]} return
3536 set isbold 0
3537 if {$highlight_related eq [mc "Descendant"] ||
3538 $highlight_related eq [mc "Not descendant"]} {
3539 if {![info exists descendent($id)]} {
3540 is_descendent $id
3542 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3543 set isbold 1
3545 } elseif {$highlight_related eq [mc "Ancestor"] ||
3546 $highlight_related eq [mc "Not ancestor"]} {
3547 if {![info exists ancestor($id)]} {
3548 is_ancestor $id
3550 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3551 set isbold 1
3554 if {[info exists iddrawn($id)]} {
3555 if {$isbold && ![ishighlighted $id]} {
3556 bolden $row mainfontbold
3559 set rhighlights($id) $isbold
3562 # Graph layout functions
3564 proc shortids {ids} {
3565 set res {}
3566 foreach id $ids {
3567 if {[llength $id] > 1} {
3568 lappend res [shortids $id]
3569 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3570 lappend res [string range $id 0 7]
3571 } else {
3572 lappend res $id
3575 return $res
3578 proc ntimes {n o} {
3579 set ret {}
3580 set o [list $o]
3581 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3582 if {($n & $mask) != 0} {
3583 set ret [concat $ret $o]
3585 set o [concat $o $o]
3587 return $ret
3590 proc ordertoken {id} {
3591 global ordertok curview varcid varcstart varctok curview parents children
3592 global nullid nullid2
3594 if {[info exists ordertok($id)]} {
3595 return $ordertok($id)
3597 set origid $id
3598 set todo {}
3599 while {1} {
3600 if {[info exists varcid($curview,$id)]} {
3601 set a $varcid($curview,$id)
3602 set p [lindex $varcstart($curview) $a]
3603 } else {
3604 set p [lindex $children($curview,$id) 0]
3606 if {[info exists ordertok($p)]} {
3607 set tok $ordertok($p)
3608 break
3610 set id [first_real_child $curview,$p]
3611 if {$id eq {}} {
3612 # it's a root
3613 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3614 break
3616 if {[llength $parents($curview,$id)] == 1} {
3617 lappend todo [list $p {}]
3618 } else {
3619 set j [lsearch -exact $parents($curview,$id) $p]
3620 if {$j < 0} {
3621 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3623 lappend todo [list $p [strrep $j]]
3626 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3627 set p [lindex $todo $i 0]
3628 append tok [lindex $todo $i 1]
3629 set ordertok($p) $tok
3631 set ordertok($origid) $tok
3632 return $tok
3635 # Work out where id should go in idlist so that order-token
3636 # values increase from left to right
3637 proc idcol {idlist id {i 0}} {
3638 set t [ordertoken $id]
3639 if {$i < 0} {
3640 set i 0
3642 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3643 if {$i > [llength $idlist]} {
3644 set i [llength $idlist]
3646 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3647 incr i
3648 } else {
3649 if {$t > [ordertoken [lindex $idlist $i]]} {
3650 while {[incr i] < [llength $idlist] &&
3651 $t >= [ordertoken [lindex $idlist $i]]} {}
3654 return $i
3657 proc initlayout {} {
3658 global rowidlist rowisopt rowfinal displayorder parentlist
3659 global numcommits canvxmax canv
3660 global nextcolor
3661 global colormap rowtextx
3663 set numcommits 0
3664 set displayorder {}
3665 set parentlist {}
3666 set nextcolor 0
3667 set rowidlist {}
3668 set rowisopt {}
3669 set rowfinal {}
3670 set canvxmax [$canv cget -width]
3671 catch {unset colormap}
3672 catch {unset rowtextx}
3673 setcanvscroll
3676 proc setcanvscroll {} {
3677 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3678 global lastscrollset lastscrollrows
3680 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3681 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3682 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3683 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3684 set lastscrollset [clock clicks -milliseconds]
3685 set lastscrollrows $numcommits
3688 proc visiblerows {} {
3689 global canv numcommits linespc
3691 set ymax [lindex [$canv cget -scrollregion] 3]
3692 if {$ymax eq {} || $ymax == 0} return
3693 set f [$canv yview]
3694 set y0 [expr {int([lindex $f 0] * $ymax)}]
3695 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3696 if {$r0 < 0} {
3697 set r0 0
3699 set y1 [expr {int([lindex $f 1] * $ymax)}]
3700 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3701 if {$r1 >= $numcommits} {
3702 set r1 [expr {$numcommits - 1}]
3704 return [list $r0 $r1]
3707 proc layoutmore {} {
3708 global commitidx viewcomplete curview
3709 global numcommits pending_select selectedline curview
3710 global lastscrollset lastscrollrows commitinterest
3712 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
3713 [clock clicks -milliseconds] - $lastscrollset > 500} {
3714 setcanvscroll
3716 if {[info exists pending_select] &&
3717 [commitinview $pending_select $curview]} {
3718 selectline [rowofcommit $pending_select] 1
3720 drawvisible
3723 proc doshowlocalchanges {} {
3724 global curview mainheadid
3726 if {[commitinview $mainheadid $curview]} {
3727 dodiffindex
3728 } else {
3729 lappend commitinterest($mainheadid) {dodiffindex}
3733 proc dohidelocalchanges {} {
3734 global nullid nullid2 lserial curview
3736 if {[commitinview $nullid $curview]} {
3737 removefakerow $nullid
3739 if {[commitinview $nullid2 $curview]} {
3740 removefakerow $nullid2
3742 incr lserial
3745 # spawn off a process to do git diff-index --cached HEAD
3746 proc dodiffindex {} {
3747 global lserial showlocalchanges
3748 global isworktree
3750 if {!$showlocalchanges || !$isworktree} return
3751 incr lserial
3752 set fd [open "|git diff-index --cached HEAD" r]
3753 fconfigure $fd -blocking 0
3754 filerun $fd [list readdiffindex $fd $lserial]
3757 proc readdiffindex {fd serial} {
3758 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3760 set isdiff 1
3761 if {[gets $fd line] < 0} {
3762 if {![eof $fd]} {
3763 return 1
3765 set isdiff 0
3767 # we only need to see one line and we don't really care what it says...
3768 close $fd
3770 if {$serial != $lserial} {
3771 return 0
3774 # now see if there are any local changes not checked in to the index
3775 set fd [open "|git diff-files" r]
3776 fconfigure $fd -blocking 0
3777 filerun $fd [list readdifffiles $fd $serial]
3779 if {$isdiff && ![commitinview $nullid2 $curview]} {
3780 # add the line for the changes in the index to the graph
3781 set hl [mc "Local changes checked in to index but not committed"]
3782 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3783 set commitdata($nullid2) "\n $hl\n"
3784 if {[commitinview $nullid $curview]} {
3785 removefakerow $nullid
3787 insertfakerow $nullid2 $mainheadid
3788 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3789 removefakerow $nullid2
3791 return 0
3794 proc readdifffiles {fd serial} {
3795 global mainheadid nullid nullid2 curview
3796 global commitinfo commitdata lserial
3798 set isdiff 1
3799 if {[gets $fd line] < 0} {
3800 if {![eof $fd]} {
3801 return 1
3803 set isdiff 0
3805 # we only need to see one line and we don't really care what it says...
3806 close $fd
3808 if {$serial != $lserial} {
3809 return 0
3812 if {$isdiff && ![commitinview $nullid $curview]} {
3813 # add the line for the local diff to the graph
3814 set hl [mc "Local uncommitted changes, not checked in to index"]
3815 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3816 set commitdata($nullid) "\n $hl\n"
3817 if {[commitinview $nullid2 $curview]} {
3818 set p $nullid2
3819 } else {
3820 set p $mainheadid
3822 insertfakerow $nullid $p
3823 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3824 removefakerow $nullid
3826 return 0
3829 proc nextuse {id row} {
3830 global curview children
3832 if {[info exists children($curview,$id)]} {
3833 foreach kid $children($curview,$id) {
3834 if {![commitinview $kid $curview]} {
3835 return -1
3837 if {[rowofcommit $kid] > $row} {
3838 return [rowofcommit $kid]
3842 if {[commitinview $id $curview]} {
3843 return [rowofcommit $id]
3845 return -1
3848 proc prevuse {id row} {
3849 global curview children
3851 set ret -1
3852 if {[info exists children($curview,$id)]} {
3853 foreach kid $children($curview,$id) {
3854 if {![commitinview $kid $curview]} break
3855 if {[rowofcommit $kid] < $row} {
3856 set ret [rowofcommit $kid]
3860 return $ret
3863 proc make_idlist {row} {
3864 global displayorder parentlist uparrowlen downarrowlen mingaplen
3865 global commitidx curview children
3867 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3868 if {$r < 0} {
3869 set r 0
3871 set ra [expr {$row - $downarrowlen}]
3872 if {$ra < 0} {
3873 set ra 0
3875 set rb [expr {$row + $uparrowlen}]
3876 if {$rb > $commitidx($curview)} {
3877 set rb $commitidx($curview)
3879 make_disporder $r [expr {$rb + 1}]
3880 set ids {}
3881 for {} {$r < $ra} {incr r} {
3882 set nextid [lindex $displayorder [expr {$r + 1}]]
3883 foreach p [lindex $parentlist $r] {
3884 if {$p eq $nextid} continue
3885 set rn [nextuse $p $r]
3886 if {$rn >= $row &&
3887 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3888 lappend ids [list [ordertoken $p] $p]
3892 for {} {$r < $row} {incr r} {
3893 set nextid [lindex $displayorder [expr {$r + 1}]]
3894 foreach p [lindex $parentlist $r] {
3895 if {$p eq $nextid} continue
3896 set rn [nextuse $p $r]
3897 if {$rn < 0 || $rn >= $row} {
3898 lappend ids [list [ordertoken $p] $p]
3902 set id [lindex $displayorder $row]
3903 lappend ids [list [ordertoken $id] $id]
3904 while {$r < $rb} {
3905 foreach p [lindex $parentlist $r] {
3906 set firstkid [lindex $children($curview,$p) 0]
3907 if {[rowofcommit $firstkid] < $row} {
3908 lappend ids [list [ordertoken $p] $p]
3911 incr r
3912 set id [lindex $displayorder $r]
3913 if {$id ne {}} {
3914 set firstkid [lindex $children($curview,$id) 0]
3915 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3916 lappend ids [list [ordertoken $id] $id]
3920 set idlist {}
3921 foreach idx [lsort -unique $ids] {
3922 lappend idlist [lindex $idx 1]
3924 return $idlist
3927 proc rowsequal {a b} {
3928 while {[set i [lsearch -exact $a {}]] >= 0} {
3929 set a [lreplace $a $i $i]
3931 while {[set i [lsearch -exact $b {}]] >= 0} {
3932 set b [lreplace $b $i $i]
3934 return [expr {$a eq $b}]
3937 proc makeupline {id row rend col} {
3938 global rowidlist uparrowlen downarrowlen mingaplen
3940 for {set r $rend} {1} {set r $rstart} {
3941 set rstart [prevuse $id $r]
3942 if {$rstart < 0} return
3943 if {$rstart < $row} break
3945 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3946 set rstart [expr {$rend - $uparrowlen - 1}]
3948 for {set r $rstart} {[incr r] <= $row} {} {
3949 set idlist [lindex $rowidlist $r]
3950 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3951 set col [idcol $idlist $id $col]
3952 lset rowidlist $r [linsert $idlist $col $id]
3953 changedrow $r
3958 proc layoutrows {row endrow} {
3959 global rowidlist rowisopt rowfinal displayorder
3960 global uparrowlen downarrowlen maxwidth mingaplen
3961 global children parentlist
3962 global commitidx viewcomplete curview
3964 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3965 set idlist {}
3966 if {$row > 0} {
3967 set rm1 [expr {$row - 1}]
3968 foreach id [lindex $rowidlist $rm1] {
3969 if {$id ne {}} {
3970 lappend idlist $id
3973 set final [lindex $rowfinal $rm1]
3975 for {} {$row < $endrow} {incr row} {
3976 set rm1 [expr {$row - 1}]
3977 if {$rm1 < 0 || $idlist eq {}} {
3978 set idlist [make_idlist $row]
3979 set final 1
3980 } else {
3981 set id [lindex $displayorder $rm1]
3982 set col [lsearch -exact $idlist $id]
3983 set idlist [lreplace $idlist $col $col]
3984 foreach p [lindex $parentlist $rm1] {
3985 if {[lsearch -exact $idlist $p] < 0} {
3986 set col [idcol $idlist $p $col]
3987 set idlist [linsert $idlist $col $p]
3988 # if not the first child, we have to insert a line going up
3989 if {$id ne [lindex $children($curview,$p) 0]} {
3990 makeupline $p $rm1 $row $col
3994 set id [lindex $displayorder $row]
3995 if {$row > $downarrowlen} {
3996 set termrow [expr {$row - $downarrowlen - 1}]
3997 foreach p [lindex $parentlist $termrow] {
3998 set i [lsearch -exact $idlist $p]
3999 if {$i < 0} continue
4000 set nr [nextuse $p $termrow]
4001 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4002 set idlist [lreplace $idlist $i $i]
4006 set col [lsearch -exact $idlist $id]
4007 if {$col < 0} {
4008 set col [idcol $idlist $id]
4009 set idlist [linsert $idlist $col $id]
4010 if {$children($curview,$id) ne {}} {
4011 makeupline $id $rm1 $row $col
4014 set r [expr {$row + $uparrowlen - 1}]
4015 if {$r < $commitidx($curview)} {
4016 set x $col
4017 foreach p [lindex $parentlist $r] {
4018 if {[lsearch -exact $idlist $p] >= 0} continue
4019 set fk [lindex $children($curview,$p) 0]
4020 if {[rowofcommit $fk] < $row} {
4021 set x [idcol $idlist $p $x]
4022 set idlist [linsert $idlist $x $p]
4025 if {[incr r] < $commitidx($curview)} {
4026 set p [lindex $displayorder $r]
4027 if {[lsearch -exact $idlist $p] < 0} {
4028 set fk [lindex $children($curview,$p) 0]
4029 if {$fk ne {} && [rowofcommit $fk] < $row} {
4030 set x [idcol $idlist $p $x]
4031 set idlist [linsert $idlist $x $p]
4037 if {$final && !$viewcomplete($curview) &&
4038 $row + $uparrowlen + $mingaplen + $downarrowlen
4039 >= $commitidx($curview)} {
4040 set final 0
4042 set l [llength $rowidlist]
4043 if {$row == $l} {
4044 lappend rowidlist $idlist
4045 lappend rowisopt 0
4046 lappend rowfinal $final
4047 } elseif {$row < $l} {
4048 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4049 lset rowidlist $row $idlist
4050 changedrow $row
4052 lset rowfinal $row $final
4053 } else {
4054 set pad [ntimes [expr {$row - $l}] {}]
4055 set rowidlist [concat $rowidlist $pad]
4056 lappend rowidlist $idlist
4057 set rowfinal [concat $rowfinal $pad]
4058 lappend rowfinal $final
4059 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4062 return $row
4065 proc changedrow {row} {
4066 global displayorder iddrawn rowisopt need_redisplay
4068 set l [llength $rowisopt]
4069 if {$row < $l} {
4070 lset rowisopt $row 0
4071 if {$row + 1 < $l} {
4072 lset rowisopt [expr {$row + 1}] 0
4073 if {$row + 2 < $l} {
4074 lset rowisopt [expr {$row + 2}] 0
4078 set id [lindex $displayorder $row]
4079 if {[info exists iddrawn($id)]} {
4080 set need_redisplay 1
4084 proc insert_pad {row col npad} {
4085 global rowidlist
4087 set pad [ntimes $npad {}]
4088 set idlist [lindex $rowidlist $row]
4089 set bef [lrange $idlist 0 [expr {$col - 1}]]
4090 set aft [lrange $idlist $col end]
4091 set i [lsearch -exact $aft {}]
4092 if {$i > 0} {
4093 set aft [lreplace $aft $i $i]
4095 lset rowidlist $row [concat $bef $pad $aft]
4096 changedrow $row
4099 proc optimize_rows {row col endrow} {
4100 global rowidlist rowisopt displayorder curview children
4102 if {$row < 1} {
4103 set row 1
4105 for {} {$row < $endrow} {incr row; set col 0} {
4106 if {[lindex $rowisopt $row]} continue
4107 set haspad 0
4108 set y0 [expr {$row - 1}]
4109 set ym [expr {$row - 2}]
4110 set idlist [lindex $rowidlist $row]
4111 set previdlist [lindex $rowidlist $y0]
4112 if {$idlist eq {} || $previdlist eq {}} continue
4113 if {$ym >= 0} {
4114 set pprevidlist [lindex $rowidlist $ym]
4115 if {$pprevidlist eq {}} continue
4116 } else {
4117 set pprevidlist {}
4119 set x0 -1
4120 set xm -1
4121 for {} {$col < [llength $idlist]} {incr col} {
4122 set id [lindex $idlist $col]
4123 if {[lindex $previdlist $col] eq $id} continue
4124 if {$id eq {}} {
4125 set haspad 1
4126 continue
4128 set x0 [lsearch -exact $previdlist $id]
4129 if {$x0 < 0} continue
4130 set z [expr {$x0 - $col}]
4131 set isarrow 0
4132 set z0 {}
4133 if {$ym >= 0} {
4134 set xm [lsearch -exact $pprevidlist $id]
4135 if {$xm >= 0} {
4136 set z0 [expr {$xm - $x0}]
4139 if {$z0 eq {}} {
4140 # if row y0 is the first child of $id then it's not an arrow
4141 if {[lindex $children($curview,$id) 0] ne
4142 [lindex $displayorder $y0]} {
4143 set isarrow 1
4146 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4147 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4148 set isarrow 1
4150 # Looking at lines from this row to the previous row,
4151 # make them go straight up if they end in an arrow on
4152 # the previous row; otherwise make them go straight up
4153 # or at 45 degrees.
4154 if {$z < -1 || ($z < 0 && $isarrow)} {
4155 # Line currently goes left too much;
4156 # insert pads in the previous row, then optimize it
4157 set npad [expr {-1 - $z + $isarrow}]
4158 insert_pad $y0 $x0 $npad
4159 if {$y0 > 0} {
4160 optimize_rows $y0 $x0 $row
4162 set previdlist [lindex $rowidlist $y0]
4163 set x0 [lsearch -exact $previdlist $id]
4164 set z [expr {$x0 - $col}]
4165 if {$z0 ne {}} {
4166 set pprevidlist [lindex $rowidlist $ym]
4167 set xm [lsearch -exact $pprevidlist $id]
4168 set z0 [expr {$xm - $x0}]
4170 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4171 # Line currently goes right too much;
4172 # insert pads in this line
4173 set npad [expr {$z - 1 + $isarrow}]
4174 insert_pad $row $col $npad
4175 set idlist [lindex $rowidlist $row]
4176 incr col $npad
4177 set z [expr {$x0 - $col}]
4178 set haspad 1
4180 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4181 # this line links to its first child on row $row-2
4182 set id [lindex $displayorder $ym]
4183 set xc [lsearch -exact $pprevidlist $id]
4184 if {$xc >= 0} {
4185 set z0 [expr {$xc - $x0}]
4188 # avoid lines jigging left then immediately right
4189 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4190 insert_pad $y0 $x0 1
4191 incr x0
4192 optimize_rows $y0 $x0 $row
4193 set previdlist [lindex $rowidlist $y0]
4196 if {!$haspad} {
4197 # Find the first column that doesn't have a line going right
4198 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4199 set id [lindex $idlist $col]
4200 if {$id eq {}} break
4201 set x0 [lsearch -exact $previdlist $id]
4202 if {$x0 < 0} {
4203 # check if this is the link to the first child
4204 set kid [lindex $displayorder $y0]
4205 if {[lindex $children($curview,$id) 0] eq $kid} {
4206 # it is, work out offset to child
4207 set x0 [lsearch -exact $previdlist $kid]
4210 if {$x0 <= $col} break
4212 # Insert a pad at that column as long as it has a line and
4213 # isn't the last column
4214 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4215 set idlist [linsert $idlist $col {}]
4216 lset rowidlist $row $idlist
4217 changedrow $row
4223 proc xc {row col} {
4224 global canvx0 linespc
4225 return [expr {$canvx0 + $col * $linespc}]
4228 proc yc {row} {
4229 global canvy0 linespc
4230 return [expr {$canvy0 + $row * $linespc}]
4233 proc linewidth {id} {
4234 global thickerline lthickness
4236 set wid $lthickness
4237 if {[info exists thickerline] && $id eq $thickerline} {
4238 set wid [expr {2 * $lthickness}]
4240 return $wid
4243 proc rowranges {id} {
4244 global curview children uparrowlen downarrowlen
4245 global rowidlist
4247 set kids $children($curview,$id)
4248 if {$kids eq {}} {
4249 return {}
4251 set ret {}
4252 lappend kids $id
4253 foreach child $kids {
4254 if {![commitinview $child $curview]} break
4255 set row [rowofcommit $child]
4256 if {![info exists prev]} {
4257 lappend ret [expr {$row + 1}]
4258 } else {
4259 if {$row <= $prevrow} {
4260 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4262 # see if the line extends the whole way from prevrow to row
4263 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4264 [lsearch -exact [lindex $rowidlist \
4265 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4266 # it doesn't, see where it ends
4267 set r [expr {$prevrow + $downarrowlen}]
4268 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4269 while {[incr r -1] > $prevrow &&
4270 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4271 } else {
4272 while {[incr r] <= $row &&
4273 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4274 incr r -1
4276 lappend ret $r
4277 # see where it starts up again
4278 set r [expr {$row - $uparrowlen}]
4279 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4280 while {[incr r] < $row &&
4281 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4282 } else {
4283 while {[incr r -1] >= $prevrow &&
4284 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4285 incr r
4287 lappend ret $r
4290 if {$child eq $id} {
4291 lappend ret $row
4293 set prev $child
4294 set prevrow $row
4296 return $ret
4299 proc drawlineseg {id row endrow arrowlow} {
4300 global rowidlist displayorder iddrawn linesegs
4301 global canv colormap linespc curview maxlinelen parentlist
4303 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4304 set le [expr {$row + 1}]
4305 set arrowhigh 1
4306 while {1} {
4307 set c [lsearch -exact [lindex $rowidlist $le] $id]
4308 if {$c < 0} {
4309 incr le -1
4310 break
4312 lappend cols $c
4313 set x [lindex $displayorder $le]
4314 if {$x eq $id} {
4315 set arrowhigh 0
4316 break
4318 if {[info exists iddrawn($x)] || $le == $endrow} {
4319 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4320 if {$c >= 0} {
4321 lappend cols $c
4322 set arrowhigh 0
4324 break
4326 incr le
4328 if {$le <= $row} {
4329 return $row
4332 set lines {}
4333 set i 0
4334 set joinhigh 0
4335 if {[info exists linesegs($id)]} {
4336 set lines $linesegs($id)
4337 foreach li $lines {
4338 set r0 [lindex $li 0]
4339 if {$r0 > $row} {
4340 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4341 set joinhigh 1
4343 break
4345 incr i
4348 set joinlow 0
4349 if {$i > 0} {
4350 set li [lindex $lines [expr {$i-1}]]
4351 set r1 [lindex $li 1]
4352 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4353 set joinlow 1
4357 set x [lindex $cols [expr {$le - $row}]]
4358 set xp [lindex $cols [expr {$le - 1 - $row}]]
4359 set dir [expr {$xp - $x}]
4360 if {$joinhigh} {
4361 set ith [lindex $lines $i 2]
4362 set coords [$canv coords $ith]
4363 set ah [$canv itemcget $ith -arrow]
4364 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4365 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4366 if {$x2 ne {} && $x - $x2 == $dir} {
4367 set coords [lrange $coords 0 end-2]
4369 } else {
4370 set coords [list [xc $le $x] [yc $le]]
4372 if {$joinlow} {
4373 set itl [lindex $lines [expr {$i-1}] 2]
4374 set al [$canv itemcget $itl -arrow]
4375 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4376 } elseif {$arrowlow} {
4377 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4378 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4379 set arrowlow 0
4382 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4383 for {set y $le} {[incr y -1] > $row} {} {
4384 set x $xp
4385 set xp [lindex $cols [expr {$y - 1 - $row}]]
4386 set ndir [expr {$xp - $x}]
4387 if {$dir != $ndir || $xp < 0} {
4388 lappend coords [xc $y $x] [yc $y]
4390 set dir $ndir
4392 if {!$joinlow} {
4393 if {$xp < 0} {
4394 # join parent line to first child
4395 set ch [lindex $displayorder $row]
4396 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4397 if {$xc < 0} {
4398 puts "oops: drawlineseg: child $ch not on row $row"
4399 } elseif {$xc != $x} {
4400 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4401 set d [expr {int(0.5 * $linespc)}]
4402 set x1 [xc $row $x]
4403 if {$xc < $x} {
4404 set x2 [expr {$x1 - $d}]
4405 } else {
4406 set x2 [expr {$x1 + $d}]
4408 set y2 [yc $row]
4409 set y1 [expr {$y2 + $d}]
4410 lappend coords $x1 $y1 $x2 $y2
4411 } elseif {$xc < $x - 1} {
4412 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4413 } elseif {$xc > $x + 1} {
4414 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4416 set x $xc
4418 lappend coords [xc $row $x] [yc $row]
4419 } else {
4420 set xn [xc $row $xp]
4421 set yn [yc $row]
4422 lappend coords $xn $yn
4424 if {!$joinhigh} {
4425 assigncolor $id
4426 set t [$canv create line $coords -width [linewidth $id] \
4427 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4428 $canv lower $t
4429 bindline $t $id
4430 set lines [linsert $lines $i [list $row $le $t]]
4431 } else {
4432 $canv coords $ith $coords
4433 if {$arrow ne $ah} {
4434 $canv itemconf $ith -arrow $arrow
4436 lset lines $i 0 $row
4438 } else {
4439 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4440 set ndir [expr {$xo - $xp}]
4441 set clow [$canv coords $itl]
4442 if {$dir == $ndir} {
4443 set clow [lrange $clow 2 end]
4445 set coords [concat $coords $clow]
4446 if {!$joinhigh} {
4447 lset lines [expr {$i-1}] 1 $le
4448 } else {
4449 # coalesce two pieces
4450 $canv delete $ith
4451 set b [lindex $lines [expr {$i-1}] 0]
4452 set e [lindex $lines $i 1]
4453 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4455 $canv coords $itl $coords
4456 if {$arrow ne $al} {
4457 $canv itemconf $itl -arrow $arrow
4461 set linesegs($id) $lines
4462 return $le
4465 proc drawparentlinks {id row} {
4466 global rowidlist canv colormap curview parentlist
4467 global idpos linespc
4469 set rowids [lindex $rowidlist $row]
4470 set col [lsearch -exact $rowids $id]
4471 if {$col < 0} return
4472 set olds [lindex $parentlist $row]
4473 set row2 [expr {$row + 1}]
4474 set x [xc $row $col]
4475 set y [yc $row]
4476 set y2 [yc $row2]
4477 set d [expr {int(0.5 * $linespc)}]
4478 set ymid [expr {$y + $d}]
4479 set ids [lindex $rowidlist $row2]
4480 # rmx = right-most X coord used
4481 set rmx 0
4482 foreach p $olds {
4483 set i [lsearch -exact $ids $p]
4484 if {$i < 0} {
4485 puts "oops, parent $p of $id not in list"
4486 continue
4488 set x2 [xc $row2 $i]
4489 if {$x2 > $rmx} {
4490 set rmx $x2
4492 set j [lsearch -exact $rowids $p]
4493 if {$j < 0} {
4494 # drawlineseg will do this one for us
4495 continue
4497 assigncolor $p
4498 # should handle duplicated parents here...
4499 set coords [list $x $y]
4500 if {$i != $col} {
4501 # if attaching to a vertical segment, draw a smaller
4502 # slant for visual distinctness
4503 if {$i == $j} {
4504 if {$i < $col} {
4505 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4506 } else {
4507 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4509 } elseif {$i < $col && $i < $j} {
4510 # segment slants towards us already
4511 lappend coords [xc $row $j] $y
4512 } else {
4513 if {$i < $col - 1} {
4514 lappend coords [expr {$x2 + $linespc}] $y
4515 } elseif {$i > $col + 1} {
4516 lappend coords [expr {$x2 - $linespc}] $y
4518 lappend coords $x2 $y2
4520 } else {
4521 lappend coords $x2 $y2
4523 set t [$canv create line $coords -width [linewidth $p] \
4524 -fill $colormap($p) -tags lines.$p]
4525 $canv lower $t
4526 bindline $t $p
4528 if {$rmx > [lindex $idpos($id) 1]} {
4529 lset idpos($id) 1 $rmx
4530 redrawtags $id
4534 proc drawlines {id} {
4535 global canv
4537 $canv itemconf lines.$id -width [linewidth $id]
4540 proc drawcmittext {id row col} {
4541 global linespc canv canv2 canv3 fgcolor curview
4542 global cmitlisted commitinfo rowidlist parentlist
4543 global rowtextx idpos idtags idheads idotherrefs
4544 global linehtag linentag linedtag selectedline
4545 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4547 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4548 set listed $cmitlisted($curview,$id)
4549 if {$id eq $nullid} {
4550 set ofill red
4551 } elseif {$id eq $nullid2} {
4552 set ofill green
4553 } else {
4554 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4556 set x [xc $row $col]
4557 set y [yc $row]
4558 set orad [expr {$linespc / 3}]
4559 if {$listed <= 2} {
4560 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4561 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4562 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4563 } elseif {$listed == 3} {
4564 # triangle pointing left for left-side commits
4565 set t [$canv create polygon \
4566 [expr {$x - $orad}] $y \
4567 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4568 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4569 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4570 } else {
4571 # triangle pointing right for right-side commits
4572 set t [$canv create polygon \
4573 [expr {$x + $orad - 1}] $y \
4574 [expr {$x - $orad}] [expr {$y - $orad}] \
4575 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4576 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4578 $canv raise $t
4579 $canv bind $t <1> {selcanvline {} %x %y}
4580 set rmx [llength [lindex $rowidlist $row]]
4581 set olds [lindex $parentlist $row]
4582 if {$olds ne {}} {
4583 set nextids [lindex $rowidlist [expr {$row + 1}]]
4584 foreach p $olds {
4585 set i [lsearch -exact $nextids $p]
4586 if {$i > $rmx} {
4587 set rmx $i
4591 set xt [xc $row $rmx]
4592 set rowtextx($row) $xt
4593 set idpos($id) [list $x $xt $y]
4594 if {[info exists idtags($id)] || [info exists idheads($id)]
4595 || [info exists idotherrefs($id)]} {
4596 set xt [drawtags $id $x $xt $y]
4598 set headline [lindex $commitinfo($id) 0]
4599 set name [lindex $commitinfo($id) 1]
4600 set date [lindex $commitinfo($id) 2]
4601 set date [formatdate $date]
4602 set font mainfont
4603 set nfont mainfont
4604 set isbold [ishighlighted $id]
4605 if {$isbold > 0} {
4606 lappend boldrows $row
4607 set font mainfontbold
4608 if {$isbold > 1} {
4609 lappend boldnamerows $row
4610 set nfont mainfontbold
4613 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4614 -text $headline -font $font -tags text]
4615 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4616 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4617 -text $name -font $nfont -tags text]
4618 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4619 -text $date -font mainfont -tags text]
4620 if {[info exists selectedline] && $selectedline == $row} {
4621 make_secsel $row
4623 set xr [expr {$xt + [font measure $font $headline]}]
4624 if {$xr > $canvxmax} {
4625 set canvxmax $xr
4626 setcanvscroll
4630 proc drawcmitrow {row} {
4631 global displayorder rowidlist nrows_drawn
4632 global iddrawn markingmatches
4633 global commitinfo numcommits
4634 global filehighlight fhighlights findpattern nhighlights
4635 global hlview vhighlights
4636 global highlight_related rhighlights
4638 if {$row >= $numcommits} return
4640 set id [lindex $displayorder $row]
4641 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4642 askvhighlight $row $id
4644 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4645 askfilehighlight $row $id
4647 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4648 askfindhighlight $row $id
4650 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4651 askrelhighlight $row $id
4653 if {![info exists iddrawn($id)]} {
4654 set col [lsearch -exact [lindex $rowidlist $row] $id]
4655 if {$col < 0} {
4656 puts "oops, row $row id $id not in list"
4657 return
4659 if {![info exists commitinfo($id)]} {
4660 getcommit $id
4662 assigncolor $id
4663 drawcmittext $id $row $col
4664 set iddrawn($id) 1
4665 incr nrows_drawn
4667 if {$markingmatches} {
4668 markrowmatches $row $id
4672 proc drawcommits {row {endrow {}}} {
4673 global numcommits iddrawn displayorder curview need_redisplay
4674 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4676 if {$row < 0} {
4677 set row 0
4679 if {$endrow eq {}} {
4680 set endrow $row
4682 if {$endrow >= $numcommits} {
4683 set endrow [expr {$numcommits - 1}]
4686 set rl1 [expr {$row - $downarrowlen - 3}]
4687 if {$rl1 < 0} {
4688 set rl1 0
4690 set ro1 [expr {$row - 3}]
4691 if {$ro1 < 0} {
4692 set ro1 0
4694 set r2 [expr {$endrow + $uparrowlen + 3}]
4695 if {$r2 > $numcommits} {
4696 set r2 $numcommits
4698 for {set r $rl1} {$r < $r2} {incr r} {
4699 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4700 if {$rl1 < $r} {
4701 layoutrows $rl1 $r
4703 set rl1 [expr {$r + 1}]
4706 if {$rl1 < $r} {
4707 layoutrows $rl1 $r
4709 optimize_rows $ro1 0 $r2
4710 if {$need_redisplay || $nrows_drawn > 2000} {
4711 clear_display
4712 drawvisible
4715 # make the lines join to already-drawn rows either side
4716 set r [expr {$row - 1}]
4717 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4718 set r $row
4720 set er [expr {$endrow + 1}]
4721 if {$er >= $numcommits ||
4722 ![info exists iddrawn([lindex $displayorder $er])]} {
4723 set er $endrow
4725 for {} {$r <= $er} {incr r} {
4726 set id [lindex $displayorder $r]
4727 set wasdrawn [info exists iddrawn($id)]
4728 drawcmitrow $r
4729 if {$r == $er} break
4730 set nextid [lindex $displayorder [expr {$r + 1}]]
4731 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4732 drawparentlinks $id $r
4734 set rowids [lindex $rowidlist $r]
4735 foreach lid $rowids {
4736 if {$lid eq {}} continue
4737 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4738 if {$lid eq $id} {
4739 # see if this is the first child of any of its parents
4740 foreach p [lindex $parentlist $r] {
4741 if {[lsearch -exact $rowids $p] < 0} {
4742 # make this line extend up to the child
4743 set lineend($p) [drawlineseg $p $r $er 0]
4746 } else {
4747 set lineend($lid) [drawlineseg $lid $r $er 1]
4753 proc undolayout {row} {
4754 global uparrowlen mingaplen downarrowlen
4755 global rowidlist rowisopt rowfinal need_redisplay
4757 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4758 if {$r < 0} {
4759 set r 0
4761 if {[llength $rowidlist] > $r} {
4762 incr r -1
4763 set rowidlist [lrange $rowidlist 0 $r]
4764 set rowfinal [lrange $rowfinal 0 $r]
4765 set rowisopt [lrange $rowisopt 0 $r]
4766 set need_redisplay 1
4767 run drawvisible
4771 proc drawvisible {} {
4772 global canv linespc curview vrowmod selectedline targetrow targetid
4773 global need_redisplay cscroll numcommits
4775 set fs [$canv yview]
4776 set ymax [lindex [$canv cget -scrollregion] 3]
4777 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4778 set f0 [lindex $fs 0]
4779 set f1 [lindex $fs 1]
4780 set y0 [expr {int($f0 * $ymax)}]
4781 set y1 [expr {int($f1 * $ymax)}]
4783 if {[info exists targetid]} {
4784 if {[commitinview $targetid $curview]} {
4785 set r [rowofcommit $targetid]
4786 if {$r != $targetrow} {
4787 # Fix up the scrollregion and change the scrolling position
4788 # now that our target row has moved.
4789 set diff [expr {($r - $targetrow) * $linespc}]
4790 set targetrow $r
4791 setcanvscroll
4792 set ymax [lindex [$canv cget -scrollregion] 3]
4793 incr y0 $diff
4794 incr y1 $diff
4795 set f0 [expr {$y0 / $ymax}]
4796 set f1 [expr {$y1 / $ymax}]
4797 allcanvs yview moveto $f0
4798 $cscroll set $f0 $f1
4799 set need_redisplay 1
4801 } else {
4802 unset targetid
4806 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4807 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4808 if {$endrow >= $vrowmod($curview)} {
4809 update_arcrows $curview
4811 if {[info exists selectedline] &&
4812 $row <= $selectedline && $selectedline <= $endrow} {
4813 set targetrow $selectedline
4814 } elseif {[info exists targetid]} {
4815 set targetrow [expr {int(($row + $endrow) / 2)}]
4817 if {[info exists targetrow]} {
4818 if {$targetrow >= $numcommits} {
4819 set targetrow [expr {$numcommits - 1}]
4821 set targetid [commitonrow $targetrow]
4823 drawcommits $row $endrow
4826 proc clear_display {} {
4827 global iddrawn linesegs need_redisplay nrows_drawn
4828 global vhighlights fhighlights nhighlights rhighlights
4830 allcanvs delete all
4831 catch {unset iddrawn}
4832 catch {unset linesegs}
4833 catch {unset vhighlights}
4834 catch {unset fhighlights}
4835 catch {unset nhighlights}
4836 catch {unset rhighlights}
4837 set need_redisplay 0
4838 set nrows_drawn 0
4841 proc findcrossings {id} {
4842 global rowidlist parentlist numcommits displayorder
4844 set cross {}
4845 set ccross {}
4846 foreach {s e} [rowranges $id] {
4847 if {$e >= $numcommits} {
4848 set e [expr {$numcommits - 1}]
4850 if {$e <= $s} continue
4851 for {set row $e} {[incr row -1] >= $s} {} {
4852 set x [lsearch -exact [lindex $rowidlist $row] $id]
4853 if {$x < 0} break
4854 set olds [lindex $parentlist $row]
4855 set kid [lindex $displayorder $row]
4856 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4857 if {$kidx < 0} continue
4858 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4859 foreach p $olds {
4860 set px [lsearch -exact $nextrow $p]
4861 if {$px < 0} continue
4862 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4863 if {[lsearch -exact $ccross $p] >= 0} continue
4864 if {$x == $px + ($kidx < $px? -1: 1)} {
4865 lappend ccross $p
4866 } elseif {[lsearch -exact $cross $p] < 0} {
4867 lappend cross $p
4873 return [concat $ccross {{}} $cross]
4876 proc assigncolor {id} {
4877 global colormap colors nextcolor
4878 global parents children children curview
4880 if {[info exists colormap($id)]} return
4881 set ncolors [llength $colors]
4882 if {[info exists children($curview,$id)]} {
4883 set kids $children($curview,$id)
4884 } else {
4885 set kids {}
4887 if {[llength $kids] == 1} {
4888 set child [lindex $kids 0]
4889 if {[info exists colormap($child)]
4890 && [llength $parents($curview,$child)] == 1} {
4891 set colormap($id) $colormap($child)
4892 return
4895 set badcolors {}
4896 set origbad {}
4897 foreach x [findcrossings $id] {
4898 if {$x eq {}} {
4899 # delimiter between corner crossings and other crossings
4900 if {[llength $badcolors] >= $ncolors - 1} break
4901 set origbad $badcolors
4903 if {[info exists colormap($x)]
4904 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4905 lappend badcolors $colormap($x)
4908 if {[llength $badcolors] >= $ncolors} {
4909 set badcolors $origbad
4911 set origbad $badcolors
4912 if {[llength $badcolors] < $ncolors - 1} {
4913 foreach child $kids {
4914 if {[info exists colormap($child)]
4915 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4916 lappend badcolors $colormap($child)
4918 foreach p $parents($curview,$child) {
4919 if {[info exists colormap($p)]
4920 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4921 lappend badcolors $colormap($p)
4925 if {[llength $badcolors] >= $ncolors} {
4926 set badcolors $origbad
4929 for {set i 0} {$i <= $ncolors} {incr i} {
4930 set c [lindex $colors $nextcolor]
4931 if {[incr nextcolor] >= $ncolors} {
4932 set nextcolor 0
4934 if {[lsearch -exact $badcolors $c]} break
4936 set colormap($id) $c
4939 proc bindline {t id} {
4940 global canv
4942 $canv bind $t <Enter> "lineenter %x %y $id"
4943 $canv bind $t <Motion> "linemotion %x %y $id"
4944 $canv bind $t <Leave> "lineleave $id"
4945 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4948 proc drawtags {id x xt y1} {
4949 global idtags idheads idotherrefs mainhead
4950 global linespc lthickness
4951 global canv rowtextx curview fgcolor bgcolor
4953 set marks {}
4954 set ntags 0
4955 set nheads 0
4956 if {[info exists idtags($id)]} {
4957 set marks $idtags($id)
4958 set ntags [llength $marks]
4960 if {[info exists idheads($id)]} {
4961 set marks [concat $marks $idheads($id)]
4962 set nheads [llength $idheads($id)]
4964 if {[info exists idotherrefs($id)]} {
4965 set marks [concat $marks $idotherrefs($id)]
4967 if {$marks eq {}} {
4968 return $xt
4971 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4972 set yt [expr {$y1 - 0.5 * $linespc}]
4973 set yb [expr {$yt + $linespc - 1}]
4974 set xvals {}
4975 set wvals {}
4976 set i -1
4977 foreach tag $marks {
4978 incr i
4979 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4980 set wid [font measure mainfontbold $tag]
4981 } else {
4982 set wid [font measure mainfont $tag]
4984 lappend xvals $xt
4985 lappend wvals $wid
4986 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4988 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4989 -width $lthickness -fill black -tags tag.$id]
4990 $canv lower $t
4991 foreach tag $marks x $xvals wid $wvals {
4992 set xl [expr {$x + $delta}]
4993 set xr [expr {$x + $delta + $wid + $lthickness}]
4994 set font mainfont
4995 if {[incr ntags -1] >= 0} {
4996 # draw a tag
4997 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4998 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4999 -width 1 -outline black -fill yellow -tags tag.$id]
5000 $canv bind $t <1> [list showtag $tag 1]
5001 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5002 } else {
5003 # draw a head or other ref
5004 if {[incr nheads -1] >= 0} {
5005 set col green
5006 if {$tag eq $mainhead} {
5007 set font mainfontbold
5009 } else {
5010 set col "#ddddff"
5012 set xl [expr {$xl - $delta/2}]
5013 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5014 -width 1 -outline black -fill $col -tags tag.$id
5015 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5016 set rwid [font measure mainfont $remoteprefix]
5017 set xi [expr {$x + 1}]
5018 set yti [expr {$yt + 1}]
5019 set xri [expr {$x + $rwid}]
5020 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5021 -width 0 -fill "#ffddaa" -tags tag.$id
5024 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5025 -font $font -tags [list tag.$id text]]
5026 if {$ntags >= 0} {
5027 $canv bind $t <1> [list showtag $tag 1]
5028 } elseif {$nheads >= 0} {
5029 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5032 return $xt
5035 proc xcoord {i level ln} {
5036 global canvx0 xspc1 xspc2
5038 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5039 if {$i > 0 && $i == $level} {
5040 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5041 } elseif {$i > $level} {
5042 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5044 return $x
5047 proc show_status {msg} {
5048 global canv fgcolor
5050 clear_display
5051 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5052 -tags text -fill $fgcolor
5055 # Don't change the text pane cursor if it is currently the hand cursor,
5056 # showing that we are over a sha1 ID link.
5057 proc settextcursor {c} {
5058 global ctext curtextcursor
5060 if {[$ctext cget -cursor] == $curtextcursor} {
5061 $ctext config -cursor $c
5063 set curtextcursor $c
5066 proc nowbusy {what {name {}}} {
5067 global isbusy busyname statusw
5069 if {[array names isbusy] eq {}} {
5070 . config -cursor watch
5071 settextcursor watch
5073 set isbusy($what) 1
5074 set busyname($what) $name
5075 if {$name ne {}} {
5076 $statusw conf -text $name
5080 proc notbusy {what} {
5081 global isbusy maincursor textcursor busyname statusw
5083 catch {
5084 unset isbusy($what)
5085 if {$busyname($what) ne {} &&
5086 [$statusw cget -text] eq $busyname($what)} {
5087 $statusw conf -text {}
5090 if {[array names isbusy] eq {}} {
5091 . config -cursor $maincursor
5092 settextcursor $textcursor
5096 proc findmatches {f} {
5097 global findtype findstring
5098 if {$findtype == [mc "Regexp"]} {
5099 set matches [regexp -indices -all -inline $findstring $f]
5100 } else {
5101 set fs $findstring
5102 if {$findtype == [mc "IgnCase"]} {
5103 set f [string tolower $f]
5104 set fs [string tolower $fs]
5106 set matches {}
5107 set i 0
5108 set l [string length $fs]
5109 while {[set j [string first $fs $f $i]] >= 0} {
5110 lappend matches [list $j [expr {$j+$l-1}]]
5111 set i [expr {$j + $l}]
5114 return $matches
5117 proc dofind {{dirn 1} {wrap 1}} {
5118 global findstring findstartline findcurline selectedline numcommits
5119 global gdttype filehighlight fh_serial find_dirn findallowwrap
5121 if {[info exists find_dirn]} {
5122 if {$find_dirn == $dirn} return
5123 stopfinding
5125 focus .
5126 if {$findstring eq {} || $numcommits == 0} return
5127 if {![info exists selectedline]} {
5128 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5129 } else {
5130 set findstartline $selectedline
5132 set findcurline $findstartline
5133 nowbusy finding [mc "Searching"]
5134 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5135 after cancel do_file_hl $fh_serial
5136 do_file_hl $fh_serial
5138 set find_dirn $dirn
5139 set findallowwrap $wrap
5140 run findmore
5143 proc stopfinding {} {
5144 global find_dirn findcurline fprogcoord
5146 if {[info exists find_dirn]} {
5147 unset find_dirn
5148 unset findcurline
5149 notbusy finding
5150 set fprogcoord 0
5151 adjustprogress
5155 proc findmore {} {
5156 global commitdata commitinfo numcommits findpattern findloc
5157 global findstartline findcurline findallowwrap
5158 global find_dirn gdttype fhighlights fprogcoord
5159 global curview varcorder vrownum varccommits vrowmod
5161 if {![info exists find_dirn]} {
5162 return 0
5164 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5165 set l $findcurline
5166 set moretodo 0
5167 if {$find_dirn > 0} {
5168 incr l
5169 if {$l >= $numcommits} {
5170 set l 0
5172 if {$l <= $findstartline} {
5173 set lim [expr {$findstartline + 1}]
5174 } else {
5175 set lim $numcommits
5176 set moretodo $findallowwrap
5178 } else {
5179 if {$l == 0} {
5180 set l $numcommits
5182 incr l -1
5183 if {$l >= $findstartline} {
5184 set lim [expr {$findstartline - 1}]
5185 } else {
5186 set lim -1
5187 set moretodo $findallowwrap
5190 set n [expr {($lim - $l) * $find_dirn}]
5191 if {$n > 500} {
5192 set n 500
5193 set moretodo 1
5195 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5196 update_arcrows $curview
5198 set found 0
5199 set domore 1
5200 set ai [bsearch $vrownum($curview) $l]
5201 set a [lindex $varcorder($curview) $ai]
5202 set arow [lindex $vrownum($curview) $ai]
5203 set ids [lindex $varccommits($curview,$a)]
5204 set arowend [expr {$arow + [llength $ids]}]
5205 if {$gdttype eq [mc "containing:"]} {
5206 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5207 if {$l < $arow || $l >= $arowend} {
5208 incr ai $find_dirn
5209 set a [lindex $varcorder($curview) $ai]
5210 set arow [lindex $vrownum($curview) $ai]
5211 set ids [lindex $varccommits($curview,$a)]
5212 set arowend [expr {$arow + [llength $ids]}]
5214 set id [lindex $ids [expr {$l - $arow}]]
5215 # shouldn't happen unless git log doesn't give all the commits...
5216 if {![info exists commitdata($id)] ||
5217 ![doesmatch $commitdata($id)]} {
5218 continue
5220 if {![info exists commitinfo($id)]} {
5221 getcommit $id
5223 set info $commitinfo($id)
5224 foreach f $info ty $fldtypes {
5225 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5226 [doesmatch $f]} {
5227 set found 1
5228 break
5231 if {$found} break
5233 } else {
5234 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5235 if {$l < $arow || $l >= $arowend} {
5236 incr ai $find_dirn
5237 set a [lindex $varcorder($curview) $ai]
5238 set arow [lindex $vrownum($curview) $ai]
5239 set ids [lindex $varccommits($curview,$a)]
5240 set arowend [expr {$arow + [llength $ids]}]
5242 set id [lindex $ids [expr {$l - $arow}]]
5243 if {![info exists fhighlights($id)]} {
5244 # this sets fhighlights($id) to -1
5245 askfilehighlight $l $id
5247 if {$fhighlights($id) > 0} {
5248 set found $domore
5249 break
5251 if {$fhighlights($id) < 0} {
5252 if {$domore} {
5253 set domore 0
5254 set findcurline [expr {$l - $find_dirn}]
5259 if {$found || ($domore && !$moretodo)} {
5260 unset findcurline
5261 unset find_dirn
5262 notbusy finding
5263 set fprogcoord 0
5264 adjustprogress
5265 if {$found} {
5266 findselectline $l
5267 } else {
5268 bell
5270 return 0
5272 if {!$domore} {
5273 flushhighlights
5274 } else {
5275 set findcurline [expr {$l - $find_dirn}]
5277 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5278 if {$n < 0} {
5279 incr n $numcommits
5281 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5282 adjustprogress
5283 return $domore
5286 proc findselectline {l} {
5287 global findloc commentend ctext findcurline markingmatches gdttype
5289 set markingmatches 1
5290 set findcurline $l
5291 selectline $l 1
5292 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5293 # highlight the matches in the comments
5294 set f [$ctext get 1.0 $commentend]
5295 set matches [findmatches $f]
5296 foreach match $matches {
5297 set start [lindex $match 0]
5298 set end [expr {[lindex $match 1] + 1}]
5299 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5302 drawvisible
5305 # mark the bits of a headline or author that match a find string
5306 proc markmatches {canv l str tag matches font row} {
5307 global selectedline
5309 set bbox [$canv bbox $tag]
5310 set x0 [lindex $bbox 0]
5311 set y0 [lindex $bbox 1]
5312 set y1 [lindex $bbox 3]
5313 foreach match $matches {
5314 set start [lindex $match 0]
5315 set end [lindex $match 1]
5316 if {$start > $end} continue
5317 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5318 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5319 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5320 [expr {$x0+$xlen+2}] $y1 \
5321 -outline {} -tags [list match$l matches] -fill yellow]
5322 $canv lower $t
5323 if {[info exists selectedline] && $row == $selectedline} {
5324 $canv raise $t secsel
5329 proc unmarkmatches {} {
5330 global markingmatches
5332 allcanvs delete matches
5333 set markingmatches 0
5334 stopfinding
5337 proc selcanvline {w x y} {
5338 global canv canvy0 ctext linespc
5339 global rowtextx
5340 set ymax [lindex [$canv cget -scrollregion] 3]
5341 if {$ymax == {}} return
5342 set yfrac [lindex [$canv yview] 0]
5343 set y [expr {$y + $yfrac * $ymax}]
5344 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5345 if {$l < 0} {
5346 set l 0
5348 if {$w eq $canv} {
5349 set xmax [lindex [$canv cget -scrollregion] 2]
5350 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5351 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5353 unmarkmatches
5354 selectline $l 1
5357 proc commit_descriptor {p} {
5358 global commitinfo
5359 if {![info exists commitinfo($p)]} {
5360 getcommit $p
5362 set l "..."
5363 if {[llength $commitinfo($p)] > 1} {
5364 set l [lindex $commitinfo($p) 0]
5366 return "$p ($l)\n"
5369 # append some text to the ctext widget, and make any SHA1 ID
5370 # that we know about be a clickable link.
5371 proc appendwithlinks {text tags} {
5372 global ctext linknum curview pendinglinks
5374 set start [$ctext index "end - 1c"]
5375 $ctext insert end $text $tags
5376 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5377 foreach l $links {
5378 set s [lindex $l 0]
5379 set e [lindex $l 1]
5380 set linkid [string range $text $s $e]
5381 incr e
5382 $ctext tag delete link$linknum
5383 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5384 setlink $linkid link$linknum
5385 incr linknum
5389 proc setlink {id lk} {
5390 global curview ctext pendinglinks commitinterest
5392 if {[commitinview $id $curview]} {
5393 $ctext tag conf $lk -foreground blue -underline 1
5394 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5395 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5396 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5397 } else {
5398 lappend pendinglinks($id) $lk
5399 lappend commitinterest($id) {makelink %I}
5403 proc makelink {id} {
5404 global pendinglinks
5406 if {![info exists pendinglinks($id)]} return
5407 foreach lk $pendinglinks($id) {
5408 setlink $id $lk
5410 unset pendinglinks($id)
5413 proc linkcursor {w inc} {
5414 global linkentercount curtextcursor
5416 if {[incr linkentercount $inc] > 0} {
5417 $w configure -cursor hand2
5418 } else {
5419 $w configure -cursor $curtextcursor
5420 if {$linkentercount < 0} {
5421 set linkentercount 0
5426 proc viewnextline {dir} {
5427 global canv linespc
5429 $canv delete hover
5430 set ymax [lindex [$canv cget -scrollregion] 3]
5431 set wnow [$canv yview]
5432 set wtop [expr {[lindex $wnow 0] * $ymax}]
5433 set newtop [expr {$wtop + $dir * $linespc}]
5434 if {$newtop < 0} {
5435 set newtop 0
5436 } elseif {$newtop > $ymax} {
5437 set newtop $ymax
5439 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5442 # add a list of tag or branch names at position pos
5443 # returns the number of names inserted
5444 proc appendrefs {pos ids var} {
5445 global ctext linknum curview $var maxrefs
5447 if {[catch {$ctext index $pos}]} {
5448 return 0
5450 $ctext conf -state normal
5451 $ctext delete $pos "$pos lineend"
5452 set tags {}
5453 foreach id $ids {
5454 foreach tag [set $var\($id\)] {
5455 lappend tags [list $tag $id]
5458 if {[llength $tags] > $maxrefs} {
5459 $ctext insert $pos "many ([llength $tags])"
5460 } else {
5461 set tags [lsort -index 0 -decreasing $tags]
5462 set sep {}
5463 foreach ti $tags {
5464 set id [lindex $ti 1]
5465 set lk link$linknum
5466 incr linknum
5467 $ctext tag delete $lk
5468 $ctext insert $pos $sep
5469 $ctext insert $pos [lindex $ti 0] $lk
5470 setlink $id $lk
5471 set sep ", "
5474 $ctext conf -state disabled
5475 return [llength $tags]
5478 # called when we have finished computing the nearby tags
5479 proc dispneartags {delay} {
5480 global selectedline currentid showneartags tagphase
5482 if {![info exists selectedline] || !$showneartags} return
5483 after cancel dispnexttag
5484 if {$delay} {
5485 after 200 dispnexttag
5486 set tagphase -1
5487 } else {
5488 after idle dispnexttag
5489 set tagphase 0
5493 proc dispnexttag {} {
5494 global selectedline currentid showneartags tagphase ctext
5496 if {![info exists selectedline] || !$showneartags} return
5497 switch -- $tagphase {
5499 set dtags [desctags $currentid]
5500 if {$dtags ne {}} {
5501 appendrefs precedes $dtags idtags
5505 set atags [anctags $currentid]
5506 if {$atags ne {}} {
5507 appendrefs follows $atags idtags
5511 set dheads [descheads $currentid]
5512 if {$dheads ne {}} {
5513 if {[appendrefs branch $dheads idheads] > 1
5514 && [$ctext get "branch -3c"] eq "h"} {
5515 # turn "Branch" into "Branches"
5516 $ctext conf -state normal
5517 $ctext insert "branch -2c" "es"
5518 $ctext conf -state disabled
5523 if {[incr tagphase] <= 2} {
5524 after idle dispnexttag
5528 proc make_secsel {l} {
5529 global linehtag linentag linedtag canv canv2 canv3
5531 if {![info exists linehtag($l)]} return
5532 $canv delete secsel
5533 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5534 -tags secsel -fill [$canv cget -selectbackground]]
5535 $canv lower $t
5536 $canv2 delete secsel
5537 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5538 -tags secsel -fill [$canv2 cget -selectbackground]]
5539 $canv2 lower $t
5540 $canv3 delete secsel
5541 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5542 -tags secsel -fill [$canv3 cget -selectbackground]]
5543 $canv3 lower $t
5546 proc selectline {l isnew} {
5547 global canv ctext commitinfo selectedline
5548 global canvy0 linespc parents children curview
5549 global currentid sha1entry
5550 global commentend idtags linknum
5551 global mergemax numcommits pending_select
5552 global cmitmode showneartags allcommits
5553 global targetrow targetid lastscrollrows
5554 global autoselect
5556 catch {unset pending_select}
5557 $canv delete hover
5558 normalline
5559 unsel_reflist
5560 stopfinding
5561 if {$l < 0 || $l >= $numcommits} return
5562 set id [commitonrow $l]
5563 set targetid $id
5564 set targetrow $l
5565 set selectedline $l
5566 set currentid $id
5567 if {$lastscrollrows < $numcommits} {
5568 setcanvscroll
5571 set y [expr {$canvy0 + $l * $linespc}]
5572 set ymax [lindex [$canv cget -scrollregion] 3]
5573 set ytop [expr {$y - $linespc - 1}]
5574 set ybot [expr {$y + $linespc + 1}]
5575 set wnow [$canv yview]
5576 set wtop [expr {[lindex $wnow 0] * $ymax}]
5577 set wbot [expr {[lindex $wnow 1] * $ymax}]
5578 set wh [expr {$wbot - $wtop}]
5579 set newtop $wtop
5580 if {$ytop < $wtop} {
5581 if {$ybot < $wtop} {
5582 set newtop [expr {$y - $wh / 2.0}]
5583 } else {
5584 set newtop $ytop
5585 if {$newtop > $wtop - $linespc} {
5586 set newtop [expr {$wtop - $linespc}]
5589 } elseif {$ybot > $wbot} {
5590 if {$ytop > $wbot} {
5591 set newtop [expr {$y - $wh / 2.0}]
5592 } else {
5593 set newtop [expr {$ybot - $wh}]
5594 if {$newtop < $wtop + $linespc} {
5595 set newtop [expr {$wtop + $linespc}]
5599 if {$newtop != $wtop} {
5600 if {$newtop < 0} {
5601 set newtop 0
5603 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5604 drawvisible
5607 make_secsel $l
5609 if {$isnew} {
5610 addtohistory [list selbyid $id]
5613 $sha1entry delete 0 end
5614 $sha1entry insert 0 $id
5615 if {$autoselect} {
5616 $sha1entry selection from 0
5617 $sha1entry selection to end
5619 rhighlight_sel $id
5621 $ctext conf -state normal
5622 clear_ctext
5623 set linknum 0
5624 if {![info exists commitinfo($id)]} {
5625 getcommit $id
5627 set info $commitinfo($id)
5628 set date [formatdate [lindex $info 2]]
5629 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5630 set date [formatdate [lindex $info 4]]
5631 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5632 if {[info exists idtags($id)]} {
5633 $ctext insert end [mc "Tags:"]
5634 foreach tag $idtags($id) {
5635 $ctext insert end " $tag"
5637 $ctext insert end "\n"
5640 set headers {}
5641 set olds $parents($curview,$id)
5642 if {[llength $olds] > 1} {
5643 set np 0
5644 foreach p $olds {
5645 if {$np >= $mergemax} {
5646 set tag mmax
5647 } else {
5648 set tag m$np
5650 $ctext insert end "[mc "Parent"]: " $tag
5651 appendwithlinks [commit_descriptor $p] {}
5652 incr np
5654 } else {
5655 foreach p $olds {
5656 append headers "[mc "Parent"]: [commit_descriptor $p]"
5660 foreach c $children($curview,$id) {
5661 append headers "[mc "Child"]: [commit_descriptor $c]"
5664 # make anything that looks like a SHA1 ID be a clickable link
5665 appendwithlinks $headers {}
5666 if {$showneartags} {
5667 if {![info exists allcommits]} {
5668 getallcommits
5670 $ctext insert end "[mc "Branch"]: "
5671 $ctext mark set branch "end -1c"
5672 $ctext mark gravity branch left
5673 $ctext insert end "\n[mc "Follows"]: "
5674 $ctext mark set follows "end -1c"
5675 $ctext mark gravity follows left
5676 $ctext insert end "\n[mc "Precedes"]: "
5677 $ctext mark set precedes "end -1c"
5678 $ctext mark gravity precedes left
5679 $ctext insert end "\n"
5680 dispneartags 1
5682 $ctext insert end "\n"
5683 set comment [lindex $info 5]
5684 if {[string first "\r" $comment] >= 0} {
5685 set comment [string map {"\r" "\n "} $comment]
5687 appendwithlinks $comment {comment}
5689 $ctext tag remove found 1.0 end
5690 $ctext conf -state disabled
5691 set commentend [$ctext index "end - 1c"]
5693 init_flist [mc "Comments"]
5694 if {$cmitmode eq "tree"} {
5695 gettree $id
5696 } elseif {[llength $olds] <= 1} {
5697 startdiff $id
5698 } else {
5699 mergediff $id
5703 proc selfirstline {} {
5704 unmarkmatches
5705 selectline 0 1
5708 proc sellastline {} {
5709 global numcommits
5710 unmarkmatches
5711 set l [expr {$numcommits - 1}]
5712 selectline $l 1
5715 proc selnextline {dir} {
5716 global selectedline
5717 focus .
5718 if {![info exists selectedline]} return
5719 set l [expr {$selectedline + $dir}]
5720 unmarkmatches
5721 selectline $l 1
5724 proc selnextpage {dir} {
5725 global canv linespc selectedline numcommits
5727 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5728 if {$lpp < 1} {
5729 set lpp 1
5731 allcanvs yview scroll [expr {$dir * $lpp}] units
5732 drawvisible
5733 if {![info exists selectedline]} return
5734 set l [expr {$selectedline + $dir * $lpp}]
5735 if {$l < 0} {
5736 set l 0
5737 } elseif {$l >= $numcommits} {
5738 set l [expr $numcommits - 1]
5740 unmarkmatches
5741 selectline $l 1
5744 proc unselectline {} {
5745 global selectedline currentid
5747 catch {unset selectedline}
5748 catch {unset currentid}
5749 allcanvs delete secsel
5750 rhighlight_none
5753 proc reselectline {} {
5754 global selectedline
5756 if {[info exists selectedline]} {
5757 selectline $selectedline 0
5761 proc addtohistory {cmd} {
5762 global history historyindex curview
5764 set elt [list $curview $cmd]
5765 if {$historyindex > 0
5766 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5767 return
5770 if {$historyindex < [llength $history]} {
5771 set history [lreplace $history $historyindex end $elt]
5772 } else {
5773 lappend history $elt
5775 incr historyindex
5776 if {$historyindex > 1} {
5777 .tf.bar.leftbut conf -state normal
5778 } else {
5779 .tf.bar.leftbut conf -state disabled
5781 .tf.bar.rightbut conf -state disabled
5784 proc godo {elt} {
5785 global curview
5787 set view [lindex $elt 0]
5788 set cmd [lindex $elt 1]
5789 if {$curview != $view} {
5790 showview $view
5792 eval $cmd
5795 proc goback {} {
5796 global history historyindex
5797 focus .
5799 if {$historyindex > 1} {
5800 incr historyindex -1
5801 godo [lindex $history [expr {$historyindex - 1}]]
5802 .tf.bar.rightbut conf -state normal
5804 if {$historyindex <= 1} {
5805 .tf.bar.leftbut conf -state disabled
5809 proc goforw {} {
5810 global history historyindex
5811 focus .
5813 if {$historyindex < [llength $history]} {
5814 set cmd [lindex $history $historyindex]
5815 incr historyindex
5816 godo $cmd
5817 .tf.bar.leftbut conf -state normal
5819 if {$historyindex >= [llength $history]} {
5820 .tf.bar.rightbut conf -state disabled
5824 proc gettree {id} {
5825 global treefilelist treeidlist diffids diffmergeid treepending
5826 global nullid nullid2
5828 set diffids $id
5829 catch {unset diffmergeid}
5830 if {![info exists treefilelist($id)]} {
5831 if {![info exists treepending]} {
5832 if {$id eq $nullid} {
5833 set cmd [list | git ls-files]
5834 } elseif {$id eq $nullid2} {
5835 set cmd [list | git ls-files --stage -t]
5836 } else {
5837 set cmd [list | git ls-tree -r $id]
5839 if {[catch {set gtf [open $cmd r]}]} {
5840 return
5842 set treepending $id
5843 set treefilelist($id) {}
5844 set treeidlist($id) {}
5845 fconfigure $gtf -blocking 0
5846 filerun $gtf [list gettreeline $gtf $id]
5848 } else {
5849 setfilelist $id
5853 proc gettreeline {gtf id} {
5854 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5856 set nl 0
5857 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5858 if {$diffids eq $nullid} {
5859 set fname $line
5860 } else {
5861 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5862 set i [string first "\t" $line]
5863 if {$i < 0} continue
5864 set sha1 [lindex $line 2]
5865 set fname [string range $line [expr {$i+1}] end]
5866 if {[string index $fname 0] eq "\""} {
5867 set fname [lindex $fname 0]
5869 lappend treeidlist($id) $sha1
5871 lappend treefilelist($id) $fname
5873 if {![eof $gtf]} {
5874 return [expr {$nl >= 1000? 2: 1}]
5876 close $gtf
5877 unset treepending
5878 if {$cmitmode ne "tree"} {
5879 if {![info exists diffmergeid]} {
5880 gettreediffs $diffids
5882 } elseif {$id ne $diffids} {
5883 gettree $diffids
5884 } else {
5885 setfilelist $id
5887 return 0
5890 proc showfile {f} {
5891 global treefilelist treeidlist diffids nullid nullid2
5892 global ctext commentend
5894 set i [lsearch -exact $treefilelist($diffids) $f]
5895 if {$i < 0} {
5896 puts "oops, $f not in list for id $diffids"
5897 return
5899 if {$diffids eq $nullid} {
5900 if {[catch {set bf [open $f r]} err]} {
5901 puts "oops, can't read $f: $err"
5902 return
5904 } else {
5905 set blob [lindex $treeidlist($diffids) $i]
5906 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5907 puts "oops, error reading blob $blob: $err"
5908 return
5911 fconfigure $bf -blocking 0
5912 filerun $bf [list getblobline $bf $diffids]
5913 $ctext config -state normal
5914 clear_ctext $commentend
5915 $ctext insert end "\n"
5916 $ctext insert end "$f\n" filesep
5917 $ctext config -state disabled
5918 $ctext yview $commentend
5919 settabs 0
5922 proc getblobline {bf id} {
5923 global diffids cmitmode ctext
5925 if {$id ne $diffids || $cmitmode ne "tree"} {
5926 catch {close $bf}
5927 return 0
5929 $ctext config -state normal
5930 set nl 0
5931 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5932 $ctext insert end "$line\n"
5934 if {[eof $bf]} {
5935 # delete last newline
5936 $ctext delete "end - 2c" "end - 1c"
5937 close $bf
5938 return 0
5940 $ctext config -state disabled
5941 return [expr {$nl >= 1000? 2: 1}]
5944 proc mergediff {id} {
5945 global diffmergeid mdifffd
5946 global diffids
5947 global parents
5948 global diffcontext
5949 global limitdiffs vfilelimit curview
5951 set diffmergeid $id
5952 set diffids $id
5953 # this doesn't seem to actually affect anything...
5954 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5955 if {$limitdiffs && $vfilelimit($curview) ne {}} {
5956 set cmd [concat $cmd -- $vfilelimit($curview)]
5958 if {[catch {set mdf [open $cmd r]} err]} {
5959 error_popup "[mc "Error getting merge diffs:"] $err"
5960 return
5962 fconfigure $mdf -blocking 0
5963 set mdifffd($id) $mdf
5964 set np [llength $parents($curview,$id)]
5965 settabs $np
5966 filerun $mdf [list getmergediffline $mdf $id $np]
5969 proc getmergediffline {mdf id np} {
5970 global diffmergeid ctext cflist mergemax
5971 global difffilestart mdifffd
5973 $ctext conf -state normal
5974 set nr 0
5975 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5976 if {![info exists diffmergeid] || $id != $diffmergeid
5977 || $mdf != $mdifffd($id)} {
5978 close $mdf
5979 return 0
5981 if {[regexp {^diff --cc (.*)} $line match fname]} {
5982 # start of a new file
5983 $ctext insert end "\n"
5984 set here [$ctext index "end - 1c"]
5985 lappend difffilestart $here
5986 add_flist [list $fname]
5987 set l [expr {(78 - [string length $fname]) / 2}]
5988 set pad [string range "----------------------------------------" 1 $l]
5989 $ctext insert end "$pad $fname $pad\n" filesep
5990 } elseif {[regexp {^@@} $line]} {
5991 $ctext insert end "$line\n" hunksep
5992 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5993 # do nothing
5994 } else {
5995 # parse the prefix - one ' ', '-' or '+' for each parent
5996 set spaces {}
5997 set minuses {}
5998 set pluses {}
5999 set isbad 0
6000 for {set j 0} {$j < $np} {incr j} {
6001 set c [string range $line $j $j]
6002 if {$c == " "} {
6003 lappend spaces $j
6004 } elseif {$c == "-"} {
6005 lappend minuses $j
6006 } elseif {$c == "+"} {
6007 lappend pluses $j
6008 } else {
6009 set isbad 1
6010 break
6013 set tags {}
6014 set num {}
6015 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6016 # line doesn't appear in result, parents in $minuses have the line
6017 set num [lindex $minuses 0]
6018 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6019 # line appears in result, parents in $pluses don't have the line
6020 lappend tags mresult
6021 set num [lindex $spaces 0]
6023 if {$num ne {}} {
6024 if {$num >= $mergemax} {
6025 set num "max"
6027 lappend tags m$num
6029 $ctext insert end "$line\n" $tags
6032 $ctext conf -state disabled
6033 if {[eof $mdf]} {
6034 close $mdf
6035 return 0
6037 return [expr {$nr >= 1000? 2: 1}]
6040 proc startdiff {ids} {
6041 global treediffs diffids treepending diffmergeid nullid nullid2
6043 settabs 1
6044 set diffids $ids
6045 catch {unset diffmergeid}
6046 if {![info exists treediffs($ids)] ||
6047 [lsearch -exact $ids $nullid] >= 0 ||
6048 [lsearch -exact $ids $nullid2] >= 0} {
6049 if {![info exists treepending]} {
6050 gettreediffs $ids
6052 } else {
6053 addtocflist $ids
6057 proc path_filter {filter name} {
6058 foreach p $filter {
6059 set l [string length $p]
6060 if {[string index $p end] eq "/"} {
6061 if {[string compare -length $l $p $name] == 0} {
6062 return 1
6064 } else {
6065 if {[string compare -length $l $p $name] == 0 &&
6066 ([string length $name] == $l ||
6067 [string index $name $l] eq "/")} {
6068 return 1
6072 return 0
6075 proc addtocflist {ids} {
6076 global treediffs
6078 add_flist $treediffs($ids)
6079 getblobdiffs $ids
6082 proc diffcmd {ids flags} {
6083 global nullid nullid2
6085 set i [lsearch -exact $ids $nullid]
6086 set j [lsearch -exact $ids $nullid2]
6087 if {$i >= 0} {
6088 if {[llength $ids] > 1 && $j < 0} {
6089 # comparing working directory with some specific revision
6090 set cmd [concat | git diff-index $flags]
6091 if {$i == 0} {
6092 lappend cmd -R [lindex $ids 1]
6093 } else {
6094 lappend cmd [lindex $ids 0]
6096 } else {
6097 # comparing working directory with index
6098 set cmd [concat | git diff-files $flags]
6099 if {$j == 1} {
6100 lappend cmd -R
6103 } elseif {$j >= 0} {
6104 set cmd [concat | git diff-index --cached $flags]
6105 if {[llength $ids] > 1} {
6106 # comparing index with specific revision
6107 if {$i == 0} {
6108 lappend cmd -R [lindex $ids 1]
6109 } else {
6110 lappend cmd [lindex $ids 0]
6112 } else {
6113 # comparing index with HEAD
6114 lappend cmd HEAD
6116 } else {
6117 set cmd [concat | git diff-tree -r $flags $ids]
6119 return $cmd
6122 proc gettreediffs {ids} {
6123 global treediff treepending
6125 set treepending $ids
6126 set treediff {}
6127 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6128 fconfigure $gdtf -blocking 0
6129 filerun $gdtf [list gettreediffline $gdtf $ids]
6132 proc gettreediffline {gdtf ids} {
6133 global treediff treediffs treepending diffids diffmergeid
6134 global cmitmode vfilelimit curview limitdiffs
6136 set nr 0
6137 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6138 set i [string first "\t" $line]
6139 if {$i >= 0} {
6140 set file [string range $line [expr {$i+1}] end]
6141 if {[string index $file 0] eq "\""} {
6142 set file [lindex $file 0]
6144 lappend treediff $file
6147 if {![eof $gdtf]} {
6148 return [expr {$nr >= 1000? 2: 1}]
6150 close $gdtf
6151 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6152 set flist {}
6153 foreach f $treediff {
6154 if {[path_filter $vfilelimit($curview) $f]} {
6155 lappend flist $f
6158 set treediffs($ids) $flist
6159 } else {
6160 set treediffs($ids) $treediff
6162 unset treepending
6163 if {$cmitmode eq "tree"} {
6164 gettree $diffids
6165 } elseif {$ids != $diffids} {
6166 if {![info exists diffmergeid]} {
6167 gettreediffs $diffids
6169 } else {
6170 addtocflist $ids
6172 return 0
6175 # empty string or positive integer
6176 proc diffcontextvalidate {v} {
6177 return [regexp {^(|[1-9][0-9]*)$} $v]
6180 proc diffcontextchange {n1 n2 op} {
6181 global diffcontextstring diffcontext
6183 if {[string is integer -strict $diffcontextstring]} {
6184 if {$diffcontextstring > 0} {
6185 set diffcontext $diffcontextstring
6186 reselectline
6191 proc changeignorespace {} {
6192 reselectline
6195 proc getblobdiffs {ids} {
6196 global blobdifffd diffids env
6197 global diffinhdr treediffs
6198 global diffcontext
6199 global ignorespace
6200 global limitdiffs vfilelimit curview
6202 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6203 if {$ignorespace} {
6204 append cmd " -w"
6206 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6207 set cmd [concat $cmd -- $vfilelimit($curview)]
6209 if {[catch {set bdf [open $cmd r]} err]} {
6210 puts "error getting diffs: $err"
6211 return
6213 set diffinhdr 0
6214 fconfigure $bdf -blocking 0
6215 set blobdifffd($ids) $bdf
6216 filerun $bdf [list getblobdiffline $bdf $diffids]
6219 proc setinlist {var i val} {
6220 global $var
6222 while {[llength [set $var]] < $i} {
6223 lappend $var {}
6225 if {[llength [set $var]] == $i} {
6226 lappend $var $val
6227 } else {
6228 lset $var $i $val
6232 proc makediffhdr {fname ids} {
6233 global ctext curdiffstart treediffs
6235 set i [lsearch -exact $treediffs($ids) $fname]
6236 if {$i >= 0} {
6237 setinlist difffilestart $i $curdiffstart
6239 set l [expr {(78 - [string length $fname]) / 2}]
6240 set pad [string range "----------------------------------------" 1 $l]
6241 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6244 proc getblobdiffline {bdf ids} {
6245 global diffids blobdifffd ctext curdiffstart
6246 global diffnexthead diffnextnote difffilestart
6247 global diffinhdr treediffs
6249 set nr 0
6250 $ctext conf -state normal
6251 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6252 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6253 close $bdf
6254 return 0
6256 if {![string compare -length 11 "diff --git " $line]} {
6257 # trim off "diff --git "
6258 set line [string range $line 11 end]
6259 set diffinhdr 1
6260 # start of a new file
6261 $ctext insert end "\n"
6262 set curdiffstart [$ctext index "end - 1c"]
6263 $ctext insert end "\n" filesep
6264 # If the name hasn't changed the length will be odd,
6265 # the middle char will be a space, and the two bits either
6266 # side will be a/name and b/name, or "a/name" and "b/name".
6267 # If the name has changed we'll get "rename from" and
6268 # "rename to" or "copy from" and "copy to" lines following this,
6269 # and we'll use them to get the filenames.
6270 # This complexity is necessary because spaces in the filename(s)
6271 # don't get escaped.
6272 set l [string length $line]
6273 set i [expr {$l / 2}]
6274 if {!(($l & 1) && [string index $line $i] eq " " &&
6275 [string range $line 2 [expr {$i - 1}]] eq \
6276 [string range $line [expr {$i + 3}] end])} {
6277 continue
6279 # unescape if quoted and chop off the a/ from the front
6280 if {[string index $line 0] eq "\""} {
6281 set fname [string range [lindex $line 0] 2 end]
6282 } else {
6283 set fname [string range $line 2 [expr {$i - 1}]]
6285 makediffhdr $fname $ids
6287 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6288 $line match f1l f1c f2l f2c rest]} {
6289 $ctext insert end "$line\n" hunksep
6290 set diffinhdr 0
6292 } elseif {$diffinhdr} {
6293 if {![string compare -length 12 "rename from " $line]} {
6294 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6295 if {[string index $fname 0] eq "\""} {
6296 set fname [lindex $fname 0]
6298 set i [lsearch -exact $treediffs($ids) $fname]
6299 if {$i >= 0} {
6300 setinlist difffilestart $i $curdiffstart
6302 } elseif {![string compare -length 10 $line "rename to "] ||
6303 ![string compare -length 8 $line "copy to "]} {
6304 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6305 if {[string index $fname 0] eq "\""} {
6306 set fname [lindex $fname 0]
6308 makediffhdr $fname $ids
6309 } elseif {[string compare -length 3 $line "---"] == 0} {
6310 # do nothing
6311 continue
6312 } elseif {[string compare -length 3 $line "+++"] == 0} {
6313 set diffinhdr 0
6314 continue
6316 $ctext insert end "$line\n" filesep
6318 } else {
6319 set x [string range $line 0 0]
6320 if {$x == "-" || $x == "+"} {
6321 set tag [expr {$x == "+"}]
6322 $ctext insert end "$line\n" d$tag
6323 } elseif {$x == " "} {
6324 $ctext insert end "$line\n"
6325 } else {
6326 # "\ No newline at end of file",
6327 # or something else we don't recognize
6328 $ctext insert end "$line\n" hunksep
6332 $ctext conf -state disabled
6333 if {[eof $bdf]} {
6334 close $bdf
6335 return 0
6337 return [expr {$nr >= 1000? 2: 1}]
6340 proc changediffdisp {} {
6341 global ctext diffelide
6343 $ctext tag conf d0 -elide [lindex $diffelide 0]
6344 $ctext tag conf d1 -elide [lindex $diffelide 1]
6347 proc prevfile {} {
6348 global difffilestart ctext
6349 set prev [lindex $difffilestart 0]
6350 set here [$ctext index @0,0]
6351 foreach loc $difffilestart {
6352 if {[$ctext compare $loc >= $here]} {
6353 $ctext yview $prev
6354 return
6356 set prev $loc
6358 $ctext yview $prev
6361 proc nextfile {} {
6362 global difffilestart ctext
6363 set here [$ctext index @0,0]
6364 foreach loc $difffilestart {
6365 if {[$ctext compare $loc > $here]} {
6366 $ctext yview $loc
6367 return
6372 proc clear_ctext {{first 1.0}} {
6373 global ctext smarktop smarkbot
6374 global pendinglinks
6376 set l [lindex [split $first .] 0]
6377 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6378 set smarktop $l
6380 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6381 set smarkbot $l
6383 $ctext delete $first end
6384 if {$first eq "1.0"} {
6385 catch {unset pendinglinks}
6389 proc settabs {{firstab {}}} {
6390 global firsttabstop tabstop ctext have_tk85
6392 if {$firstab ne {} && $have_tk85} {
6393 set firsttabstop $firstab
6395 set w [font measure textfont "0"]
6396 if {$firsttabstop != 0} {
6397 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6398 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6399 } elseif {$have_tk85 || $tabstop != 8} {
6400 $ctext conf -tabs [expr {$tabstop * $w}]
6401 } else {
6402 $ctext conf -tabs {}
6406 proc incrsearch {name ix op} {
6407 global ctext searchstring searchdirn
6409 $ctext tag remove found 1.0 end
6410 if {[catch {$ctext index anchor}]} {
6411 # no anchor set, use start of selection, or of visible area
6412 set sel [$ctext tag ranges sel]
6413 if {$sel ne {}} {
6414 $ctext mark set anchor [lindex $sel 0]
6415 } elseif {$searchdirn eq "-forwards"} {
6416 $ctext mark set anchor @0,0
6417 } else {
6418 $ctext mark set anchor @0,[winfo height $ctext]
6421 if {$searchstring ne {}} {
6422 set here [$ctext search $searchdirn -- $searchstring anchor]
6423 if {$here ne {}} {
6424 $ctext see $here
6426 searchmarkvisible 1
6430 proc dosearch {} {
6431 global sstring ctext searchstring searchdirn
6433 focus $sstring
6434 $sstring icursor end
6435 set searchdirn -forwards
6436 if {$searchstring ne {}} {
6437 set sel [$ctext tag ranges sel]
6438 if {$sel ne {}} {
6439 set start "[lindex $sel 0] + 1c"
6440 } elseif {[catch {set start [$ctext index anchor]}]} {
6441 set start "@0,0"
6443 set match [$ctext search -count mlen -- $searchstring $start]
6444 $ctext tag remove sel 1.0 end
6445 if {$match eq {}} {
6446 bell
6447 return
6449 $ctext see $match
6450 set mend "$match + $mlen c"
6451 $ctext tag add sel $match $mend
6452 $ctext mark unset anchor
6456 proc dosearchback {} {
6457 global sstring ctext searchstring searchdirn
6459 focus $sstring
6460 $sstring icursor end
6461 set searchdirn -backwards
6462 if {$searchstring ne {}} {
6463 set sel [$ctext tag ranges sel]
6464 if {$sel ne {}} {
6465 set start [lindex $sel 0]
6466 } elseif {[catch {set start [$ctext index anchor]}]} {
6467 set start @0,[winfo height $ctext]
6469 set match [$ctext search -backwards -count ml -- $searchstring $start]
6470 $ctext tag remove sel 1.0 end
6471 if {$match eq {}} {
6472 bell
6473 return
6475 $ctext see $match
6476 set mend "$match + $ml c"
6477 $ctext tag add sel $match $mend
6478 $ctext mark unset anchor
6482 proc searchmark {first last} {
6483 global ctext searchstring
6485 set mend $first.0
6486 while {1} {
6487 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6488 if {$match eq {}} break
6489 set mend "$match + $mlen c"
6490 $ctext tag add found $match $mend
6494 proc searchmarkvisible {doall} {
6495 global ctext smarktop smarkbot
6497 set topline [lindex [split [$ctext index @0,0] .] 0]
6498 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6499 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6500 # no overlap with previous
6501 searchmark $topline $botline
6502 set smarktop $topline
6503 set smarkbot $botline
6504 } else {
6505 if {$topline < $smarktop} {
6506 searchmark $topline [expr {$smarktop-1}]
6507 set smarktop $topline
6509 if {$botline > $smarkbot} {
6510 searchmark [expr {$smarkbot+1}] $botline
6511 set smarkbot $botline
6516 proc scrolltext {f0 f1} {
6517 global searchstring
6519 .bleft.bottom.sb set $f0 $f1
6520 if {$searchstring ne {}} {
6521 searchmarkvisible 0
6525 proc setcoords {} {
6526 global linespc charspc canvx0 canvy0
6527 global xspc1 xspc2 lthickness
6529 set linespc [font metrics mainfont -linespace]
6530 set charspc [font measure mainfont "m"]
6531 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6532 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6533 set lthickness [expr {int($linespc / 9) + 1}]
6534 set xspc1(0) $linespc
6535 set xspc2 $linespc
6538 proc redisplay {} {
6539 global canv
6540 global selectedline
6542 set ymax [lindex [$canv cget -scrollregion] 3]
6543 if {$ymax eq {} || $ymax == 0} return
6544 set span [$canv yview]
6545 clear_display
6546 setcanvscroll
6547 allcanvs yview moveto [lindex $span 0]
6548 drawvisible
6549 if {[info exists selectedline]} {
6550 selectline $selectedline 0
6551 allcanvs yview moveto [lindex $span 0]
6555 proc parsefont {f n} {
6556 global fontattr
6558 set fontattr($f,family) [lindex $n 0]
6559 set s [lindex $n 1]
6560 if {$s eq {} || $s == 0} {
6561 set s 10
6562 } elseif {$s < 0} {
6563 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6565 set fontattr($f,size) $s
6566 set fontattr($f,weight) normal
6567 set fontattr($f,slant) roman
6568 foreach style [lrange $n 2 end] {
6569 switch -- $style {
6570 "normal" -
6571 "bold" {set fontattr($f,weight) $style}
6572 "roman" -
6573 "italic" {set fontattr($f,slant) $style}
6578 proc fontflags {f {isbold 0}} {
6579 global fontattr
6581 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6582 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6583 -slant $fontattr($f,slant)]
6586 proc fontname {f} {
6587 global fontattr
6589 set n [list $fontattr($f,family) $fontattr($f,size)]
6590 if {$fontattr($f,weight) eq "bold"} {
6591 lappend n "bold"
6593 if {$fontattr($f,slant) eq "italic"} {
6594 lappend n "italic"
6596 return $n
6599 proc incrfont {inc} {
6600 global mainfont textfont ctext canv cflist showrefstop
6601 global stopped entries fontattr
6603 unmarkmatches
6604 set s $fontattr(mainfont,size)
6605 incr s $inc
6606 if {$s < 1} {
6607 set s 1
6609 set fontattr(mainfont,size) $s
6610 font config mainfont -size $s
6611 font config mainfontbold -size $s
6612 set mainfont [fontname mainfont]
6613 set s $fontattr(textfont,size)
6614 incr s $inc
6615 if {$s < 1} {
6616 set s 1
6618 set fontattr(textfont,size) $s
6619 font config textfont -size $s
6620 font config textfontbold -size $s
6621 set textfont [fontname textfont]
6622 setcoords
6623 settabs
6624 redisplay
6627 proc clearsha1 {} {
6628 global sha1entry sha1string
6629 if {[string length $sha1string] == 40} {
6630 $sha1entry delete 0 end
6634 proc sha1change {n1 n2 op} {
6635 global sha1string currentid sha1but
6636 if {$sha1string == {}
6637 || ([info exists currentid] && $sha1string == $currentid)} {
6638 set state disabled
6639 } else {
6640 set state normal
6642 if {[$sha1but cget -state] == $state} return
6643 if {$state == "normal"} {
6644 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6645 } else {
6646 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6650 proc gotocommit {} {
6651 global sha1string tagids headids curview varcid
6653 if {$sha1string == {}
6654 || ([info exists currentid] && $sha1string == $currentid)} return
6655 if {[info exists tagids($sha1string)]} {
6656 set id $tagids($sha1string)
6657 } elseif {[info exists headids($sha1string)]} {
6658 set id $headids($sha1string)
6659 } else {
6660 set id [string tolower $sha1string]
6661 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6662 set matches [array names varcid "$curview,$id*"]
6663 if {$matches ne {}} {
6664 if {[llength $matches] > 1} {
6665 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6666 return
6668 set id [lindex [split [lindex $matches 0] ","] 1]
6672 if {[commitinview $id $curview]} {
6673 selectline [rowofcommit $id] 1
6674 return
6676 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6677 set msg [mc "SHA1 id %s is not known" $sha1string]
6678 } else {
6679 set msg [mc "Tag/Head %s is not known" $sha1string]
6681 error_popup $msg
6684 proc lineenter {x y id} {
6685 global hoverx hovery hoverid hovertimer
6686 global commitinfo canv
6688 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6689 set hoverx $x
6690 set hovery $y
6691 set hoverid $id
6692 if {[info exists hovertimer]} {
6693 after cancel $hovertimer
6695 set hovertimer [after 500 linehover]
6696 $canv delete hover
6699 proc linemotion {x y id} {
6700 global hoverx hovery hoverid hovertimer
6702 if {[info exists hoverid] && $id == $hoverid} {
6703 set hoverx $x
6704 set hovery $y
6705 if {[info exists hovertimer]} {
6706 after cancel $hovertimer
6708 set hovertimer [after 500 linehover]
6712 proc lineleave {id} {
6713 global hoverid hovertimer canv
6715 if {[info exists hoverid] && $id == $hoverid} {
6716 $canv delete hover
6717 if {[info exists hovertimer]} {
6718 after cancel $hovertimer
6719 unset hovertimer
6721 unset hoverid
6725 proc linehover {} {
6726 global hoverx hovery hoverid hovertimer
6727 global canv linespc lthickness
6728 global commitinfo
6730 set text [lindex $commitinfo($hoverid) 0]
6731 set ymax [lindex [$canv cget -scrollregion] 3]
6732 if {$ymax == {}} return
6733 set yfrac [lindex [$canv yview] 0]
6734 set x [expr {$hoverx + 2 * $linespc}]
6735 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6736 set x0 [expr {$x - 2 * $lthickness}]
6737 set y0 [expr {$y - 2 * $lthickness}]
6738 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6739 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6740 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6741 -fill \#ffff80 -outline black -width 1 -tags hover]
6742 $canv raise $t
6743 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6744 -font mainfont]
6745 $canv raise $t
6748 proc clickisonarrow {id y} {
6749 global lthickness
6751 set ranges [rowranges $id]
6752 set thresh [expr {2 * $lthickness + 6}]
6753 set n [expr {[llength $ranges] - 1}]
6754 for {set i 1} {$i < $n} {incr i} {
6755 set row [lindex $ranges $i]
6756 if {abs([yc $row] - $y) < $thresh} {
6757 return $i
6760 return {}
6763 proc arrowjump {id n y} {
6764 global canv
6766 # 1 <-> 2, 3 <-> 4, etc...
6767 set n [expr {(($n - 1) ^ 1) + 1}]
6768 set row [lindex [rowranges $id] $n]
6769 set yt [yc $row]
6770 set ymax [lindex [$canv cget -scrollregion] 3]
6771 if {$ymax eq {} || $ymax <= 0} return
6772 set view [$canv yview]
6773 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6774 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6775 if {$yfrac < 0} {
6776 set yfrac 0
6778 allcanvs yview moveto $yfrac
6781 proc lineclick {x y id isnew} {
6782 global ctext commitinfo children canv thickerline curview
6784 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6785 unmarkmatches
6786 unselectline
6787 normalline
6788 $canv delete hover
6789 # draw this line thicker than normal
6790 set thickerline $id
6791 drawlines $id
6792 if {$isnew} {
6793 set ymax [lindex [$canv cget -scrollregion] 3]
6794 if {$ymax eq {}} return
6795 set yfrac [lindex [$canv yview] 0]
6796 set y [expr {$y + $yfrac * $ymax}]
6798 set dirn [clickisonarrow $id $y]
6799 if {$dirn ne {}} {
6800 arrowjump $id $dirn $y
6801 return
6804 if {$isnew} {
6805 addtohistory [list lineclick $x $y $id 0]
6807 # fill the details pane with info about this line
6808 $ctext conf -state normal
6809 clear_ctext
6810 settabs 0
6811 $ctext insert end "[mc "Parent"]:\t"
6812 $ctext insert end $id link0
6813 setlink $id link0
6814 set info $commitinfo($id)
6815 $ctext insert end "\n\t[lindex $info 0]\n"
6816 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6817 set date [formatdate [lindex $info 2]]
6818 $ctext insert end "\t[mc "Date"]:\t$date\n"
6819 set kids $children($curview,$id)
6820 if {$kids ne {}} {
6821 $ctext insert end "\n[mc "Children"]:"
6822 set i 0
6823 foreach child $kids {
6824 incr i
6825 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6826 set info $commitinfo($child)
6827 $ctext insert end "\n\t"
6828 $ctext insert end $child link$i
6829 setlink $child link$i
6830 $ctext insert end "\n\t[lindex $info 0]"
6831 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6832 set date [formatdate [lindex $info 2]]
6833 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6836 $ctext conf -state disabled
6837 init_flist {}
6840 proc normalline {} {
6841 global thickerline
6842 if {[info exists thickerline]} {
6843 set id $thickerline
6844 unset thickerline
6845 drawlines $id
6849 proc selbyid {id} {
6850 global curview
6851 if {[commitinview $id $curview]} {
6852 selectline [rowofcommit $id] 1
6856 proc mstime {} {
6857 global startmstime
6858 if {![info exists startmstime]} {
6859 set startmstime [clock clicks -milliseconds]
6861 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6864 proc rowmenu {x y id} {
6865 global rowctxmenu selectedline rowmenuid curview
6866 global nullid nullid2 fakerowmenu mainhead
6868 stopfinding
6869 set rowmenuid $id
6870 if {![info exists selectedline]
6871 || [rowofcommit $id] eq $selectedline} {
6872 set state disabled
6873 } else {
6874 set state normal
6876 if {$id ne $nullid && $id ne $nullid2} {
6877 set menu $rowctxmenu
6878 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6879 } else {
6880 set menu $fakerowmenu
6882 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6883 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6884 $menu entryconfigure [mc "Make patch"] -state $state
6885 tk_popup $menu $x $y
6888 proc diffvssel {dirn} {
6889 global rowmenuid selectedline
6891 if {![info exists selectedline]} return
6892 if {$dirn} {
6893 set oldid [commitonrow $selectedline]
6894 set newid $rowmenuid
6895 } else {
6896 set oldid $rowmenuid
6897 set newid [commitonrow $selectedline]
6899 addtohistory [list doseldiff $oldid $newid]
6900 doseldiff $oldid $newid
6903 proc doseldiff {oldid newid} {
6904 global ctext
6905 global commitinfo
6907 $ctext conf -state normal
6908 clear_ctext
6909 init_flist [mc "Top"]
6910 $ctext insert end "[mc "From"] "
6911 $ctext insert end $oldid link0
6912 setlink $oldid link0
6913 $ctext insert end "\n "
6914 $ctext insert end [lindex $commitinfo($oldid) 0]
6915 $ctext insert end "\n\n[mc "To"] "
6916 $ctext insert end $newid link1
6917 setlink $newid link1
6918 $ctext insert end "\n "
6919 $ctext insert end [lindex $commitinfo($newid) 0]
6920 $ctext insert end "\n"
6921 $ctext conf -state disabled
6922 $ctext tag remove found 1.0 end
6923 startdiff [list $oldid $newid]
6926 proc mkpatch {} {
6927 global rowmenuid currentid commitinfo patchtop patchnum
6929 if {![info exists currentid]} return
6930 set oldid $currentid
6931 set oldhead [lindex $commitinfo($oldid) 0]
6932 set newid $rowmenuid
6933 set newhead [lindex $commitinfo($newid) 0]
6934 set top .patch
6935 set patchtop $top
6936 catch {destroy $top}
6937 toplevel $top
6938 label $top.title -text [mc "Generate patch"]
6939 grid $top.title - -pady 10
6940 label $top.from -text [mc "From:"]
6941 entry $top.fromsha1 -width 40 -relief flat
6942 $top.fromsha1 insert 0 $oldid
6943 $top.fromsha1 conf -state readonly
6944 grid $top.from $top.fromsha1 -sticky w
6945 entry $top.fromhead -width 60 -relief flat
6946 $top.fromhead insert 0 $oldhead
6947 $top.fromhead conf -state readonly
6948 grid x $top.fromhead -sticky w
6949 label $top.to -text [mc "To:"]
6950 entry $top.tosha1 -width 40 -relief flat
6951 $top.tosha1 insert 0 $newid
6952 $top.tosha1 conf -state readonly
6953 grid $top.to $top.tosha1 -sticky w
6954 entry $top.tohead -width 60 -relief flat
6955 $top.tohead insert 0 $newhead
6956 $top.tohead conf -state readonly
6957 grid x $top.tohead -sticky w
6958 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6959 grid $top.rev x -pady 10
6960 label $top.flab -text [mc "Output file:"]
6961 entry $top.fname -width 60
6962 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6963 incr patchnum
6964 grid $top.flab $top.fname -sticky w
6965 frame $top.buts
6966 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6967 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6968 grid $top.buts.gen $top.buts.can
6969 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6970 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6971 grid $top.buts - -pady 10 -sticky ew
6972 focus $top.fname
6975 proc mkpatchrev {} {
6976 global patchtop
6978 set oldid [$patchtop.fromsha1 get]
6979 set oldhead [$patchtop.fromhead get]
6980 set newid [$patchtop.tosha1 get]
6981 set newhead [$patchtop.tohead get]
6982 foreach e [list fromsha1 fromhead tosha1 tohead] \
6983 v [list $newid $newhead $oldid $oldhead] {
6984 $patchtop.$e conf -state normal
6985 $patchtop.$e delete 0 end
6986 $patchtop.$e insert 0 $v
6987 $patchtop.$e conf -state readonly
6991 proc mkpatchgo {} {
6992 global patchtop nullid nullid2
6994 set oldid [$patchtop.fromsha1 get]
6995 set newid [$patchtop.tosha1 get]
6996 set fname [$patchtop.fname get]
6997 set cmd [diffcmd [list $oldid $newid] -p]
6998 # trim off the initial "|"
6999 set cmd [lrange $cmd 1 end]
7000 lappend cmd >$fname &
7001 if {[catch {eval exec $cmd} err]} {
7002 error_popup "[mc "Error creating patch:"] $err"
7004 catch {destroy $patchtop}
7005 unset patchtop
7008 proc mkpatchcan {} {
7009 global patchtop
7011 catch {destroy $patchtop}
7012 unset patchtop
7015 proc mktag {} {
7016 global rowmenuid mktagtop commitinfo
7018 set top .maketag
7019 set mktagtop $top
7020 catch {destroy $top}
7021 toplevel $top
7022 label $top.title -text [mc "Create tag"]
7023 grid $top.title - -pady 10
7024 label $top.id -text [mc "ID:"]
7025 entry $top.sha1 -width 40 -relief flat
7026 $top.sha1 insert 0 $rowmenuid
7027 $top.sha1 conf -state readonly
7028 grid $top.id $top.sha1 -sticky w
7029 entry $top.head -width 60 -relief flat
7030 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7031 $top.head conf -state readonly
7032 grid x $top.head -sticky w
7033 label $top.tlab -text [mc "Tag name:"]
7034 entry $top.tag -width 60
7035 grid $top.tlab $top.tag -sticky w
7036 frame $top.buts
7037 button $top.buts.gen -text [mc "Create"] -command mktaggo
7038 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7039 grid $top.buts.gen $top.buts.can
7040 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7041 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7042 grid $top.buts - -pady 10 -sticky ew
7043 focus $top.tag
7046 proc domktag {} {
7047 global mktagtop env tagids idtags
7049 set id [$mktagtop.sha1 get]
7050 set tag [$mktagtop.tag get]
7051 if {$tag == {}} {
7052 error_popup [mc "No tag name specified"]
7053 return
7055 if {[info exists tagids($tag)]} {
7056 error_popup [mc "Tag \"%s\" already exists" $tag]
7057 return
7059 if {[catch {
7060 exec git tag $tag $id
7061 } err]} {
7062 error_popup "[mc "Error creating tag:"] $err"
7063 return
7066 set tagids($tag) $id
7067 lappend idtags($id) $tag
7068 redrawtags $id
7069 addedtag $id
7070 dispneartags 0
7071 run refill_reflist
7074 proc redrawtags {id} {
7075 global canv linehtag idpos currentid curview
7076 global canvxmax iddrawn
7078 if {![commitinview $id $curview]} return
7079 if {![info exists iddrawn($id)]} return
7080 set row [rowofcommit $id]
7081 $canv delete tag.$id
7082 set xt [eval drawtags $id $idpos($id)]
7083 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7084 set text [$canv itemcget $linehtag($row) -text]
7085 set font [$canv itemcget $linehtag($row) -font]
7086 set xr [expr {$xt + [font measure $font $text]}]
7087 if {$xr > $canvxmax} {
7088 set canvxmax $xr
7089 setcanvscroll
7091 if {[info exists currentid] && $currentid == $id} {
7092 make_secsel $row
7096 proc mktagcan {} {
7097 global mktagtop
7099 catch {destroy $mktagtop}
7100 unset mktagtop
7103 proc mktaggo {} {
7104 domktag
7105 mktagcan
7108 proc writecommit {} {
7109 global rowmenuid wrcomtop commitinfo wrcomcmd
7111 set top .writecommit
7112 set wrcomtop $top
7113 catch {destroy $top}
7114 toplevel $top
7115 label $top.title -text [mc "Write commit to file"]
7116 grid $top.title - -pady 10
7117 label $top.id -text [mc "ID:"]
7118 entry $top.sha1 -width 40 -relief flat
7119 $top.sha1 insert 0 $rowmenuid
7120 $top.sha1 conf -state readonly
7121 grid $top.id $top.sha1 -sticky w
7122 entry $top.head -width 60 -relief flat
7123 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7124 $top.head conf -state readonly
7125 grid x $top.head -sticky w
7126 label $top.clab -text [mc "Command:"]
7127 entry $top.cmd -width 60 -textvariable wrcomcmd
7128 grid $top.clab $top.cmd -sticky w -pady 10
7129 label $top.flab -text [mc "Output file:"]
7130 entry $top.fname -width 60
7131 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7132 grid $top.flab $top.fname -sticky w
7133 frame $top.buts
7134 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7135 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7136 grid $top.buts.gen $top.buts.can
7137 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7138 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7139 grid $top.buts - -pady 10 -sticky ew
7140 focus $top.fname
7143 proc wrcomgo {} {
7144 global wrcomtop
7146 set id [$wrcomtop.sha1 get]
7147 set cmd "echo $id | [$wrcomtop.cmd get]"
7148 set fname [$wrcomtop.fname get]
7149 if {[catch {exec sh -c $cmd >$fname &} err]} {
7150 error_popup "[mc "Error writing commit:"] $err"
7152 catch {destroy $wrcomtop}
7153 unset wrcomtop
7156 proc wrcomcan {} {
7157 global wrcomtop
7159 catch {destroy $wrcomtop}
7160 unset wrcomtop
7163 proc mkbranch {} {
7164 global rowmenuid mkbrtop
7166 set top .makebranch
7167 catch {destroy $top}
7168 toplevel $top
7169 label $top.title -text [mc "Create new branch"]
7170 grid $top.title - -pady 10
7171 label $top.id -text [mc "ID:"]
7172 entry $top.sha1 -width 40 -relief flat
7173 $top.sha1 insert 0 $rowmenuid
7174 $top.sha1 conf -state readonly
7175 grid $top.id $top.sha1 -sticky w
7176 label $top.nlab -text [mc "Name:"]
7177 entry $top.name -width 40
7178 grid $top.nlab $top.name -sticky w
7179 frame $top.buts
7180 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7181 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7182 grid $top.buts.go $top.buts.can
7183 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7184 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7185 grid $top.buts - -pady 10 -sticky ew
7186 focus $top.name
7189 proc mkbrgo {top} {
7190 global headids idheads
7192 set name [$top.name get]
7193 set id [$top.sha1 get]
7194 if {$name eq {}} {
7195 error_popup [mc "Please specify a name for the new branch"]
7196 return
7198 catch {destroy $top}
7199 nowbusy newbranch
7200 update
7201 if {[catch {
7202 exec git branch $name $id
7203 } err]} {
7204 notbusy newbranch
7205 error_popup $err
7206 } else {
7207 set headids($name) $id
7208 lappend idheads($id) $name
7209 addedhead $id $name
7210 notbusy newbranch
7211 redrawtags $id
7212 dispneartags 0
7213 run refill_reflist
7217 proc cherrypick {} {
7218 global rowmenuid curview
7219 global mainhead mainheadid
7221 set oldhead [exec git rev-parse HEAD]
7222 set dheads [descheads $rowmenuid]
7223 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7224 set ok [confirm_popup [mc "Commit %s is already\
7225 included in branch %s -- really re-apply it?" \
7226 [string range $rowmenuid 0 7] $mainhead]]
7227 if {!$ok} return
7229 nowbusy cherrypick [mc "Cherry-picking"]
7230 update
7231 # Unfortunately git-cherry-pick writes stuff to stderr even when
7232 # no error occurs, and exec takes that as an indication of error...
7233 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7234 notbusy cherrypick
7235 error_popup $err
7236 return
7238 set newhead [exec git rev-parse HEAD]
7239 if {$newhead eq $oldhead} {
7240 notbusy cherrypick
7241 error_popup [mc "No changes committed"]
7242 return
7244 addnewchild $newhead $oldhead
7245 if {[commitinview $oldhead $curview]} {
7246 insertrow $newhead $oldhead $curview
7247 if {$mainhead ne {}} {
7248 movehead $newhead $mainhead
7249 movedhead $newhead $mainhead
7250 set mainheadid $newhead
7252 redrawtags $oldhead
7253 redrawtags $newhead
7254 selbyid $newhead
7256 notbusy cherrypick
7259 proc resethead {} {
7260 global mainhead rowmenuid confirm_ok resettype
7262 set confirm_ok 0
7263 set w ".confirmreset"
7264 toplevel $w
7265 wm transient $w .
7266 wm title $w [mc "Confirm reset"]
7267 message $w.m -text \
7268 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7269 -justify center -aspect 1000
7270 pack $w.m -side top -fill x -padx 20 -pady 20
7271 frame $w.f -relief sunken -border 2
7272 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7273 grid $w.f.rt -sticky w
7274 set resettype mixed
7275 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7276 -text [mc "Soft: Leave working tree and index untouched"]
7277 grid $w.f.soft -sticky w
7278 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7279 -text [mc "Mixed: Leave working tree untouched, reset index"]
7280 grid $w.f.mixed -sticky w
7281 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7282 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7283 grid $w.f.hard -sticky w
7284 pack $w.f -side top -fill x
7285 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7286 pack $w.ok -side left -fill x -padx 20 -pady 20
7287 button $w.cancel -text [mc Cancel] -command "destroy $w"
7288 pack $w.cancel -side right -fill x -padx 20 -pady 20
7289 bind $w <Visibility> "grab $w; focus $w"
7290 tkwait window $w
7291 if {!$confirm_ok} return
7292 if {[catch {set fd [open \
7293 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7294 error_popup $err
7295 } else {
7296 dohidelocalchanges
7297 filerun $fd [list readresetstat $fd]
7298 nowbusy reset [mc "Resetting"]
7299 selbyid $rowmenuid
7303 proc readresetstat {fd} {
7304 global mainhead mainheadid showlocalchanges rprogcoord
7306 if {[gets $fd line] >= 0} {
7307 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7308 set rprogcoord [expr {1.0 * $m / $n}]
7309 adjustprogress
7311 return 1
7313 set rprogcoord 0
7314 adjustprogress
7315 notbusy reset
7316 if {[catch {close $fd} err]} {
7317 error_popup $err
7319 set oldhead $mainheadid
7320 set newhead [exec git rev-parse HEAD]
7321 if {$newhead ne $oldhead} {
7322 movehead $newhead $mainhead
7323 movedhead $newhead $mainhead
7324 set mainheadid $newhead
7325 redrawtags $oldhead
7326 redrawtags $newhead
7328 if {$showlocalchanges} {
7329 doshowlocalchanges
7331 return 0
7334 # context menu for a head
7335 proc headmenu {x y id head} {
7336 global headmenuid headmenuhead headctxmenu mainhead
7338 stopfinding
7339 set headmenuid $id
7340 set headmenuhead $head
7341 set state normal
7342 if {$head eq $mainhead} {
7343 set state disabled
7345 $headctxmenu entryconfigure 0 -state $state
7346 $headctxmenu entryconfigure 1 -state $state
7347 tk_popup $headctxmenu $x $y
7350 proc cobranch {} {
7351 global headmenuid headmenuhead mainhead headids
7352 global showlocalchanges mainheadid
7354 # check the tree is clean first??
7355 set oldmainhead $mainhead
7356 nowbusy checkout [mc "Checking out"]
7357 update
7358 dohidelocalchanges
7359 if {[catch {
7360 exec git checkout -q $headmenuhead
7361 } err]} {
7362 notbusy checkout
7363 error_popup $err
7364 } else {
7365 notbusy checkout
7366 set mainhead $headmenuhead
7367 set mainheadid $headmenuid
7368 if {[info exists headids($oldmainhead)]} {
7369 redrawtags $headids($oldmainhead)
7371 redrawtags $headmenuid
7372 selbyid $headmenuid
7374 if {$showlocalchanges} {
7375 dodiffindex
7379 proc rmbranch {} {
7380 global headmenuid headmenuhead mainhead
7381 global idheads
7383 set head $headmenuhead
7384 set id $headmenuid
7385 # this check shouldn't be needed any more...
7386 if {$head eq $mainhead} {
7387 error_popup [mc "Cannot delete the currently checked-out branch"]
7388 return
7390 set dheads [descheads $id]
7391 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7392 # the stuff on this branch isn't on any other branch
7393 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7394 branch.\nReally delete branch %s?" $head $head]]} return
7396 nowbusy rmbranch
7397 update
7398 if {[catch {exec git branch -D $head} err]} {
7399 notbusy rmbranch
7400 error_popup $err
7401 return
7403 removehead $id $head
7404 removedhead $id $head
7405 redrawtags $id
7406 notbusy rmbranch
7407 dispneartags 0
7408 run refill_reflist
7411 # Display a list of tags and heads
7412 proc showrefs {} {
7413 global showrefstop bgcolor fgcolor selectbgcolor
7414 global bglist fglist reflistfilter reflist maincursor
7416 set top .showrefs
7417 set showrefstop $top
7418 if {[winfo exists $top]} {
7419 raise $top
7420 refill_reflist
7421 return
7423 toplevel $top
7424 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7425 text $top.list -background $bgcolor -foreground $fgcolor \
7426 -selectbackground $selectbgcolor -font mainfont \
7427 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7428 -width 30 -height 20 -cursor $maincursor \
7429 -spacing1 1 -spacing3 1 -state disabled
7430 $top.list tag configure highlight -background $selectbgcolor
7431 lappend bglist $top.list
7432 lappend fglist $top.list
7433 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7434 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7435 grid $top.list $top.ysb -sticky nsew
7436 grid $top.xsb x -sticky ew
7437 frame $top.f
7438 label $top.f.l -text "[mc "Filter"]: "
7439 entry $top.f.e -width 20 -textvariable reflistfilter
7440 set reflistfilter "*"
7441 trace add variable reflistfilter write reflistfilter_change
7442 pack $top.f.e -side right -fill x -expand 1
7443 pack $top.f.l -side left
7444 grid $top.f - -sticky ew -pady 2
7445 button $top.close -command [list destroy $top] -text [mc "Close"]
7446 grid $top.close -
7447 grid columnconfigure $top 0 -weight 1
7448 grid rowconfigure $top 0 -weight 1
7449 bind $top.list <1> {break}
7450 bind $top.list <B1-Motion> {break}
7451 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7452 set reflist {}
7453 refill_reflist
7456 proc sel_reflist {w x y} {
7457 global showrefstop reflist headids tagids otherrefids
7459 if {![winfo exists $showrefstop]} return
7460 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7461 set ref [lindex $reflist [expr {$l-1}]]
7462 set n [lindex $ref 0]
7463 switch -- [lindex $ref 1] {
7464 "H" {selbyid $headids($n)}
7465 "T" {selbyid $tagids($n)}
7466 "o" {selbyid $otherrefids($n)}
7468 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7471 proc unsel_reflist {} {
7472 global showrefstop
7474 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7475 $showrefstop.list tag remove highlight 0.0 end
7478 proc reflistfilter_change {n1 n2 op} {
7479 global reflistfilter
7481 after cancel refill_reflist
7482 after 200 refill_reflist
7485 proc refill_reflist {} {
7486 global reflist reflistfilter showrefstop headids tagids otherrefids
7487 global curview commitinterest
7489 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7490 set refs {}
7491 foreach n [array names headids] {
7492 if {[string match $reflistfilter $n]} {
7493 if {[commitinview $headids($n) $curview]} {
7494 lappend refs [list $n H]
7495 } else {
7496 set commitinterest($headids($n)) {run refill_reflist}
7500 foreach n [array names tagids] {
7501 if {[string match $reflistfilter $n]} {
7502 if {[commitinview $tagids($n) $curview]} {
7503 lappend refs [list $n T]
7504 } else {
7505 set commitinterest($tagids($n)) {run refill_reflist}
7509 foreach n [array names otherrefids] {
7510 if {[string match $reflistfilter $n]} {
7511 if {[commitinview $otherrefids($n) $curview]} {
7512 lappend refs [list $n o]
7513 } else {
7514 set commitinterest($otherrefids($n)) {run refill_reflist}
7518 set refs [lsort -index 0 $refs]
7519 if {$refs eq $reflist} return
7521 # Update the contents of $showrefstop.list according to the
7522 # differences between $reflist (old) and $refs (new)
7523 $showrefstop.list conf -state normal
7524 $showrefstop.list insert end "\n"
7525 set i 0
7526 set j 0
7527 while {$i < [llength $reflist] || $j < [llength $refs]} {
7528 if {$i < [llength $reflist]} {
7529 if {$j < [llength $refs]} {
7530 set cmp [string compare [lindex $reflist $i 0] \
7531 [lindex $refs $j 0]]
7532 if {$cmp == 0} {
7533 set cmp [string compare [lindex $reflist $i 1] \
7534 [lindex $refs $j 1]]
7536 } else {
7537 set cmp -1
7539 } else {
7540 set cmp 1
7542 switch -- $cmp {
7543 -1 {
7544 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7545 incr i
7548 incr i
7549 incr j
7552 set l [expr {$j + 1}]
7553 $showrefstop.list image create $l.0 -align baseline \
7554 -image reficon-[lindex $refs $j 1] -padx 2
7555 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7556 incr j
7560 set reflist $refs
7561 # delete last newline
7562 $showrefstop.list delete end-2c end-1c
7563 $showrefstop.list conf -state disabled
7566 # Stuff for finding nearby tags
7567 proc getallcommits {} {
7568 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7569 global idheads idtags idotherrefs allparents tagobjid
7571 if {![info exists allcommits]} {
7572 set nextarc 0
7573 set allcommits 0
7574 set seeds {}
7575 set allcwait 0
7576 set cachedarcs 0
7577 set allccache [file join [gitdir] "gitk.cache"]
7578 if {![catch {
7579 set f [open $allccache r]
7580 set allcwait 1
7581 getcache $f
7582 }]} return
7585 if {$allcwait} {
7586 return
7588 set cmd [list | git rev-list --parents]
7589 set allcupdate [expr {$seeds ne {}}]
7590 if {!$allcupdate} {
7591 set ids "--all"
7592 } else {
7593 set refs [concat [array names idheads] [array names idtags] \
7594 [array names idotherrefs]]
7595 set ids {}
7596 set tagobjs {}
7597 foreach name [array names tagobjid] {
7598 lappend tagobjs $tagobjid($name)
7600 foreach id [lsort -unique $refs] {
7601 if {![info exists allparents($id)] &&
7602 [lsearch -exact $tagobjs $id] < 0} {
7603 lappend ids $id
7606 if {$ids ne {}} {
7607 foreach id $seeds {
7608 lappend ids "^$id"
7612 if {$ids ne {}} {
7613 set fd [open [concat $cmd $ids] r]
7614 fconfigure $fd -blocking 0
7615 incr allcommits
7616 nowbusy allcommits
7617 filerun $fd [list getallclines $fd]
7618 } else {
7619 dispneartags 0
7623 # Since most commits have 1 parent and 1 child, we group strings of
7624 # such commits into "arcs" joining branch/merge points (BMPs), which
7625 # are commits that either don't have 1 parent or don't have 1 child.
7627 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7628 # arcout(id) - outgoing arcs for BMP
7629 # arcids(a) - list of IDs on arc including end but not start
7630 # arcstart(a) - BMP ID at start of arc
7631 # arcend(a) - BMP ID at end of arc
7632 # growing(a) - arc a is still growing
7633 # arctags(a) - IDs out of arcids (excluding end) that have tags
7634 # archeads(a) - IDs out of arcids (excluding end) that have heads
7635 # The start of an arc is at the descendent end, so "incoming" means
7636 # coming from descendents, and "outgoing" means going towards ancestors.
7638 proc getallclines {fd} {
7639 global allparents allchildren idtags idheads nextarc
7640 global arcnos arcids arctags arcout arcend arcstart archeads growing
7641 global seeds allcommits cachedarcs allcupdate
7643 set nid 0
7644 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7645 set id [lindex $line 0]
7646 if {[info exists allparents($id)]} {
7647 # seen it already
7648 continue
7650 set cachedarcs 0
7651 set olds [lrange $line 1 end]
7652 set allparents($id) $olds
7653 if {![info exists allchildren($id)]} {
7654 set allchildren($id) {}
7655 set arcnos($id) {}
7656 lappend seeds $id
7657 } else {
7658 set a $arcnos($id)
7659 if {[llength $olds] == 1 && [llength $a] == 1} {
7660 lappend arcids($a) $id
7661 if {[info exists idtags($id)]} {
7662 lappend arctags($a) $id
7664 if {[info exists idheads($id)]} {
7665 lappend archeads($a) $id
7667 if {[info exists allparents($olds)]} {
7668 # seen parent already
7669 if {![info exists arcout($olds)]} {
7670 splitarc $olds
7672 lappend arcids($a) $olds
7673 set arcend($a) $olds
7674 unset growing($a)
7676 lappend allchildren($olds) $id
7677 lappend arcnos($olds) $a
7678 continue
7681 foreach a $arcnos($id) {
7682 lappend arcids($a) $id
7683 set arcend($a) $id
7684 unset growing($a)
7687 set ao {}
7688 foreach p $olds {
7689 lappend allchildren($p) $id
7690 set a [incr nextarc]
7691 set arcstart($a) $id
7692 set archeads($a) {}
7693 set arctags($a) {}
7694 set archeads($a) {}
7695 set arcids($a) {}
7696 lappend ao $a
7697 set growing($a) 1
7698 if {[info exists allparents($p)]} {
7699 # seen it already, may need to make a new branch
7700 if {![info exists arcout($p)]} {
7701 splitarc $p
7703 lappend arcids($a) $p
7704 set arcend($a) $p
7705 unset growing($a)
7707 lappend arcnos($p) $a
7709 set arcout($id) $ao
7711 if {$nid > 0} {
7712 global cached_dheads cached_dtags cached_atags
7713 catch {unset cached_dheads}
7714 catch {unset cached_dtags}
7715 catch {unset cached_atags}
7717 if {![eof $fd]} {
7718 return [expr {$nid >= 1000? 2: 1}]
7720 set cacheok 1
7721 if {[catch {
7722 fconfigure $fd -blocking 1
7723 close $fd
7724 } err]} {
7725 # got an error reading the list of commits
7726 # if we were updating, try rereading the whole thing again
7727 if {$allcupdate} {
7728 incr allcommits -1
7729 dropcache $err
7730 return
7732 error_popup "[mc "Error reading commit topology information;\
7733 branch and preceding/following tag information\
7734 will be incomplete."]\n($err)"
7735 set cacheok 0
7737 if {[incr allcommits -1] == 0} {
7738 notbusy allcommits
7739 if {$cacheok} {
7740 run savecache
7743 dispneartags 0
7744 return 0
7747 proc recalcarc {a} {
7748 global arctags archeads arcids idtags idheads
7750 set at {}
7751 set ah {}
7752 foreach id [lrange $arcids($a) 0 end-1] {
7753 if {[info exists idtags($id)]} {
7754 lappend at $id
7756 if {[info exists idheads($id)]} {
7757 lappend ah $id
7760 set arctags($a) $at
7761 set archeads($a) $ah
7764 proc splitarc {p} {
7765 global arcnos arcids nextarc arctags archeads idtags idheads
7766 global arcstart arcend arcout allparents growing
7768 set a $arcnos($p)
7769 if {[llength $a] != 1} {
7770 puts "oops splitarc called but [llength $a] arcs already"
7771 return
7773 set a [lindex $a 0]
7774 set i [lsearch -exact $arcids($a) $p]
7775 if {$i < 0} {
7776 puts "oops splitarc $p not in arc $a"
7777 return
7779 set na [incr nextarc]
7780 if {[info exists arcend($a)]} {
7781 set arcend($na) $arcend($a)
7782 } else {
7783 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7784 set j [lsearch -exact $arcnos($l) $a]
7785 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7787 set tail [lrange $arcids($a) [expr {$i+1}] end]
7788 set arcids($a) [lrange $arcids($a) 0 $i]
7789 set arcend($a) $p
7790 set arcstart($na) $p
7791 set arcout($p) $na
7792 set arcids($na) $tail
7793 if {[info exists growing($a)]} {
7794 set growing($na) 1
7795 unset growing($a)
7798 foreach id $tail {
7799 if {[llength $arcnos($id)] == 1} {
7800 set arcnos($id) $na
7801 } else {
7802 set j [lsearch -exact $arcnos($id) $a]
7803 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7807 # reconstruct tags and heads lists
7808 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7809 recalcarc $a
7810 recalcarc $na
7811 } else {
7812 set arctags($na) {}
7813 set archeads($na) {}
7817 # Update things for a new commit added that is a child of one
7818 # existing commit. Used when cherry-picking.
7819 proc addnewchild {id p} {
7820 global allparents allchildren idtags nextarc
7821 global arcnos arcids arctags arcout arcend arcstart archeads growing
7822 global seeds allcommits
7824 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7825 set allparents($id) [list $p]
7826 set allchildren($id) {}
7827 set arcnos($id) {}
7828 lappend seeds $id
7829 lappend allchildren($p) $id
7830 set a [incr nextarc]
7831 set arcstart($a) $id
7832 set archeads($a) {}
7833 set arctags($a) {}
7834 set arcids($a) [list $p]
7835 set arcend($a) $p
7836 if {![info exists arcout($p)]} {
7837 splitarc $p
7839 lappend arcnos($p) $a
7840 set arcout($id) [list $a]
7843 # This implements a cache for the topology information.
7844 # The cache saves, for each arc, the start and end of the arc,
7845 # the ids on the arc, and the outgoing arcs from the end.
7846 proc readcache {f} {
7847 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7848 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7849 global allcwait
7851 set a $nextarc
7852 set lim $cachedarcs
7853 if {$lim - $a > 500} {
7854 set lim [expr {$a + 500}]
7856 if {[catch {
7857 if {$a == $lim} {
7858 # finish reading the cache and setting up arctags, etc.
7859 set line [gets $f]
7860 if {$line ne "1"} {error "bad final version"}
7861 close $f
7862 foreach id [array names idtags] {
7863 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7864 [llength $allparents($id)] == 1} {
7865 set a [lindex $arcnos($id) 0]
7866 if {$arctags($a) eq {}} {
7867 recalcarc $a
7871 foreach id [array names idheads] {
7872 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7873 [llength $allparents($id)] == 1} {
7874 set a [lindex $arcnos($id) 0]
7875 if {$archeads($a) eq {}} {
7876 recalcarc $a
7880 foreach id [lsort -unique $possible_seeds] {
7881 if {$arcnos($id) eq {}} {
7882 lappend seeds $id
7885 set allcwait 0
7886 } else {
7887 while {[incr a] <= $lim} {
7888 set line [gets $f]
7889 if {[llength $line] != 3} {error "bad line"}
7890 set s [lindex $line 0]
7891 set arcstart($a) $s
7892 lappend arcout($s) $a
7893 if {![info exists arcnos($s)]} {
7894 lappend possible_seeds $s
7895 set arcnos($s) {}
7897 set e [lindex $line 1]
7898 if {$e eq {}} {
7899 set growing($a) 1
7900 } else {
7901 set arcend($a) $e
7902 if {![info exists arcout($e)]} {
7903 set arcout($e) {}
7906 set arcids($a) [lindex $line 2]
7907 foreach id $arcids($a) {
7908 lappend allparents($s) $id
7909 set s $id
7910 lappend arcnos($id) $a
7912 if {![info exists allparents($s)]} {
7913 set allparents($s) {}
7915 set arctags($a) {}
7916 set archeads($a) {}
7918 set nextarc [expr {$a - 1}]
7920 } err]} {
7921 dropcache $err
7922 return 0
7924 if {!$allcwait} {
7925 getallcommits
7927 return $allcwait
7930 proc getcache {f} {
7931 global nextarc cachedarcs possible_seeds
7933 if {[catch {
7934 set line [gets $f]
7935 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7936 # make sure it's an integer
7937 set cachedarcs [expr {int([lindex $line 1])}]
7938 if {$cachedarcs < 0} {error "bad number of arcs"}
7939 set nextarc 0
7940 set possible_seeds {}
7941 run readcache $f
7942 } err]} {
7943 dropcache $err
7945 return 0
7948 proc dropcache {err} {
7949 global allcwait nextarc cachedarcs seeds
7951 #puts "dropping cache ($err)"
7952 foreach v {arcnos arcout arcids arcstart arcend growing \
7953 arctags archeads allparents allchildren} {
7954 global $v
7955 catch {unset $v}
7957 set allcwait 0
7958 set nextarc 0
7959 set cachedarcs 0
7960 set seeds {}
7961 getallcommits
7964 proc writecache {f} {
7965 global cachearc cachedarcs allccache
7966 global arcstart arcend arcnos arcids arcout
7968 set a $cachearc
7969 set lim $cachedarcs
7970 if {$lim - $a > 1000} {
7971 set lim [expr {$a + 1000}]
7973 if {[catch {
7974 while {[incr a] <= $lim} {
7975 if {[info exists arcend($a)]} {
7976 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7977 } else {
7978 puts $f [list $arcstart($a) {} $arcids($a)]
7981 } err]} {
7982 catch {close $f}
7983 catch {file delete $allccache}
7984 #puts "writing cache failed ($err)"
7985 return 0
7987 set cachearc [expr {$a - 1}]
7988 if {$a > $cachedarcs} {
7989 puts $f "1"
7990 close $f
7991 return 0
7993 return 1
7996 proc savecache {} {
7997 global nextarc cachedarcs cachearc allccache
7999 if {$nextarc == $cachedarcs} return
8000 set cachearc 0
8001 set cachedarcs $nextarc
8002 catch {
8003 set f [open $allccache w]
8004 puts $f [list 1 $cachedarcs]
8005 run writecache $f
8009 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8010 # or 0 if neither is true.
8011 proc anc_or_desc {a b} {
8012 global arcout arcstart arcend arcnos cached_isanc
8014 if {$arcnos($a) eq $arcnos($b)} {
8015 # Both are on the same arc(s); either both are the same BMP,
8016 # or if one is not a BMP, the other is also not a BMP or is
8017 # the BMP at end of the arc (and it only has 1 incoming arc).
8018 # Or both can be BMPs with no incoming arcs.
8019 if {$a eq $b || $arcnos($a) eq {}} {
8020 return 0
8022 # assert {[llength $arcnos($a)] == 1}
8023 set arc [lindex $arcnos($a) 0]
8024 set i [lsearch -exact $arcids($arc) $a]
8025 set j [lsearch -exact $arcids($arc) $b]
8026 if {$i < 0 || $i > $j} {
8027 return 1
8028 } else {
8029 return -1
8033 if {![info exists arcout($a)]} {
8034 set arc [lindex $arcnos($a) 0]
8035 if {[info exists arcend($arc)]} {
8036 set aend $arcend($arc)
8037 } else {
8038 set aend {}
8040 set a $arcstart($arc)
8041 } else {
8042 set aend $a
8044 if {![info exists arcout($b)]} {
8045 set arc [lindex $arcnos($b) 0]
8046 if {[info exists arcend($arc)]} {
8047 set bend $arcend($arc)
8048 } else {
8049 set bend {}
8051 set b $arcstart($arc)
8052 } else {
8053 set bend $b
8055 if {$a eq $bend} {
8056 return 1
8058 if {$b eq $aend} {
8059 return -1
8061 if {[info exists cached_isanc($a,$bend)]} {
8062 if {$cached_isanc($a,$bend)} {
8063 return 1
8066 if {[info exists cached_isanc($b,$aend)]} {
8067 if {$cached_isanc($b,$aend)} {
8068 return -1
8070 if {[info exists cached_isanc($a,$bend)]} {
8071 return 0
8075 set todo [list $a $b]
8076 set anc($a) a
8077 set anc($b) b
8078 for {set i 0} {$i < [llength $todo]} {incr i} {
8079 set x [lindex $todo $i]
8080 if {$anc($x) eq {}} {
8081 continue
8083 foreach arc $arcnos($x) {
8084 set xd $arcstart($arc)
8085 if {$xd eq $bend} {
8086 set cached_isanc($a,$bend) 1
8087 set cached_isanc($b,$aend) 0
8088 return 1
8089 } elseif {$xd eq $aend} {
8090 set cached_isanc($b,$aend) 1
8091 set cached_isanc($a,$bend) 0
8092 return -1
8094 if {![info exists anc($xd)]} {
8095 set anc($xd) $anc($x)
8096 lappend todo $xd
8097 } elseif {$anc($xd) ne $anc($x)} {
8098 set anc($xd) {}
8102 set cached_isanc($a,$bend) 0
8103 set cached_isanc($b,$aend) 0
8104 return 0
8107 # This identifies whether $desc has an ancestor that is
8108 # a growing tip of the graph and which is not an ancestor of $anc
8109 # and returns 0 if so and 1 if not.
8110 # If we subsequently discover a tag on such a growing tip, and that
8111 # turns out to be a descendent of $anc (which it could, since we
8112 # don't necessarily see children before parents), then $desc
8113 # isn't a good choice to display as a descendent tag of
8114 # $anc (since it is the descendent of another tag which is
8115 # a descendent of $anc). Similarly, $anc isn't a good choice to
8116 # display as a ancestor tag of $desc.
8118 proc is_certain {desc anc} {
8119 global arcnos arcout arcstart arcend growing problems
8121 set certain {}
8122 if {[llength $arcnos($anc)] == 1} {
8123 # tags on the same arc are certain
8124 if {$arcnos($desc) eq $arcnos($anc)} {
8125 return 1
8127 if {![info exists arcout($anc)]} {
8128 # if $anc is partway along an arc, use the start of the arc instead
8129 set a [lindex $arcnos($anc) 0]
8130 set anc $arcstart($a)
8133 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8134 set x $desc
8135 } else {
8136 set a [lindex $arcnos($desc) 0]
8137 set x $arcend($a)
8139 if {$x == $anc} {
8140 return 1
8142 set anclist [list $x]
8143 set dl($x) 1
8144 set nnh 1
8145 set ngrowanc 0
8146 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8147 set x [lindex $anclist $i]
8148 if {$dl($x)} {
8149 incr nnh -1
8151 set done($x) 1
8152 foreach a $arcout($x) {
8153 if {[info exists growing($a)]} {
8154 if {![info exists growanc($x)] && $dl($x)} {
8155 set growanc($x) 1
8156 incr ngrowanc
8158 } else {
8159 set y $arcend($a)
8160 if {[info exists dl($y)]} {
8161 if {$dl($y)} {
8162 if {!$dl($x)} {
8163 set dl($y) 0
8164 if {![info exists done($y)]} {
8165 incr nnh -1
8167 if {[info exists growanc($x)]} {
8168 incr ngrowanc -1
8170 set xl [list $y]
8171 for {set k 0} {$k < [llength $xl]} {incr k} {
8172 set z [lindex $xl $k]
8173 foreach c $arcout($z) {
8174 if {[info exists arcend($c)]} {
8175 set v $arcend($c)
8176 if {[info exists dl($v)] && $dl($v)} {
8177 set dl($v) 0
8178 if {![info exists done($v)]} {
8179 incr nnh -1
8181 if {[info exists growanc($v)]} {
8182 incr ngrowanc -1
8184 lappend xl $v
8191 } elseif {$y eq $anc || !$dl($x)} {
8192 set dl($y) 0
8193 lappend anclist $y
8194 } else {
8195 set dl($y) 1
8196 lappend anclist $y
8197 incr nnh
8202 foreach x [array names growanc] {
8203 if {$dl($x)} {
8204 return 0
8206 return 0
8208 return 1
8211 proc validate_arctags {a} {
8212 global arctags idtags
8214 set i -1
8215 set na $arctags($a)
8216 foreach id $arctags($a) {
8217 incr i
8218 if {![info exists idtags($id)]} {
8219 set na [lreplace $na $i $i]
8220 incr i -1
8223 set arctags($a) $na
8226 proc validate_archeads {a} {
8227 global archeads idheads
8229 set i -1
8230 set na $archeads($a)
8231 foreach id $archeads($a) {
8232 incr i
8233 if {![info exists idheads($id)]} {
8234 set na [lreplace $na $i $i]
8235 incr i -1
8238 set archeads($a) $na
8241 # Return the list of IDs that have tags that are descendents of id,
8242 # ignoring IDs that are descendents of IDs already reported.
8243 proc desctags {id} {
8244 global arcnos arcstart arcids arctags idtags allparents
8245 global growing cached_dtags
8247 if {![info exists allparents($id)]} {
8248 return {}
8250 set t1 [clock clicks -milliseconds]
8251 set argid $id
8252 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8253 # part-way along an arc; check that arc first
8254 set a [lindex $arcnos($id) 0]
8255 if {$arctags($a) ne {}} {
8256 validate_arctags $a
8257 set i [lsearch -exact $arcids($a) $id]
8258 set tid {}
8259 foreach t $arctags($a) {
8260 set j [lsearch -exact $arcids($a) $t]
8261 if {$j >= $i} break
8262 set tid $t
8264 if {$tid ne {}} {
8265 return $tid
8268 set id $arcstart($a)
8269 if {[info exists idtags($id)]} {
8270 return $id
8273 if {[info exists cached_dtags($id)]} {
8274 return $cached_dtags($id)
8277 set origid $id
8278 set todo [list $id]
8279 set queued($id) 1
8280 set nc 1
8281 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8282 set id [lindex $todo $i]
8283 set done($id) 1
8284 set ta [info exists hastaggedancestor($id)]
8285 if {!$ta} {
8286 incr nc -1
8288 # ignore tags on starting node
8289 if {!$ta && $i > 0} {
8290 if {[info exists idtags($id)]} {
8291 set tagloc($id) $id
8292 set ta 1
8293 } elseif {[info exists cached_dtags($id)]} {
8294 set tagloc($id) $cached_dtags($id)
8295 set ta 1
8298 foreach a $arcnos($id) {
8299 set d $arcstart($a)
8300 if {!$ta && $arctags($a) ne {}} {
8301 validate_arctags $a
8302 if {$arctags($a) ne {}} {
8303 lappend tagloc($id) [lindex $arctags($a) end]
8306 if {$ta || $arctags($a) ne {}} {
8307 set tomark [list $d]
8308 for {set j 0} {$j < [llength $tomark]} {incr j} {
8309 set dd [lindex $tomark $j]
8310 if {![info exists hastaggedancestor($dd)]} {
8311 if {[info exists done($dd)]} {
8312 foreach b $arcnos($dd) {
8313 lappend tomark $arcstart($b)
8315 if {[info exists tagloc($dd)]} {
8316 unset tagloc($dd)
8318 } elseif {[info exists queued($dd)]} {
8319 incr nc -1
8321 set hastaggedancestor($dd) 1
8325 if {![info exists queued($d)]} {
8326 lappend todo $d
8327 set queued($d) 1
8328 if {![info exists hastaggedancestor($d)]} {
8329 incr nc
8334 set tags {}
8335 foreach id [array names tagloc] {
8336 if {![info exists hastaggedancestor($id)]} {
8337 foreach t $tagloc($id) {
8338 if {[lsearch -exact $tags $t] < 0} {
8339 lappend tags $t
8344 set t2 [clock clicks -milliseconds]
8345 set loopix $i
8347 # remove tags that are descendents of other tags
8348 for {set i 0} {$i < [llength $tags]} {incr i} {
8349 set a [lindex $tags $i]
8350 for {set j 0} {$j < $i} {incr j} {
8351 set b [lindex $tags $j]
8352 set r [anc_or_desc $a $b]
8353 if {$r == 1} {
8354 set tags [lreplace $tags $j $j]
8355 incr j -1
8356 incr i -1
8357 } elseif {$r == -1} {
8358 set tags [lreplace $tags $i $i]
8359 incr i -1
8360 break
8365 if {[array names growing] ne {}} {
8366 # graph isn't finished, need to check if any tag could get
8367 # eclipsed by another tag coming later. Simply ignore any
8368 # tags that could later get eclipsed.
8369 set ctags {}
8370 foreach t $tags {
8371 if {[is_certain $t $origid]} {
8372 lappend ctags $t
8375 if {$tags eq $ctags} {
8376 set cached_dtags($origid) $tags
8377 } else {
8378 set tags $ctags
8380 } else {
8381 set cached_dtags($origid) $tags
8383 set t3 [clock clicks -milliseconds]
8384 if {0 && $t3 - $t1 >= 100} {
8385 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8386 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8388 return $tags
8391 proc anctags {id} {
8392 global arcnos arcids arcout arcend arctags idtags allparents
8393 global growing cached_atags
8395 if {![info exists allparents($id)]} {
8396 return {}
8398 set t1 [clock clicks -milliseconds]
8399 set argid $id
8400 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8401 # part-way along an arc; check that arc first
8402 set a [lindex $arcnos($id) 0]
8403 if {$arctags($a) ne {}} {
8404 validate_arctags $a
8405 set i [lsearch -exact $arcids($a) $id]
8406 foreach t $arctags($a) {
8407 set j [lsearch -exact $arcids($a) $t]
8408 if {$j > $i} {
8409 return $t
8413 if {![info exists arcend($a)]} {
8414 return {}
8416 set id $arcend($a)
8417 if {[info exists idtags($id)]} {
8418 return $id
8421 if {[info exists cached_atags($id)]} {
8422 return $cached_atags($id)
8425 set origid $id
8426 set todo [list $id]
8427 set queued($id) 1
8428 set taglist {}
8429 set nc 1
8430 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8431 set id [lindex $todo $i]
8432 set done($id) 1
8433 set td [info exists hastaggeddescendent($id)]
8434 if {!$td} {
8435 incr nc -1
8437 # ignore tags on starting node
8438 if {!$td && $i > 0} {
8439 if {[info exists idtags($id)]} {
8440 set tagloc($id) $id
8441 set td 1
8442 } elseif {[info exists cached_atags($id)]} {
8443 set tagloc($id) $cached_atags($id)
8444 set td 1
8447 foreach a $arcout($id) {
8448 if {!$td && $arctags($a) ne {}} {
8449 validate_arctags $a
8450 if {$arctags($a) ne {}} {
8451 lappend tagloc($id) [lindex $arctags($a) 0]
8454 if {![info exists arcend($a)]} continue
8455 set d $arcend($a)
8456 if {$td || $arctags($a) ne {}} {
8457 set tomark [list $d]
8458 for {set j 0} {$j < [llength $tomark]} {incr j} {
8459 set dd [lindex $tomark $j]
8460 if {![info exists hastaggeddescendent($dd)]} {
8461 if {[info exists done($dd)]} {
8462 foreach b $arcout($dd) {
8463 if {[info exists arcend($b)]} {
8464 lappend tomark $arcend($b)
8467 if {[info exists tagloc($dd)]} {
8468 unset tagloc($dd)
8470 } elseif {[info exists queued($dd)]} {
8471 incr nc -1
8473 set hastaggeddescendent($dd) 1
8477 if {![info exists queued($d)]} {
8478 lappend todo $d
8479 set queued($d) 1
8480 if {![info exists hastaggeddescendent($d)]} {
8481 incr nc
8486 set t2 [clock clicks -milliseconds]
8487 set loopix $i
8488 set tags {}
8489 foreach id [array names tagloc] {
8490 if {![info exists hastaggeddescendent($id)]} {
8491 foreach t $tagloc($id) {
8492 if {[lsearch -exact $tags $t] < 0} {
8493 lappend tags $t
8499 # remove tags that are ancestors of other tags
8500 for {set i 0} {$i < [llength $tags]} {incr i} {
8501 set a [lindex $tags $i]
8502 for {set j 0} {$j < $i} {incr j} {
8503 set b [lindex $tags $j]
8504 set r [anc_or_desc $a $b]
8505 if {$r == -1} {
8506 set tags [lreplace $tags $j $j]
8507 incr j -1
8508 incr i -1
8509 } elseif {$r == 1} {
8510 set tags [lreplace $tags $i $i]
8511 incr i -1
8512 break
8517 if {[array names growing] ne {}} {
8518 # graph isn't finished, need to check if any tag could get
8519 # eclipsed by another tag coming later. Simply ignore any
8520 # tags that could later get eclipsed.
8521 set ctags {}
8522 foreach t $tags {
8523 if {[is_certain $origid $t]} {
8524 lappend ctags $t
8527 if {$tags eq $ctags} {
8528 set cached_atags($origid) $tags
8529 } else {
8530 set tags $ctags
8532 } else {
8533 set cached_atags($origid) $tags
8535 set t3 [clock clicks -milliseconds]
8536 if {0 && $t3 - $t1 >= 100} {
8537 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8538 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8540 return $tags
8543 # Return the list of IDs that have heads that are descendents of id,
8544 # including id itself if it has a head.
8545 proc descheads {id} {
8546 global arcnos arcstart arcids archeads idheads cached_dheads
8547 global allparents
8549 if {![info exists allparents($id)]} {
8550 return {}
8552 set aret {}
8553 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8554 # part-way along an arc; check it first
8555 set a [lindex $arcnos($id) 0]
8556 if {$archeads($a) ne {}} {
8557 validate_archeads $a
8558 set i [lsearch -exact $arcids($a) $id]
8559 foreach t $archeads($a) {
8560 set j [lsearch -exact $arcids($a) $t]
8561 if {$j > $i} break
8562 lappend aret $t
8565 set id $arcstart($a)
8567 set origid $id
8568 set todo [list $id]
8569 set seen($id) 1
8570 set ret {}
8571 for {set i 0} {$i < [llength $todo]} {incr i} {
8572 set id [lindex $todo $i]
8573 if {[info exists cached_dheads($id)]} {
8574 set ret [concat $ret $cached_dheads($id)]
8575 } else {
8576 if {[info exists idheads($id)]} {
8577 lappend ret $id
8579 foreach a $arcnos($id) {
8580 if {$archeads($a) ne {}} {
8581 validate_archeads $a
8582 if {$archeads($a) ne {}} {
8583 set ret [concat $ret $archeads($a)]
8586 set d $arcstart($a)
8587 if {![info exists seen($d)]} {
8588 lappend todo $d
8589 set seen($d) 1
8594 set ret [lsort -unique $ret]
8595 set cached_dheads($origid) $ret
8596 return [concat $ret $aret]
8599 proc addedtag {id} {
8600 global arcnos arcout cached_dtags cached_atags
8602 if {![info exists arcnos($id)]} return
8603 if {![info exists arcout($id)]} {
8604 recalcarc [lindex $arcnos($id) 0]
8606 catch {unset cached_dtags}
8607 catch {unset cached_atags}
8610 proc addedhead {hid head} {
8611 global arcnos arcout cached_dheads
8613 if {![info exists arcnos($hid)]} return
8614 if {![info exists arcout($hid)]} {
8615 recalcarc [lindex $arcnos($hid) 0]
8617 catch {unset cached_dheads}
8620 proc removedhead {hid head} {
8621 global cached_dheads
8623 catch {unset cached_dheads}
8626 proc movedhead {hid head} {
8627 global arcnos arcout cached_dheads
8629 if {![info exists arcnos($hid)]} return
8630 if {![info exists arcout($hid)]} {
8631 recalcarc [lindex $arcnos($hid) 0]
8633 catch {unset cached_dheads}
8636 proc changedrefs {} {
8637 global cached_dheads cached_dtags cached_atags
8638 global arctags archeads arcnos arcout idheads idtags
8640 foreach id [concat [array names idheads] [array names idtags]] {
8641 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8642 set a [lindex $arcnos($id) 0]
8643 if {![info exists donearc($a)]} {
8644 recalcarc $a
8645 set donearc($a) 1
8649 catch {unset cached_dtags}
8650 catch {unset cached_atags}
8651 catch {unset cached_dheads}
8654 proc rereadrefs {} {
8655 global idtags idheads idotherrefs mainheadid
8657 set refids [concat [array names idtags] \
8658 [array names idheads] [array names idotherrefs]]
8659 foreach id $refids {
8660 if {![info exists ref($id)]} {
8661 set ref($id) [listrefs $id]
8664 set oldmainhead $mainheadid
8665 readrefs
8666 changedrefs
8667 set refids [lsort -unique [concat $refids [array names idtags] \
8668 [array names idheads] [array names idotherrefs]]]
8669 foreach id $refids {
8670 set v [listrefs $id]
8671 if {![info exists ref($id)] || $ref($id) != $v ||
8672 ($id eq $oldmainhead && $id ne $mainheadid) ||
8673 ($id eq $mainheadid && $id ne $oldmainhead)} {
8674 redrawtags $id
8677 run refill_reflist
8680 proc listrefs {id} {
8681 global idtags idheads idotherrefs
8683 set x {}
8684 if {[info exists idtags($id)]} {
8685 set x $idtags($id)
8687 set y {}
8688 if {[info exists idheads($id)]} {
8689 set y $idheads($id)
8691 set z {}
8692 if {[info exists idotherrefs($id)]} {
8693 set z $idotherrefs($id)
8695 return [list $x $y $z]
8698 proc showtag {tag isnew} {
8699 global ctext tagcontents tagids linknum tagobjid
8701 if {$isnew} {
8702 addtohistory [list showtag $tag 0]
8704 $ctext conf -state normal
8705 clear_ctext
8706 settabs 0
8707 set linknum 0
8708 if {![info exists tagcontents($tag)]} {
8709 catch {
8710 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8713 if {[info exists tagcontents($tag)]} {
8714 set text $tagcontents($tag)
8715 } else {
8716 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8718 appendwithlinks $text {}
8719 $ctext conf -state disabled
8720 init_flist {}
8723 proc doquit {} {
8724 global stopped
8725 set stopped 100
8726 savestuff .
8727 destroy .
8730 proc mkfontdisp {font top which} {
8731 global fontattr fontpref $font
8733 set fontpref($font) [set $font]
8734 button $top.${font}but -text $which -font optionfont \
8735 -command [list choosefont $font $which]
8736 label $top.$font -relief flat -font $font \
8737 -text $fontattr($font,family) -justify left
8738 grid x $top.${font}but $top.$font -sticky w
8741 proc choosefont {font which} {
8742 global fontparam fontlist fonttop fontattr
8744 set fontparam(which) $which
8745 set fontparam(font) $font
8746 set fontparam(family) [font actual $font -family]
8747 set fontparam(size) $fontattr($font,size)
8748 set fontparam(weight) $fontattr($font,weight)
8749 set fontparam(slant) $fontattr($font,slant)
8750 set top .gitkfont
8751 set fonttop $top
8752 if {![winfo exists $top]} {
8753 font create sample
8754 eval font config sample [font actual $font]
8755 toplevel $top
8756 wm title $top [mc "Gitk font chooser"]
8757 label $top.l -textvariable fontparam(which)
8758 pack $top.l -side top
8759 set fontlist [lsort [font families]]
8760 frame $top.f
8761 listbox $top.f.fam -listvariable fontlist \
8762 -yscrollcommand [list $top.f.sb set]
8763 bind $top.f.fam <<ListboxSelect>> selfontfam
8764 scrollbar $top.f.sb -command [list $top.f.fam yview]
8765 pack $top.f.sb -side right -fill y
8766 pack $top.f.fam -side left -fill both -expand 1
8767 pack $top.f -side top -fill both -expand 1
8768 frame $top.g
8769 spinbox $top.g.size -from 4 -to 40 -width 4 \
8770 -textvariable fontparam(size) \
8771 -validatecommand {string is integer -strict %s}
8772 checkbutton $top.g.bold -padx 5 \
8773 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8774 -variable fontparam(weight) -onvalue bold -offvalue normal
8775 checkbutton $top.g.ital -padx 5 \
8776 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8777 -variable fontparam(slant) -onvalue italic -offvalue roman
8778 pack $top.g.size $top.g.bold $top.g.ital -side left
8779 pack $top.g -side top
8780 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8781 -background white
8782 $top.c create text 100 25 -anchor center -text $which -font sample \
8783 -fill black -tags text
8784 bind $top.c <Configure> [list centertext $top.c]
8785 pack $top.c -side top -fill x
8786 frame $top.buts
8787 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8788 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8789 grid $top.buts.ok $top.buts.can
8790 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8791 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8792 pack $top.buts -side bottom -fill x
8793 trace add variable fontparam write chg_fontparam
8794 } else {
8795 raise $top
8796 $top.c itemconf text -text $which
8798 set i [lsearch -exact $fontlist $fontparam(family)]
8799 if {$i >= 0} {
8800 $top.f.fam selection set $i
8801 $top.f.fam see $i
8805 proc centertext {w} {
8806 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8809 proc fontok {} {
8810 global fontparam fontpref prefstop
8812 set f $fontparam(font)
8813 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8814 if {$fontparam(weight) eq "bold"} {
8815 lappend fontpref($f) "bold"
8817 if {$fontparam(slant) eq "italic"} {
8818 lappend fontpref($f) "italic"
8820 set w $prefstop.$f
8821 $w conf -text $fontparam(family) -font $fontpref($f)
8823 fontcan
8826 proc fontcan {} {
8827 global fonttop fontparam
8829 if {[info exists fonttop]} {
8830 catch {destroy $fonttop}
8831 catch {font delete sample}
8832 unset fonttop
8833 unset fontparam
8837 proc selfontfam {} {
8838 global fonttop fontparam
8840 set i [$fonttop.f.fam curselection]
8841 if {$i ne {}} {
8842 set fontparam(family) [$fonttop.f.fam get $i]
8846 proc chg_fontparam {v sub op} {
8847 global fontparam
8849 font config sample -$sub $fontparam($sub)
8852 proc doprefs {} {
8853 global maxwidth maxgraphpct
8854 global oldprefs prefstop showneartags showlocalchanges
8855 global bgcolor fgcolor ctext diffcolors selectbgcolor
8856 global tabstop limitdiffs autoselect
8858 set top .gitkprefs
8859 set prefstop $top
8860 if {[winfo exists $top]} {
8861 raise $top
8862 return
8864 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8865 limitdiffs tabstop} {
8866 set oldprefs($v) [set $v]
8868 toplevel $top
8869 wm title $top [mc "Gitk preferences"]
8870 label $top.ldisp -text [mc "Commit list display options"]
8871 grid $top.ldisp - -sticky w -pady 10
8872 label $top.spacer -text " "
8873 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8874 -font optionfont
8875 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8876 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8877 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8878 -font optionfont
8879 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8880 grid x $top.maxpctl $top.maxpct -sticky w
8881 frame $top.showlocal
8882 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8883 checkbutton $top.showlocal.b -variable showlocalchanges
8884 pack $top.showlocal.b $top.showlocal.l -side left
8885 grid x $top.showlocal -sticky w
8886 frame $top.autoselect
8887 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8888 checkbutton $top.autoselect.b -variable autoselect
8889 pack $top.autoselect.b $top.autoselect.l -side left
8890 grid x $top.autoselect -sticky w
8892 label $top.ddisp -text [mc "Diff display options"]
8893 grid $top.ddisp - -sticky w -pady 10
8894 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8895 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8896 grid x $top.tabstopl $top.tabstop -sticky w
8897 frame $top.ntag
8898 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8899 checkbutton $top.ntag.b -variable showneartags
8900 pack $top.ntag.b $top.ntag.l -side left
8901 grid x $top.ntag -sticky w
8902 frame $top.ldiff
8903 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8904 checkbutton $top.ldiff.b -variable limitdiffs
8905 pack $top.ldiff.b $top.ldiff.l -side left
8906 grid x $top.ldiff -sticky w
8908 label $top.cdisp -text [mc "Colors: press to choose"]
8909 grid $top.cdisp - -sticky w -pady 10
8910 label $top.bg -padx 40 -relief sunk -background $bgcolor
8911 button $top.bgbut -text [mc "Background"] -font optionfont \
8912 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8913 grid x $top.bgbut $top.bg -sticky w
8914 label $top.fg -padx 40 -relief sunk -background $fgcolor
8915 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8916 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8917 grid x $top.fgbut $top.fg -sticky w
8918 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8919 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8920 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8921 [list $ctext tag conf d0 -foreground]]
8922 grid x $top.diffoldbut $top.diffold -sticky w
8923 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8924 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8925 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8926 [list $ctext tag conf d1 -foreground]]
8927 grid x $top.diffnewbut $top.diffnew -sticky w
8928 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8929 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8930 -command [list choosecolor diffcolors 2 $top.hunksep \
8931 "diff hunk header" \
8932 [list $ctext tag conf hunksep -foreground]]
8933 grid x $top.hunksepbut $top.hunksep -sticky w
8934 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8935 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8936 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8937 grid x $top.selbgbut $top.selbgsep -sticky w
8939 label $top.cfont -text [mc "Fonts: press to choose"]
8940 grid $top.cfont - -sticky w -pady 10
8941 mkfontdisp mainfont $top [mc "Main font"]
8942 mkfontdisp textfont $top [mc "Diff display font"]
8943 mkfontdisp uifont $top [mc "User interface font"]
8945 frame $top.buts
8946 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8947 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8948 grid $top.buts.ok $top.buts.can
8949 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8950 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8951 grid $top.buts - - -pady 10 -sticky ew
8952 bind $top <Visibility> "focus $top.buts.ok"
8955 proc choosecolor {v vi w x cmd} {
8956 global $v
8958 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8959 -title [mc "Gitk: choose color for %s" $x]]
8960 if {$c eq {}} return
8961 $w conf -background $c
8962 lset $v $vi $c
8963 eval $cmd $c
8966 proc setselbg {c} {
8967 global bglist cflist
8968 foreach w $bglist {
8969 $w configure -selectbackground $c
8971 $cflist tag configure highlight \
8972 -background [$cflist cget -selectbackground]
8973 allcanvs itemconf secsel -fill $c
8976 proc setbg {c} {
8977 global bglist
8979 foreach w $bglist {
8980 $w conf -background $c
8984 proc setfg {c} {
8985 global fglist canv
8987 foreach w $fglist {
8988 $w conf -foreground $c
8990 allcanvs itemconf text -fill $c
8991 $canv itemconf circle -outline $c
8994 proc prefscan {} {
8995 global oldprefs prefstop
8997 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8998 limitdiffs tabstop} {
8999 global $v
9000 set $v $oldprefs($v)
9002 catch {destroy $prefstop}
9003 unset prefstop
9004 fontcan
9007 proc prefsok {} {
9008 global maxwidth maxgraphpct
9009 global oldprefs prefstop showneartags showlocalchanges
9010 global fontpref mainfont textfont uifont
9011 global limitdiffs treediffs
9013 catch {destroy $prefstop}
9014 unset prefstop
9015 fontcan
9016 set fontchanged 0
9017 if {$mainfont ne $fontpref(mainfont)} {
9018 set mainfont $fontpref(mainfont)
9019 parsefont mainfont $mainfont
9020 eval font configure mainfont [fontflags mainfont]
9021 eval font configure mainfontbold [fontflags mainfont 1]
9022 setcoords
9023 set fontchanged 1
9025 if {$textfont ne $fontpref(textfont)} {
9026 set textfont $fontpref(textfont)
9027 parsefont textfont $textfont
9028 eval font configure textfont [fontflags textfont]
9029 eval font configure textfontbold [fontflags textfont 1]
9031 if {$uifont ne $fontpref(uifont)} {
9032 set uifont $fontpref(uifont)
9033 parsefont uifont $uifont
9034 eval font configure uifont [fontflags uifont]
9036 settabs
9037 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9038 if {$showlocalchanges} {
9039 doshowlocalchanges
9040 } else {
9041 dohidelocalchanges
9044 if {$limitdiffs != $oldprefs(limitdiffs)} {
9045 # treediffs elements are limited by path
9046 catch {unset treediffs}
9048 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9049 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9050 redisplay
9051 } elseif {$showneartags != $oldprefs(showneartags) ||
9052 $limitdiffs != $oldprefs(limitdiffs)} {
9053 reselectline
9057 proc formatdate {d} {
9058 global datetimeformat
9059 if {$d ne {}} {
9060 set d [clock format $d -format $datetimeformat]
9062 return $d
9065 # This list of encoding names and aliases is distilled from
9066 # http://www.iana.org/assignments/character-sets.
9067 # Not all of them are supported by Tcl.
9068 set encoding_aliases {
9069 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9070 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9071 { ISO-10646-UTF-1 csISO10646UTF1 }
9072 { ISO_646.basic:1983 ref csISO646basic1983 }
9073 { INVARIANT csINVARIANT }
9074 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9075 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9076 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9077 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9078 { NATS-DANO iso-ir-9-1 csNATSDANO }
9079 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9080 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9081 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9082 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9083 { ISO-2022-KR csISO2022KR }
9084 { EUC-KR csEUCKR }
9085 { ISO-2022-JP csISO2022JP }
9086 { ISO-2022-JP-2 csISO2022JP2 }
9087 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9088 csISO13JISC6220jp }
9089 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9090 { IT iso-ir-15 ISO646-IT csISO15Italian }
9091 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9092 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9093 { greek7-old iso-ir-18 csISO18Greek7Old }
9094 { latin-greek iso-ir-19 csISO19LatinGreek }
9095 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9096 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9097 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9098 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9099 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9100 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9101 { INIS iso-ir-49 csISO49INIS }
9102 { INIS-8 iso-ir-50 csISO50INIS8 }
9103 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9104 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9105 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9106 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9107 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9108 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9109 csISO60Norwegian1 }
9110 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9111 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9112 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9113 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9114 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9115 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9116 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9117 { greek7 iso-ir-88 csISO88Greek7 }
9118 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9119 { iso-ir-90 csISO90 }
9120 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9121 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9122 csISO92JISC62991984b }
9123 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9124 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9125 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9126 csISO95JIS62291984handadd }
9127 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9128 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9129 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9130 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9131 CP819 csISOLatin1 }
9132 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9133 { T.61-7bit iso-ir-102 csISO102T617bit }
9134 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9135 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9136 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9137 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9138 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9139 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9140 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9141 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9142 arabic csISOLatinArabic }
9143 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9144 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9145 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9146 greek greek8 csISOLatinGreek }
9147 { T.101-G2 iso-ir-128 csISO128T101G2 }
9148 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9149 csISOLatinHebrew }
9150 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9151 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9152 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9153 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9154 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9155 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9156 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9157 csISOLatinCyrillic }
9158 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9159 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9160 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9161 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9162 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9163 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9164 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9165 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9166 { ISO_10367-box iso-ir-155 csISO10367Box }
9167 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9168 { latin-lap lap iso-ir-158 csISO158Lap }
9169 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9170 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9171 { us-dk csUSDK }
9172 { dk-us csDKUS }
9173 { JIS_X0201 X0201 csHalfWidthKatakana }
9174 { KSC5636 ISO646-KR csKSC5636 }
9175 { ISO-10646-UCS-2 csUnicode }
9176 { ISO-10646-UCS-4 csUCS4 }
9177 { DEC-MCS dec csDECMCS }
9178 { hp-roman8 roman8 r8 csHPRoman8 }
9179 { macintosh mac csMacintosh }
9180 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9181 csIBM037 }
9182 { IBM038 EBCDIC-INT cp038 csIBM038 }
9183 { IBM273 CP273 csIBM273 }
9184 { IBM274 EBCDIC-BE CP274 csIBM274 }
9185 { IBM275 EBCDIC-BR cp275 csIBM275 }
9186 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9187 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9188 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9189 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9190 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9191 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9192 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9193 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9194 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9195 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9196 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9197 { IBM437 cp437 437 csPC8CodePage437 }
9198 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9199 { IBM775 cp775 csPC775Baltic }
9200 { IBM850 cp850 850 csPC850Multilingual }
9201 { IBM851 cp851 851 csIBM851 }
9202 { IBM852 cp852 852 csPCp852 }
9203 { IBM855 cp855 855 csIBM855 }
9204 { IBM857 cp857 857 csIBM857 }
9205 { IBM860 cp860 860 csIBM860 }
9206 { IBM861 cp861 861 cp-is csIBM861 }
9207 { IBM862 cp862 862 csPC862LatinHebrew }
9208 { IBM863 cp863 863 csIBM863 }
9209 { IBM864 cp864 csIBM864 }
9210 { IBM865 cp865 865 csIBM865 }
9211 { IBM866 cp866 866 csIBM866 }
9212 { IBM868 CP868 cp-ar csIBM868 }
9213 { IBM869 cp869 869 cp-gr csIBM869 }
9214 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9215 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9216 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9217 { IBM891 cp891 csIBM891 }
9218 { IBM903 cp903 csIBM903 }
9219 { IBM904 cp904 904 csIBBM904 }
9220 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9221 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9222 { IBM1026 CP1026 csIBM1026 }
9223 { EBCDIC-AT-DE csIBMEBCDICATDE }
9224 { EBCDIC-AT-DE-A csEBCDICATDEA }
9225 { EBCDIC-CA-FR csEBCDICCAFR }
9226 { EBCDIC-DK-NO csEBCDICDKNO }
9227 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9228 { EBCDIC-FI-SE csEBCDICFISE }
9229 { EBCDIC-FI-SE-A csEBCDICFISEA }
9230 { EBCDIC-FR csEBCDICFR }
9231 { EBCDIC-IT csEBCDICIT }
9232 { EBCDIC-PT csEBCDICPT }
9233 { EBCDIC-ES csEBCDICES }
9234 { EBCDIC-ES-A csEBCDICESA }
9235 { EBCDIC-ES-S csEBCDICESS }
9236 { EBCDIC-UK csEBCDICUK }
9237 { EBCDIC-US csEBCDICUS }
9238 { UNKNOWN-8BIT csUnknown8BiT }
9239 { MNEMONIC csMnemonic }
9240 { MNEM csMnem }
9241 { VISCII csVISCII }
9242 { VIQR csVIQR }
9243 { KOI8-R csKOI8R }
9244 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9245 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9246 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9247 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9248 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9249 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9250 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9251 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9252 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9253 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9254 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9255 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9256 { IBM1047 IBM-1047 }
9257 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9258 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9259 { UNICODE-1-1 csUnicode11 }
9260 { CESU-8 csCESU-8 }
9261 { BOCU-1 csBOCU-1 }
9262 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9263 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9264 l8 }
9265 { ISO-8859-15 ISO_8859-15 Latin-9 }
9266 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9267 { GBK CP936 MS936 windows-936 }
9268 { JIS_Encoding csJISEncoding }
9269 { Shift_JIS MS_Kanji csShiftJIS }
9270 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9271 EUC-JP }
9272 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9273 { ISO-10646-UCS-Basic csUnicodeASCII }
9274 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9275 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9276 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9277 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9278 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9279 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9280 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9281 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9282 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9283 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9284 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9285 { Ventura-US csVenturaUS }
9286 { Ventura-International csVenturaInternational }
9287 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9288 { PC8-Turkish csPC8Turkish }
9289 { IBM-Symbols csIBMSymbols }
9290 { IBM-Thai csIBMThai }
9291 { HP-Legal csHPLegal }
9292 { HP-Pi-font csHPPiFont }
9293 { HP-Math8 csHPMath8 }
9294 { Adobe-Symbol-Encoding csHPPSMath }
9295 { HP-DeskTop csHPDesktop }
9296 { Ventura-Math csVenturaMath }
9297 { Microsoft-Publishing csMicrosoftPublishing }
9298 { Windows-31J csWindows31J }
9299 { GB2312 csGB2312 }
9300 { Big5 csBig5 }
9303 proc tcl_encoding {enc} {
9304 global encoding_aliases
9305 set names [encoding names]
9306 set lcnames [string tolower $names]
9307 set enc [string tolower $enc]
9308 set i [lsearch -exact $lcnames $enc]
9309 if {$i < 0} {
9310 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9311 if {[regsub {^iso[-_]} $enc iso encx]} {
9312 set i [lsearch -exact $lcnames $encx]
9315 if {$i < 0} {
9316 foreach l $encoding_aliases {
9317 set ll [string tolower $l]
9318 if {[lsearch -exact $ll $enc] < 0} continue
9319 # look through the aliases for one that tcl knows about
9320 foreach e $ll {
9321 set i [lsearch -exact $lcnames $e]
9322 if {$i < 0} {
9323 if {[regsub {^iso[-_]} $e iso ex]} {
9324 set i [lsearch -exact $lcnames $ex]
9327 if {$i >= 0} break
9329 break
9332 if {$i >= 0} {
9333 return [lindex $names $i]
9335 return {}
9338 # First check that Tcl/Tk is recent enough
9339 if {[catch {package require Tk 8.4} err]} {
9340 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9341 Gitk requires at least Tcl/Tk 8.4."]
9342 exit 1
9345 # defaults...
9346 set wrcomcmd "git diff-tree --stdin -p --pretty"
9348 set gitencoding {}
9349 catch {
9350 set gitencoding [exec git config --get i18n.commitencoding]
9352 if {$gitencoding == ""} {
9353 set gitencoding "utf-8"
9355 set tclencoding [tcl_encoding $gitencoding]
9356 if {$tclencoding == {}} {
9357 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9360 set mainfont {Helvetica 9}
9361 set textfont {Courier 9}
9362 set uifont {Helvetica 9 bold}
9363 set tabstop 8
9364 set findmergefiles 0
9365 set maxgraphpct 50
9366 set maxwidth 16
9367 set revlistorder 0
9368 set fastdate 0
9369 set uparrowlen 5
9370 set downarrowlen 5
9371 set mingaplen 100
9372 set cmitmode "patch"
9373 set wrapcomment "none"
9374 set showneartags 1
9375 set maxrefs 20
9376 set maxlinelen 200
9377 set showlocalchanges 1
9378 set limitdiffs 1
9379 set datetimeformat "%Y-%m-%d %H:%M:%S"
9380 set autoselect 1
9382 set colors {green red blue magenta darkgrey brown orange}
9383 set bgcolor white
9384 set fgcolor black
9385 set diffcolors {red "#00a000" blue}
9386 set diffcontext 3
9387 set ignorespace 0
9388 set selectbgcolor gray85
9390 ## For msgcat loading, first locate the installation location.
9391 if { [info exists ::env(GITK_MSGSDIR)] } {
9392 ## Msgsdir was manually set in the environment.
9393 set gitk_msgsdir $::env(GITK_MSGSDIR)
9394 } else {
9395 ## Let's guess the prefix from argv0.
9396 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9397 set gitk_libdir [file join $gitk_prefix share gitk lib]
9398 set gitk_msgsdir [file join $gitk_libdir msgs]
9399 unset gitk_prefix
9402 ## Internationalization (i18n) through msgcat and gettext. See
9403 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9404 package require msgcat
9405 namespace import ::msgcat::mc
9406 ## And eventually load the actual message catalog
9407 ::msgcat::mcload $gitk_msgsdir
9409 catch {source ~/.gitk}
9411 font create optionfont -family sans-serif -size -12
9413 parsefont mainfont $mainfont
9414 eval font create mainfont [fontflags mainfont]
9415 eval font create mainfontbold [fontflags mainfont 1]
9417 parsefont textfont $textfont
9418 eval font create textfont [fontflags textfont]
9419 eval font create textfontbold [fontflags textfont 1]
9421 parsefont uifont $uifont
9422 eval font create uifont [fontflags uifont]
9424 setoptions
9426 # check that we can find a .git directory somewhere...
9427 if {[catch {set gitdir [gitdir]}]} {
9428 show_error {} . [mc "Cannot find a git repository here."]
9429 exit 1
9431 if {![file isdirectory $gitdir]} {
9432 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9433 exit 1
9436 set revtreeargs {}
9437 set cmdline_files {}
9438 set i 0
9439 set revtreeargscmd {}
9440 foreach arg $argv {
9441 switch -glob -- $arg {
9442 "" { }
9443 "--" {
9444 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9445 break
9447 "--argscmd=*" {
9448 set revtreeargscmd [string range $arg 10 end]
9450 default {
9451 lappend revtreeargs $arg
9454 incr i
9457 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9458 # no -- on command line, but some arguments (other than --argscmd)
9459 if {[catch {
9460 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9461 set cmdline_files [split $f "\n"]
9462 set n [llength $cmdline_files]
9463 set revtreeargs [lrange $revtreeargs 0 end-$n]
9464 # Unfortunately git rev-parse doesn't produce an error when
9465 # something is both a revision and a filename. To be consistent
9466 # with git log and git rev-list, check revtreeargs for filenames.
9467 foreach arg $revtreeargs {
9468 if {[file exists $arg]} {
9469 show_error {} . [mc "Ambiguous argument '%s': both revision\
9470 and filename" $arg]
9471 exit 1
9474 } err]} {
9475 # unfortunately we get both stdout and stderr in $err,
9476 # so look for "fatal:".
9477 set i [string first "fatal:" $err]
9478 if {$i > 0} {
9479 set err [string range $err [expr {$i + 6}] end]
9481 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9482 exit 1
9486 set nullid "0000000000000000000000000000000000000000"
9487 set nullid2 "0000000000000000000000000000000000000001"
9489 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9491 set runq {}
9492 set history {}
9493 set historyindex 0
9494 set fh_serial 0
9495 set nhl_names {}
9496 set highlight_paths {}
9497 set findpattern {}
9498 set searchdirn -forwards
9499 set boldrows {}
9500 set boldnamerows {}
9501 set diffelide {0 0}
9502 set markingmatches 0
9503 set linkentercount 0
9504 set need_redisplay 0
9505 set nrows_drawn 0
9506 set firsttabstop 0
9508 set nextviewnum 1
9509 set curview 0
9510 set selectedview 0
9511 set selectedhlview [mc "None"]
9512 set highlight_related [mc "None"]
9513 set highlight_files {}
9514 set viewfiles(0) {}
9515 set viewperm(0) 0
9516 set viewargs(0) {}
9517 set viewargscmd(0) {}
9519 set loginstance 0
9520 set cmdlineok 0
9521 set stopped 0
9522 set stuffsaved 0
9523 set patchnum 0
9524 set lserial 0
9525 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9526 setcoords
9527 makewindow
9528 # wait for the window to become visible
9529 tkwait visibility .
9530 wm title . "[file tail $argv0]: [file tail [pwd]]"
9531 readrefs
9533 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9534 # create a view for the files/dirs specified on the command line
9535 set curview 1
9536 set selectedview 1
9537 set nextviewnum 2
9538 set viewname(1) [mc "Command line"]
9539 set viewfiles(1) $cmdline_files
9540 set viewargs(1) $revtreeargs
9541 set viewargscmd(1) $revtreeargscmd
9542 set viewperm(1) 0
9543 set vdatemode(1) 0
9544 addviewmenu 1
9545 .bar.view entryconf [mc "Edit view..."] -state normal
9546 .bar.view entryconf [mc "Delete view"] -state normal
9549 if {[info exists permviews]} {
9550 foreach v $permviews {
9551 set n $nextviewnum
9552 incr nextviewnum
9553 set viewname($n) [lindex $v 0]
9554 set viewfiles($n) [lindex $v 1]
9555 set viewargs($n) [lindex $v 2]
9556 set viewargscmd($n) [lindex $v 3]
9557 set viewperm($n) 1
9558 addviewmenu $n
9561 getcommits