Skip more symbolic link tests.
[git/mingw.git] / gitk-git / gitk
blobf06461805ceea33148aa29c6fbffa7cf4b039080
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 dorunq {} {
51 global isonrunq runq
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
76 if {$runq ne {}} {
77 after idle dorunq
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewargscmd viewfiles commitidx viewcomplete vnextroot
86 global showlocalchanges commitinterest mainheadid
87 global progressdirn progresscoords proglastnc curview
89 set startmsecs [clock clicks -milliseconds]
90 set commitidx($view) 0
91 set viewcomplete($view) 0
92 set vnextroot($view) 0
93 set args $viewargs($view)
94 if {$viewargscmd($view) ne {}} {
95 if {[catch {
96 set str [exec sh -c $viewargscmd($view)]
97 } err]} {
98 error_popup "Error executing --argscmd command: $err"
99 exit 1
101 set args [concat $args [split $str "\n"]]
103 set order "--topo-order"
104 if {$datemode} {
105 set order "--date-order"
107 if {[catch {
108 set fd [open [concat | git log --no-color -z --pretty=raw $order --parents \
109 --boundary $args "--" $viewfiles($view)] r]
110 } err]} {
111 error_popup "[mc "Error executing git rev-list:"] $err"
112 exit 1
114 set commfd($view) $fd
115 set leftover($view) {}
116 if {$showlocalchanges} {
117 lappend commitinterest($mainheadid) {dodiffindex}
119 fconfigure $fd -blocking 0 -translation lf -eofchar {}
120 if {$tclencoding != {}} {
121 fconfigure $fd -encoding $tclencoding
123 filerun $fd [list getcommitlines $fd $view]
124 nowbusy $view [mc "Reading"]
125 if {$view == $curview} {
126 set progressdirn 1
127 set progresscoords {0 0}
128 set proglastnc 0
132 proc stop_rev_list {} {
133 global commfd curview
135 if {![info exists commfd($curview)]} return
136 set fd $commfd($curview)
137 catch {
138 set pid [pid $fd]
139 exec kill $pid
141 catch {close $fd}
142 unset commfd($curview)
145 proc getcommits {} {
146 global phase canv curview
148 set phase getcommits
149 initlayout
150 start_rev_list $curview
151 show_status [mc "Reading commits..."]
154 # This makes a string representation of a positive integer which
155 # sorts as a string in numerical order
156 proc strrep {n} {
157 if {$n < 16} {
158 return [format "%x" $n]
159 } elseif {$n < 256} {
160 return [format "x%.2x" $n]
161 } elseif {$n < 65536} {
162 return [format "y%.4x" $n]
164 return [format "z%.8x" $n]
167 proc getcommitlines {fd view} {
168 global commitlisted commitinterest
169 global leftover commfd
170 global displayorder commitidx viewcomplete commitrow commitdata
171 global parentlist children curview hlview
172 global vparentlist vdisporder vcmitlisted
173 global ordertok vnextroot idpending
175 set stuff [read $fd 500000]
176 # git log doesn't terminate the last commit with a null...
177 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
178 set stuff "\0"
180 if {$stuff == {}} {
181 if {![eof $fd]} {
182 return 1
184 # Check if we have seen any ids listed as parents that haven't
185 # appeared in the list
186 foreach vid [array names idpending "$view,*"] {
187 # should only get here if git log is buggy
188 set id [lindex [split $vid ","] 1]
189 set commitrow($vid) $commitidx($view)
190 incr commitidx($view)
191 if {$view == $curview} {
192 lappend parentlist {}
193 lappend displayorder $id
194 lappend commitlisted 0
195 } else {
196 lappend vparentlist($view) {}
197 lappend vdisporder($view) $id
198 lappend vcmitlisted($view) 0
201 set viewcomplete($view) 1
202 global viewname progresscoords
203 unset commfd($view)
204 notbusy $view
205 set progresscoords {0 0}
206 adjustprogress
207 # set it blocking so we wait for the process to terminate
208 fconfigure $fd -blocking 1
209 if {[catch {close $fd} err]} {
210 set fv {}
211 if {$view != $curview} {
212 set fv " for the \"$viewname($view)\" view"
214 if {[string range $err 0 4] == "usage"} {
215 set err "Gitk: error reading commits$fv:\
216 bad arguments to git rev-list."
217 if {$viewname($view) eq "Command line"} {
218 append err \
219 " (Note: arguments to gitk are passed to git rev-list\
220 to allow selection of commits to be displayed.)"
222 } else {
223 set err "Error reading commits$fv: $err"
225 error_popup $err
227 if {$view == $curview} {
228 run chewcommits $view
230 return 0
232 set start 0
233 set gotsome 0
234 while 1 {
235 set i [string first "\0" $stuff $start]
236 if {$i < 0} {
237 append leftover($view) [string range $stuff $start end]
238 break
240 if {$start == 0} {
241 set cmit $leftover($view)
242 append cmit [string range $stuff 0 [expr {$i - 1}]]
243 set leftover($view) {}
244 } else {
245 set cmit [string range $stuff $start [expr {$i - 1}]]
247 set start [expr {$i + 1}]
248 set j [string first "\n" $cmit]
249 set ok 0
250 set listed 1
251 if {$j >= 0 && [string match "commit *" $cmit]} {
252 set ids [string range $cmit 7 [expr {$j - 1}]]
253 if {[string match {[-^<>]*} $ids]} {
254 switch -- [string index $ids 0] {
255 "-" {set listed 0}
256 "^" {set listed 2}
257 "<" {set listed 3}
258 ">" {set listed 4}
260 set ids [string range $ids 1 end]
262 set ok 1
263 foreach id $ids {
264 if {[string length $id] != 40} {
265 set ok 0
266 break
270 if {!$ok} {
271 set shortcmit $cmit
272 if {[string length $shortcmit] > 80} {
273 set shortcmit "[string range $shortcmit 0 80]..."
275 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
276 exit 1
278 set id [lindex $ids 0]
279 if {![info exists ordertok($view,$id)]} {
280 set otok "o[strrep $vnextroot($view)]"
281 incr vnextroot($view)
282 set ordertok($view,$id) $otok
283 } else {
284 set otok $ordertok($view,$id)
285 unset idpending($view,$id)
287 if {$listed} {
288 set olds [lrange $ids 1 end]
289 if {[llength $olds] == 1} {
290 set p [lindex $olds 0]
291 lappend children($view,$p) $id
292 if {![info exists ordertok($view,$p)]} {
293 set ordertok($view,$p) $ordertok($view,$id)
294 set idpending($view,$p) 1
296 } else {
297 set i 0
298 foreach p $olds {
299 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
300 lappend children($view,$p) $id
302 if {![info exists ordertok($view,$p)]} {
303 set ordertok($view,$p) "$otok[strrep $i]]"
304 set idpending($view,$p) 1
306 incr i
309 } else {
310 set olds {}
312 if {![info exists children($view,$id)]} {
313 set children($view,$id) {}
315 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
316 set commitrow($view,$id) $commitidx($view)
317 incr commitidx($view)
318 if {$view == $curview} {
319 lappend parentlist $olds
320 lappend displayorder $id
321 lappend commitlisted $listed
322 } else {
323 lappend vparentlist($view) $olds
324 lappend vdisporder($view) $id
325 lappend vcmitlisted($view) $listed
327 if {[info exists commitinterest($id)]} {
328 foreach script $commitinterest($id) {
329 eval [string map [list "%I" $id] $script]
331 unset commitinterest($id)
333 set gotsome 1
335 if {$gotsome} {
336 run chewcommits $view
337 if {$view == $curview} {
338 # update progress bar
339 global progressdirn progresscoords proglastnc
340 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
341 set proglastnc $commitidx($view)
342 set l [lindex $progresscoords 0]
343 set r [lindex $progresscoords 1]
344 if {$progressdirn} {
345 set r [expr {$r + $inc}]
346 if {$r >= 1.0} {
347 set r 1.0
348 set progressdirn 0
350 if {$r > 0.2} {
351 set l [expr {$r - 0.2}]
353 } else {
354 set l [expr {$l - $inc}]
355 if {$l <= 0.0} {
356 set l 0.0
357 set progressdirn 1
359 set r [expr {$l + 0.2}]
361 set progresscoords [list $l $r]
362 adjustprogress
365 return 2
368 proc chewcommits {view} {
369 global curview hlview viewcomplete
370 global selectedline pending_select
372 if {$view == $curview} {
373 layoutmore
374 if {$viewcomplete($view)} {
375 global displayorder commitidx phase
376 global numcommits startmsecs
378 if {[info exists pending_select]} {
379 set row [first_real_row]
380 selectline $row 1
382 if {$commitidx($curview) > 0} {
383 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
384 #puts "overall $ms ms for $numcommits commits"
385 } else {
386 show_status [mc "No commits selected"]
388 notbusy layout
389 set phase {}
392 if {[info exists hlview] && $view == $hlview} {
393 vhighlightmore
395 return 0
398 proc readcommit {id} {
399 if {[catch {set contents [exec git cat-file commit $id]}]} return
400 parsecommit $id $contents 0
403 proc updatecommits {} {
404 global viewdata curview phase displayorder ordertok idpending
405 global children commitrow selectedline thickerline showneartags
406 global isworktree
408 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
410 if {$phase ne {}} {
411 stop_rev_list
412 set phase {}
414 set n $curview
415 foreach id $displayorder {
416 catch {unset children($n,$id)}
417 catch {unset commitrow($n,$id)}
418 catch {unset ordertok($n,$id)}
420 foreach vid [array names idpending "$n,*"] {
421 unset idpending($vid)
423 set curview -1
424 catch {unset selectedline}
425 catch {unset thickerline}
426 catch {unset viewdata($n)}
427 readrefs
428 changedrefs
429 if {$showneartags} {
430 getallcommits
432 showview $n
435 proc parsecommit {id contents listed} {
436 global commitinfo cdate
438 set inhdr 1
439 set comment {}
440 set headline {}
441 set auname {}
442 set audate {}
443 set comname {}
444 set comdate {}
445 set hdrend [string first "\n\n" $contents]
446 if {$hdrend < 0} {
447 # should never happen...
448 set hdrend [string length $contents]
450 set header [string range $contents 0 [expr {$hdrend - 1}]]
451 set comment [string range $contents [expr {$hdrend + 2}] end]
452 foreach line [split $header "\n"] {
453 set tag [lindex $line 0]
454 if {$tag == "author"} {
455 set audate [lindex $line end-1]
456 set auname [lrange $line 1 end-2]
457 } elseif {$tag == "committer"} {
458 set comdate [lindex $line end-1]
459 set comname [lrange $line 1 end-2]
462 set headline {}
463 # take the first non-blank line of the comment as the headline
464 set headline [string trimleft $comment]
465 set i [string first "\n" $headline]
466 if {$i >= 0} {
467 set headline [string range $headline 0 $i]
469 set headline [string trimright $headline]
470 set i [string first "\r" $headline]
471 if {$i >= 0} {
472 set headline [string trimright [string range $headline 0 $i]]
474 if {!$listed} {
475 # git rev-list indents the comment by 4 spaces;
476 # if we got this via git cat-file, add the indentation
477 set newcomment {}
478 foreach line [split $comment "\n"] {
479 append newcomment " "
480 append newcomment $line
481 append newcomment "\n"
483 set comment $newcomment
485 if {$comdate != {}} {
486 set cdate($id) $comdate
488 set commitinfo($id) [list $headline $auname $audate \
489 $comname $comdate $comment]
492 proc getcommit {id} {
493 global commitdata commitinfo
495 if {[info exists commitdata($id)]} {
496 parsecommit $id $commitdata($id) 1
497 } else {
498 readcommit $id
499 if {![info exists commitinfo($id)]} {
500 set commitinfo($id) [list [mc "No commit information available"]]
503 return 1
506 proc readrefs {} {
507 global tagids idtags headids idheads tagobjid
508 global otherrefids idotherrefs mainhead mainheadid
510 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
511 catch {unset $v}
513 set refd [open [list | git show-ref -d] r]
514 while {[gets $refd line] >= 0} {
515 if {[string index $line 40] ne " "} continue
516 set id [string range $line 0 39]
517 set ref [string range $line 41 end]
518 if {![string match "refs/*" $ref]} continue
519 set name [string range $ref 5 end]
520 if {[string match "remotes/*" $name]} {
521 if {![string match "*/HEAD" $name]} {
522 set headids($name) $id
523 lappend idheads($id) $name
525 } elseif {[string match "heads/*" $name]} {
526 set name [string range $name 6 end]
527 set headids($name) $id
528 lappend idheads($id) $name
529 } elseif {[string match "tags/*" $name]} {
530 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
531 # which is what we want since the former is the commit ID
532 set name [string range $name 5 end]
533 if {[string match "*^{}" $name]} {
534 set name [string range $name 0 end-3]
535 } else {
536 set tagobjid($name) $id
538 set tagids($name) $id
539 lappend idtags($id) $name
540 } else {
541 set otherrefids($name) $id
542 lappend idotherrefs($id) $name
545 catch {close $refd}
546 set mainhead {}
547 set mainheadid {}
548 catch {
549 set thehead [exec git symbolic-ref HEAD]
550 if {[string match "refs/heads/*" $thehead]} {
551 set mainhead [string range $thehead 11 end]
552 if {[info exists headids($mainhead)]} {
553 set mainheadid $headids($mainhead)
559 # skip over fake commits
560 proc first_real_row {} {
561 global nullid nullid2 displayorder numcommits
563 for {set row 0} {$row < $numcommits} {incr row} {
564 set id [lindex $displayorder $row]
565 if {$id ne $nullid && $id ne $nullid2} {
566 break
569 return $row
572 # update things for a head moved to a child of its previous location
573 proc movehead {id name} {
574 global headids idheads
576 removehead $headids($name) $name
577 set headids($name) $id
578 lappend idheads($id) $name
581 # update things when a head has been removed
582 proc removehead {id name} {
583 global headids idheads
585 if {$idheads($id) eq $name} {
586 unset idheads($id)
587 } else {
588 set i [lsearch -exact $idheads($id) $name]
589 if {$i >= 0} {
590 set idheads($id) [lreplace $idheads($id) $i $i]
593 unset headids($name)
596 proc show_error {w top msg} {
597 message $w.m -text $msg -justify center -aspect 400
598 pack $w.m -side top -fill x -padx 20 -pady 20
599 button $w.ok -text [mc OK] -command "destroy $top"
600 pack $w.ok -side bottom -fill x
601 bind $top <Visibility> "grab $top; focus $top"
602 bind $top <Key-Return> "destroy $top"
603 tkwait window $top
606 proc error_popup msg {
607 set w .error
608 toplevel $w
609 wm transient $w .
610 show_error $w $w $msg
613 proc confirm_popup msg {
614 global confirm_ok
615 set confirm_ok 0
616 set w .confirm
617 toplevel $w
618 wm transient $w .
619 message $w.m -text $msg -justify center -aspect 400
620 pack $w.m -side top -fill x -padx 20 -pady 20
621 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
622 pack $w.ok -side left -fill x
623 button $w.cancel -text [mc Cancel] -command "destroy $w"
624 pack $w.cancel -side right -fill x
625 bind $w <Visibility> "grab $w; focus $w"
626 tkwait window $w
627 return $confirm_ok
630 proc setoptions {} {
631 option add *Panedwindow.showHandle 1 startupFile
632 option add *Panedwindow.sashRelief raised startupFile
633 option add *Button.font uifont startupFile
634 option add *Checkbutton.font uifont startupFile
635 option add *Radiobutton.font uifont startupFile
636 option add *Menu.font uifont startupFile
637 option add *Menubutton.font uifont startupFile
638 option add *Label.font uifont startupFile
639 option add *Message.font uifont startupFile
640 option add *Entry.font uifont startupFile
643 proc makewindow {} {
644 global canv canv2 canv3 linespc charspc ctext cflist
645 global tabstop
646 global findtype findtypemenu findloc findstring fstring geometry
647 global entries sha1entry sha1string sha1but
648 global diffcontextstring diffcontext
649 global ignorespace
650 global maincursor textcursor curtextcursor
651 global rowctxmenu fakerowmenu mergemax wrapcomment
652 global highlight_files gdttype
653 global searchstring sstring
654 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
655 global headctxmenu progresscanv progressitem progresscoords statusw
656 global fprogitem fprogcoord lastprogupdate progupdatepending
657 global rprogitem rprogcoord
658 global have_tk85
660 menu .bar
661 .bar add cascade -label [mc "File"] -menu .bar.file
662 menu .bar.file
663 .bar.file add command -label [mc "Update"] -command updatecommits
664 .bar.file add command -label [mc "Reread references"] -command rereadrefs
665 .bar.file add command -label [mc "List references"] -command showrefs
666 .bar.file add command -label [mc "Quit"] -command doquit
667 menu .bar.edit
668 .bar add cascade -label [mc "Edit"] -menu .bar.edit
669 .bar.edit add command -label [mc "Preferences"] -command doprefs
671 menu .bar.view
672 .bar add cascade -label [mc "View"] -menu .bar.view
673 .bar.view add command -label [mc "New view..."] -command {newview 0}
674 .bar.view add command -label [mc "Edit view..."] -command editview \
675 -state disabled
676 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
677 .bar.view add separator
678 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
679 -variable selectedview -value 0
681 menu .bar.help
682 .bar add cascade -label [mc "Help"] -menu .bar.help
683 .bar.help add command -label [mc "About gitk"] -command about
684 .bar.help add command -label [mc "Key bindings"] -command keys
685 .bar.help configure
686 . configure -menu .bar
688 # the gui has upper and lower half, parts of a paned window.
689 panedwindow .ctop -orient vertical
691 # possibly use assumed geometry
692 if {![info exists geometry(pwsash0)]} {
693 set geometry(topheight) [expr {15 * $linespc}]
694 set geometry(topwidth) [expr {80 * $charspc}]
695 set geometry(botheight) [expr {15 * $linespc}]
696 set geometry(botwidth) [expr {50 * $charspc}]
697 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
698 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
701 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
702 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
703 frame .tf.histframe
704 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
706 # create three canvases
707 set cscroll .tf.histframe.csb
708 set canv .tf.histframe.pwclist.canv
709 canvas $canv \
710 -selectbackground $selectbgcolor \
711 -background $bgcolor -bd 0 \
712 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
713 .tf.histframe.pwclist add $canv
714 set canv2 .tf.histframe.pwclist.canv2
715 canvas $canv2 \
716 -selectbackground $selectbgcolor \
717 -background $bgcolor -bd 0 -yscrollincr $linespc
718 .tf.histframe.pwclist add $canv2
719 set canv3 .tf.histframe.pwclist.canv3
720 canvas $canv3 \
721 -selectbackground $selectbgcolor \
722 -background $bgcolor -bd 0 -yscrollincr $linespc
723 .tf.histframe.pwclist add $canv3
724 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
725 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
727 # a scroll bar to rule them
728 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
729 pack $cscroll -side right -fill y
730 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
731 lappend bglist $canv $canv2 $canv3
732 pack .tf.histframe.pwclist -fill both -expand 1 -side left
734 # we have two button bars at bottom of top frame. Bar 1
735 frame .tf.bar
736 frame .tf.lbar -height 15
738 set sha1entry .tf.bar.sha1
739 set entries $sha1entry
740 set sha1but .tf.bar.sha1label
741 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
742 -command gotocommit -width 8
743 $sha1but conf -disabledforeground [$sha1but cget -foreground]
744 pack .tf.bar.sha1label -side left
745 entry $sha1entry -width 40 -font textfont -textvariable sha1string
746 trace add variable sha1string write sha1change
747 pack $sha1entry -side left -pady 2
749 image create bitmap bm-left -data {
750 #define left_width 16
751 #define left_height 16
752 static unsigned char left_bits[] = {
753 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
754 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
755 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
757 image create bitmap bm-right -data {
758 #define right_width 16
759 #define right_height 16
760 static unsigned char right_bits[] = {
761 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
762 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
763 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
765 button .tf.bar.leftbut -image bm-left -command goback \
766 -state disabled -width 26
767 pack .tf.bar.leftbut -side left -fill y
768 button .tf.bar.rightbut -image bm-right -command goforw \
769 -state disabled -width 26
770 pack .tf.bar.rightbut -side left -fill y
772 # Status label and progress bar
773 set statusw .tf.bar.status
774 label $statusw -width 15 -relief sunken
775 pack $statusw -side left -padx 5
776 set h [expr {[font metrics uifont -linespace] + 2}]
777 set progresscanv .tf.bar.progress
778 canvas $progresscanv -relief sunken -height $h -borderwidth 2
779 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
780 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
781 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
782 pack $progresscanv -side right -expand 1 -fill x
783 set progresscoords {0 0}
784 set fprogcoord 0
785 set rprogcoord 0
786 bind $progresscanv <Configure> adjustprogress
787 set lastprogupdate [clock clicks -milliseconds]
788 set progupdatepending 0
790 # build up the bottom bar of upper window
791 label .tf.lbar.flabel -text "[mc "Find"] "
792 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
793 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
794 label .tf.lbar.flab2 -text " [mc "commit"] "
795 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
796 -side left -fill y
797 set gdttype [mc "containing:"]
798 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
799 [mc "containing:"] \
800 [mc "touching paths:"] \
801 [mc "adding/removing string:"]]
802 trace add variable gdttype write gdttype_change
803 pack .tf.lbar.gdttype -side left -fill y
805 set findstring {}
806 set fstring .tf.lbar.findstring
807 lappend entries $fstring
808 entry $fstring -width 30 -font textfont -textvariable findstring
809 trace add variable findstring write find_change
810 set findtype [mc "Exact"]
811 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
812 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
813 trace add variable findtype write findcom_change
814 set findloc [mc "All fields"]
815 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
816 [mc "Comments"] [mc "Author"] [mc "Committer"]
817 trace add variable findloc write find_change
818 pack .tf.lbar.findloc -side right
819 pack .tf.lbar.findtype -side right
820 pack $fstring -side left -expand 1 -fill x
822 # Finish putting the upper half of the viewer together
823 pack .tf.lbar -in .tf -side bottom -fill x
824 pack .tf.bar -in .tf -side bottom -fill x
825 pack .tf.histframe -fill both -side top -expand 1
826 .ctop add .tf
827 .ctop paneconfigure .tf -height $geometry(topheight)
828 .ctop paneconfigure .tf -width $geometry(topwidth)
830 # now build up the bottom
831 panedwindow .pwbottom -orient horizontal
833 # lower left, a text box over search bar, scroll bar to the right
834 # if we know window height, then that will set the lower text height, otherwise
835 # we set lower text height which will drive window height
836 if {[info exists geometry(main)]} {
837 frame .bleft -width $geometry(botwidth)
838 } else {
839 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
841 frame .bleft.top
842 frame .bleft.mid
843 frame .bleft.bottom
845 button .bleft.top.search -text [mc "Search"] -command dosearch
846 pack .bleft.top.search -side left -padx 5
847 set sstring .bleft.top.sstring
848 entry $sstring -width 20 -font textfont -textvariable searchstring
849 lappend entries $sstring
850 trace add variable searchstring write incrsearch
851 pack $sstring -side left -expand 1 -fill x
852 radiobutton .bleft.mid.diff -text [mc "Diff"] \
853 -command changediffdisp -variable diffelide -value {0 0}
854 radiobutton .bleft.mid.old -text [mc "Old version"] \
855 -command changediffdisp -variable diffelide -value {0 1}
856 radiobutton .bleft.mid.new -text [mc "New version"] \
857 -command changediffdisp -variable diffelide -value {1 0}
858 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
859 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
860 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
861 -from 1 -increment 1 -to 10000000 \
862 -validate all -validatecommand "diffcontextvalidate %P" \
863 -textvariable diffcontextstring
864 .bleft.mid.diffcontext set $diffcontext
865 trace add variable diffcontextstring write diffcontextchange
866 lappend entries .bleft.mid.diffcontext
867 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
868 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
869 -command changeignorespace -variable ignorespace
870 pack .bleft.mid.ignspace -side left -padx 5
871 set ctext .bleft.bottom.ctext
872 text $ctext -background $bgcolor -foreground $fgcolor \
873 -state disabled -font textfont \
874 -yscrollcommand scrolltext -wrap none \
875 -xscrollcommand ".bleft.bottom.sbhorizontal set"
876 if {$have_tk85} {
877 $ctext conf -tabstyle wordprocessor
879 scrollbar .bleft.bottom.sb -command "$ctext yview"
880 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
881 -width 10
882 pack .bleft.top -side top -fill x
883 pack .bleft.mid -side top -fill x
884 grid $ctext .bleft.bottom.sb -sticky nsew
885 grid .bleft.bottom.sbhorizontal -sticky ew
886 grid columnconfigure .bleft.bottom 0 -weight 1
887 grid rowconfigure .bleft.bottom 0 -weight 1
888 grid rowconfigure .bleft.bottom 1 -weight 0
889 pack .bleft.bottom -side top -fill both -expand 1
890 lappend bglist $ctext
891 lappend fglist $ctext
893 $ctext tag conf comment -wrap $wrapcomment
894 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
895 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
896 $ctext tag conf d0 -fore [lindex $diffcolors 0]
897 $ctext tag conf d1 -fore [lindex $diffcolors 1]
898 $ctext tag conf m0 -fore red
899 $ctext tag conf m1 -fore blue
900 $ctext tag conf m2 -fore green
901 $ctext tag conf m3 -fore purple
902 $ctext tag conf m4 -fore brown
903 $ctext tag conf m5 -fore "#009090"
904 $ctext tag conf m6 -fore magenta
905 $ctext tag conf m7 -fore "#808000"
906 $ctext tag conf m8 -fore "#009000"
907 $ctext tag conf m9 -fore "#ff0080"
908 $ctext tag conf m10 -fore cyan
909 $ctext tag conf m11 -fore "#b07070"
910 $ctext tag conf m12 -fore "#70b0f0"
911 $ctext tag conf m13 -fore "#70f0b0"
912 $ctext tag conf m14 -fore "#f0b070"
913 $ctext tag conf m15 -fore "#ff70b0"
914 $ctext tag conf mmax -fore darkgrey
915 set mergemax 16
916 $ctext tag conf mresult -font textfontbold
917 $ctext tag conf msep -font textfontbold
918 $ctext tag conf found -back yellow
920 .pwbottom add .bleft
921 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
923 # lower right
924 frame .bright
925 frame .bright.mode
926 radiobutton .bright.mode.patch -text [mc "Patch"] \
927 -command reselectline -variable cmitmode -value "patch"
928 radiobutton .bright.mode.tree -text [mc "Tree"] \
929 -command reselectline -variable cmitmode -value "tree"
930 grid .bright.mode.patch .bright.mode.tree -sticky ew
931 pack .bright.mode -side top -fill x
932 set cflist .bright.cfiles
933 set indent [font measure mainfont "nn"]
934 text $cflist \
935 -selectbackground $selectbgcolor \
936 -background $bgcolor -foreground $fgcolor \
937 -font mainfont \
938 -tabs [list $indent [expr {2 * $indent}]] \
939 -yscrollcommand ".bright.sb set" \
940 -cursor [. cget -cursor] \
941 -spacing1 1 -spacing3 1
942 lappend bglist $cflist
943 lappend fglist $cflist
944 scrollbar .bright.sb -command "$cflist yview"
945 pack .bright.sb -side right -fill y
946 pack $cflist -side left -fill both -expand 1
947 $cflist tag configure highlight \
948 -background [$cflist cget -selectbackground]
949 $cflist tag configure bold -font mainfontbold
951 .pwbottom add .bright
952 .ctop add .pwbottom
954 # restore window width & height if known
955 if {[info exists geometry(main)]} {
956 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
957 if {$w > [winfo screenwidth .]} {
958 set w [winfo screenwidth .]
960 if {$h > [winfo screenheight .]} {
961 set h [winfo screenheight .]
963 wm geometry . "${w}x$h"
967 if {[tk windowingsystem] eq {aqua}} {
968 set M1B M1
969 } else {
970 set M1B Control
973 bind .pwbottom <Configure> {resizecdetpanes %W %w}
974 pack .ctop -fill both -expand 1
975 bindall <1> {selcanvline %W %x %y}
976 #bindall <B1-Motion> {selcanvline %W %x %y}
977 if {[tk windowingsystem] == "win32"} {
978 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
979 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
980 } else {
981 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
982 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
983 if {[tk windowingsystem] eq "aqua"} {
984 bindall <MouseWheel> {
985 set delta [expr {- (%D)}]
986 allcanvs yview scroll $delta units
990 bindall <2> "canvscan mark %W %x %y"
991 bindall <B2-Motion> "canvscan dragto %W %x %y"
992 bindkey <Home> selfirstline
993 bindkey <End> sellastline
994 bind . <Key-Up> "selnextline -1"
995 bind . <Key-Down> "selnextline 1"
996 bind . <Shift-Key-Up> "dofind -1 0"
997 bind . <Shift-Key-Down> "dofind 1 0"
998 bindkey <Key-Right> "goforw"
999 bindkey <Key-Left> "goback"
1000 bind . <Key-Prior> "selnextpage -1"
1001 bind . <Key-Next> "selnextpage 1"
1002 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1003 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1004 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1005 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1006 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1007 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1008 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1009 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1010 bindkey <Key-space> "$ctext yview scroll 1 pages"
1011 bindkey p "selnextline -1"
1012 bindkey n "selnextline 1"
1013 bindkey z "goback"
1014 bindkey x "goforw"
1015 bindkey i "selnextline -1"
1016 bindkey k "selnextline 1"
1017 bindkey j "goback"
1018 bindkey l "goforw"
1019 bindkey b "$ctext yview scroll -1 pages"
1020 bindkey d "$ctext yview scroll 18 units"
1021 bindkey u "$ctext yview scroll -18 units"
1022 bindkey / {dofind 1 1}
1023 bindkey <Key-Return> {dofind 1 1}
1024 bindkey ? {dofind -1 1}
1025 bindkey f nextfile
1026 bindkey <F5> updatecommits
1027 bind . <$M1B-q> doquit
1028 bind . <$M1B-f> {dofind 1 1}
1029 bind . <$M1B-g> {dofind 1 0}
1030 bind . <$M1B-r> dosearchback
1031 bind . <$M1B-s> dosearch
1032 bind . <$M1B-equal> {incrfont 1}
1033 bind . <$M1B-plus> {incrfont 1}
1034 bind . <$M1B-KP_Add> {incrfont 1}
1035 bind . <$M1B-minus> {incrfont -1}
1036 bind . <$M1B-KP_Subtract> {incrfont -1}
1037 wm protocol . WM_DELETE_WINDOW doquit
1038 bind . <Button-1> "click %W"
1039 bind $fstring <Key-Return> {dofind 1 1}
1040 bind $sha1entry <Key-Return> gotocommit
1041 bind $sha1entry <<PasteSelection>> clearsha1
1042 bind $cflist <1> {sel_flist %W %x %y; break}
1043 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1044 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1045 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1047 set maincursor [. cget -cursor]
1048 set textcursor [$ctext cget -cursor]
1049 set curtextcursor $textcursor
1051 set rowctxmenu .rowctxmenu
1052 menu $rowctxmenu -tearoff 0
1053 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1054 -command {diffvssel 0}
1055 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1056 -command {diffvssel 1}
1057 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1058 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1059 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1060 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1061 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1062 -command cherrypick
1063 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1064 -command resethead
1066 set fakerowmenu .fakerowmenu
1067 menu $fakerowmenu -tearoff 0
1068 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1069 -command {diffvssel 0}
1070 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1071 -command {diffvssel 1}
1072 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1073 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1074 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1075 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1077 set headctxmenu .headctxmenu
1078 menu $headctxmenu -tearoff 0
1079 $headctxmenu add command -label [mc "Check out this branch"] \
1080 -command cobranch
1081 $headctxmenu add command -label [mc "Remove this branch"] \
1082 -command rmbranch
1084 global flist_menu
1085 set flist_menu .flistctxmenu
1086 menu $flist_menu -tearoff 0
1087 $flist_menu add command -label [mc "Highlight this too"] \
1088 -command {flist_hl 0}
1089 $flist_menu add command -label [mc "Highlight this only"] \
1090 -command {flist_hl 1}
1093 # Windows sends all mouse wheel events to the current focused window, not
1094 # the one where the mouse hovers, so bind those events here and redirect
1095 # to the correct window
1096 proc windows_mousewheel_redirector {W X Y D} {
1097 global canv canv2 canv3
1098 set w [winfo containing -displayof $W $X $Y]
1099 if {$w ne ""} {
1100 set u [expr {$D < 0 ? 5 : -5}]
1101 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1102 allcanvs yview scroll $u units
1103 } else {
1104 catch {
1105 $w yview scroll $u units
1111 # mouse-2 makes all windows scan vertically, but only the one
1112 # the cursor is in scans horizontally
1113 proc canvscan {op w x y} {
1114 global canv canv2 canv3
1115 foreach c [list $canv $canv2 $canv3] {
1116 if {$c == $w} {
1117 $c scan $op $x $y
1118 } else {
1119 $c scan $op 0 $y
1124 proc scrollcanv {cscroll f0 f1} {
1125 $cscroll set $f0 $f1
1126 drawfrac $f0 $f1
1127 flushhighlights
1130 # when we make a key binding for the toplevel, make sure
1131 # it doesn't get triggered when that key is pressed in the
1132 # find string entry widget.
1133 proc bindkey {ev script} {
1134 global entries
1135 bind . $ev $script
1136 set escript [bind Entry $ev]
1137 if {$escript == {}} {
1138 set escript [bind Entry <Key>]
1140 foreach e $entries {
1141 bind $e $ev "$escript; break"
1145 # set the focus back to the toplevel for any click outside
1146 # the entry widgets
1147 proc click {w} {
1148 global ctext entries
1149 foreach e [concat $entries $ctext] {
1150 if {$w == $e} return
1152 focus .
1155 # Adjust the progress bar for a change in requested extent or canvas size
1156 proc adjustprogress {} {
1157 global progresscanv progressitem progresscoords
1158 global fprogitem fprogcoord lastprogupdate progupdatepending
1159 global rprogitem rprogcoord
1161 set w [expr {[winfo width $progresscanv] - 4}]
1162 set x0 [expr {$w * [lindex $progresscoords 0]}]
1163 set x1 [expr {$w * [lindex $progresscoords 1]}]
1164 set h [winfo height $progresscanv]
1165 $progresscanv coords $progressitem $x0 0 $x1 $h
1166 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1167 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1168 set now [clock clicks -milliseconds]
1169 if {$now >= $lastprogupdate + 100} {
1170 set progupdatepending 0
1171 update
1172 } elseif {!$progupdatepending} {
1173 set progupdatepending 1
1174 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1178 proc doprogupdate {} {
1179 global lastprogupdate progupdatepending
1181 if {$progupdatepending} {
1182 set progupdatepending 0
1183 set lastprogupdate [clock clicks -milliseconds]
1184 update
1188 proc savestuff {w} {
1189 global canv canv2 canv3 mainfont textfont uifont tabstop
1190 global stuffsaved findmergefiles maxgraphpct
1191 global maxwidth showneartags showlocalchanges
1192 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
1193 global cmitmode wrapcomment datetimeformat limitdiffs
1194 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1195 global autoselect
1197 if {$stuffsaved} return
1198 if {![winfo viewable .]} return
1199 catch {
1200 set f [open "~/.gitk-new" w]
1201 puts $f [list set mainfont $mainfont]
1202 puts $f [list set textfont $textfont]
1203 puts $f [list set uifont $uifont]
1204 puts $f [list set tabstop $tabstop]
1205 puts $f [list set findmergefiles $findmergefiles]
1206 puts $f [list set maxgraphpct $maxgraphpct]
1207 puts $f [list set maxwidth $maxwidth]
1208 puts $f [list set cmitmode $cmitmode]
1209 puts $f [list set wrapcomment $wrapcomment]
1210 puts $f [list set autoselect $autoselect]
1211 puts $f [list set showneartags $showneartags]
1212 puts $f [list set showlocalchanges $showlocalchanges]
1213 puts $f [list set datetimeformat $datetimeformat]
1214 puts $f [list set limitdiffs $limitdiffs]
1215 puts $f [list set bgcolor $bgcolor]
1216 puts $f [list set fgcolor $fgcolor]
1217 puts $f [list set colors $colors]
1218 puts $f [list set diffcolors $diffcolors]
1219 puts $f [list set diffcontext $diffcontext]
1220 puts $f [list set selectbgcolor $selectbgcolor]
1222 puts $f "set geometry(main) [wm geometry .]"
1223 puts $f "set geometry(topwidth) [winfo width .tf]"
1224 puts $f "set geometry(topheight) [winfo height .tf]"
1225 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1226 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1227 puts $f "set geometry(botwidth) [winfo width .bleft]"
1228 puts $f "set geometry(botheight) [winfo height .bleft]"
1230 puts -nonewline $f "set permviews {"
1231 for {set v 0} {$v < $nextviewnum} {incr v} {
1232 if {$viewperm($v)} {
1233 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1236 puts $f "}"
1237 close $f
1238 catch {file delete "~/.gitk"}
1239 file rename -force "~/.gitk-new" "~/.gitk"
1241 set stuffsaved 1
1244 proc resizeclistpanes {win w} {
1245 global oldwidth
1246 if {[info exists oldwidth($win)]} {
1247 set s0 [$win sash coord 0]
1248 set s1 [$win sash coord 1]
1249 if {$w < 60} {
1250 set sash0 [expr {int($w/2 - 2)}]
1251 set sash1 [expr {int($w*5/6 - 2)}]
1252 } else {
1253 set factor [expr {1.0 * $w / $oldwidth($win)}]
1254 set sash0 [expr {int($factor * [lindex $s0 0])}]
1255 set sash1 [expr {int($factor * [lindex $s1 0])}]
1256 if {$sash0 < 30} {
1257 set sash0 30
1259 if {$sash1 < $sash0 + 20} {
1260 set sash1 [expr {$sash0 + 20}]
1262 if {$sash1 > $w - 10} {
1263 set sash1 [expr {$w - 10}]
1264 if {$sash0 > $sash1 - 20} {
1265 set sash0 [expr {$sash1 - 20}]
1269 $win sash place 0 $sash0 [lindex $s0 1]
1270 $win sash place 1 $sash1 [lindex $s1 1]
1272 set oldwidth($win) $w
1275 proc resizecdetpanes {win w} {
1276 global oldwidth
1277 if {[info exists oldwidth($win)]} {
1278 set s0 [$win sash coord 0]
1279 if {$w < 60} {
1280 set sash0 [expr {int($w*3/4 - 2)}]
1281 } else {
1282 set factor [expr {1.0 * $w / $oldwidth($win)}]
1283 set sash0 [expr {int($factor * [lindex $s0 0])}]
1284 if {$sash0 < 45} {
1285 set sash0 45
1287 if {$sash0 > $w - 15} {
1288 set sash0 [expr {$w - 15}]
1291 $win sash place 0 $sash0 [lindex $s0 1]
1293 set oldwidth($win) $w
1296 proc allcanvs args {
1297 global canv canv2 canv3
1298 eval $canv $args
1299 eval $canv2 $args
1300 eval $canv3 $args
1303 proc bindall {event action} {
1304 global canv canv2 canv3
1305 bind $canv $event $action
1306 bind $canv2 $event $action
1307 bind $canv3 $event $action
1310 proc about {} {
1311 global uifont
1312 set w .about
1313 if {[winfo exists $w]} {
1314 raise $w
1315 return
1317 toplevel $w
1318 wm title $w [mc "About gitk"]
1319 message $w.m -text [mc "
1320 Gitk - a commit viewer for git
1322 Copyright © 2005-2006 Paul Mackerras
1324 Use and redistribute under the terms of the GNU General Public License"] \
1325 -justify center -aspect 400 -border 2 -bg white -relief groove
1326 pack $w.m -side top -fill x -padx 2 -pady 2
1327 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
1328 pack $w.ok -side bottom
1329 bind $w <Visibility> "focus $w.ok"
1330 bind $w <Key-Escape> "destroy $w"
1331 bind $w <Key-Return> "destroy $w"
1334 proc keys {} {
1335 set w .keys
1336 if {[winfo exists $w]} {
1337 raise $w
1338 return
1340 if {[tk windowingsystem] eq {aqua}} {
1341 set M1T Cmd
1342 } else {
1343 set M1T Ctrl
1345 toplevel $w
1346 wm title $w [mc "Gitk key bindings"]
1347 message $w.m -text "
1348 [mc "Gitk key bindings:"]
1350 [mc "<%s-Q> Quit" $M1T]
1351 [mc "<Home> Move to first commit"]
1352 [mc "<End> Move to last commit"]
1353 [mc "<Up>, p, i Move up one commit"]
1354 [mc "<Down>, n, k Move down one commit"]
1355 [mc "<Left>, z, j Go back in history list"]
1356 [mc "<Right>, x, l Go forward in history list"]
1357 [mc "<PageUp> Move up one page in commit list"]
1358 [mc "<PageDown> Move down one page in commit list"]
1359 [mc "<%s-Home> Scroll to top of commit list" $M1T]
1360 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
1361 [mc "<%s-Up> Scroll commit list up one line" $M1T]
1362 [mc "<%s-Down> Scroll commit list down one line" $M1T]
1363 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
1364 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
1365 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
1366 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
1367 [mc "<Delete>, b Scroll diff view up one page"]
1368 [mc "<Backspace> Scroll diff view up one page"]
1369 [mc "<Space> Scroll diff view down one page"]
1370 [mc "u Scroll diff view up 18 lines"]
1371 [mc "d Scroll diff view down 18 lines"]
1372 [mc "<%s-F> Find" $M1T]
1373 [mc "<%s-G> Move to next find hit" $M1T]
1374 [mc "<Return> Move to next find hit"]
1375 [mc "/ Move to next find hit, or redo find"]
1376 [mc "? Move to previous find hit"]
1377 [mc "f Scroll diff view to next file"]
1378 [mc "<%s-S> Search for next hit in diff view" $M1T]
1379 [mc "<%s-R> Search for previous hit in diff view" $M1T]
1380 [mc "<%s-KP+> Increase font size" $M1T]
1381 [mc "<%s-plus> Increase font size" $M1T]
1382 [mc "<%s-KP-> Decrease font size" $M1T]
1383 [mc "<%s-minus> Decrease font size" $M1T]
1384 [mc "<F5> Update"]
1386 -justify left -bg white -border 2 -relief groove
1387 pack $w.m -side top -fill both -padx 2 -pady 2
1388 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
1389 pack $w.ok -side bottom
1390 bind $w <Visibility> "focus $w.ok"
1391 bind $w <Key-Escape> "destroy $w"
1392 bind $w <Key-Return> "destroy $w"
1395 # Procedures for manipulating the file list window at the
1396 # bottom right of the overall window.
1398 proc treeview {w l openlevs} {
1399 global treecontents treediropen treeheight treeparent treeindex
1401 set ix 0
1402 set treeindex() 0
1403 set lev 0
1404 set prefix {}
1405 set prefixend -1
1406 set prefendstack {}
1407 set htstack {}
1408 set ht 0
1409 set treecontents() {}
1410 $w conf -state normal
1411 foreach f $l {
1412 while {[string range $f 0 $prefixend] ne $prefix} {
1413 if {$lev <= $openlevs} {
1414 $w mark set e:$treeindex($prefix) "end -1c"
1415 $w mark gravity e:$treeindex($prefix) left
1417 set treeheight($prefix) $ht
1418 incr ht [lindex $htstack end]
1419 set htstack [lreplace $htstack end end]
1420 set prefixend [lindex $prefendstack end]
1421 set prefendstack [lreplace $prefendstack end end]
1422 set prefix [string range $prefix 0 $prefixend]
1423 incr lev -1
1425 set tail [string range $f [expr {$prefixend+1}] end]
1426 while {[set slash [string first "/" $tail]] >= 0} {
1427 lappend htstack $ht
1428 set ht 0
1429 lappend prefendstack $prefixend
1430 incr prefixend [expr {$slash + 1}]
1431 set d [string range $tail 0 $slash]
1432 lappend treecontents($prefix) $d
1433 set oldprefix $prefix
1434 append prefix $d
1435 set treecontents($prefix) {}
1436 set treeindex($prefix) [incr ix]
1437 set treeparent($prefix) $oldprefix
1438 set tail [string range $tail [expr {$slash+1}] end]
1439 if {$lev <= $openlevs} {
1440 set ht 1
1441 set treediropen($prefix) [expr {$lev < $openlevs}]
1442 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1443 $w mark set d:$ix "end -1c"
1444 $w mark gravity d:$ix left
1445 set str "\n"
1446 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1447 $w insert end $str
1448 $w image create end -align center -image $bm -padx 1 \
1449 -name a:$ix
1450 $w insert end $d [highlight_tag $prefix]
1451 $w mark set s:$ix "end -1c"
1452 $w mark gravity s:$ix left
1454 incr lev
1456 if {$tail ne {}} {
1457 if {$lev <= $openlevs} {
1458 incr ht
1459 set str "\n"
1460 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1461 $w insert end $str
1462 $w insert end $tail [highlight_tag $f]
1464 lappend treecontents($prefix) $tail
1467 while {$htstack ne {}} {
1468 set treeheight($prefix) $ht
1469 incr ht [lindex $htstack end]
1470 set htstack [lreplace $htstack end end]
1471 set prefixend [lindex $prefendstack end]
1472 set prefendstack [lreplace $prefendstack end end]
1473 set prefix [string range $prefix 0 $prefixend]
1475 $w conf -state disabled
1478 proc linetoelt {l} {
1479 global treeheight treecontents
1481 set y 2
1482 set prefix {}
1483 while {1} {
1484 foreach e $treecontents($prefix) {
1485 if {$y == $l} {
1486 return "$prefix$e"
1488 set n 1
1489 if {[string index $e end] eq "/"} {
1490 set n $treeheight($prefix$e)
1491 if {$y + $n > $l} {
1492 append prefix $e
1493 incr y
1494 break
1497 incr y $n
1502 proc highlight_tree {y prefix} {
1503 global treeheight treecontents cflist
1505 foreach e $treecontents($prefix) {
1506 set path $prefix$e
1507 if {[highlight_tag $path] ne {}} {
1508 $cflist tag add bold $y.0 "$y.0 lineend"
1510 incr y
1511 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1512 set y [highlight_tree $y $path]
1515 return $y
1518 proc treeclosedir {w dir} {
1519 global treediropen treeheight treeparent treeindex
1521 set ix $treeindex($dir)
1522 $w conf -state normal
1523 $w delete s:$ix e:$ix
1524 set treediropen($dir) 0
1525 $w image configure a:$ix -image tri-rt
1526 $w conf -state disabled
1527 set n [expr {1 - $treeheight($dir)}]
1528 while {$dir ne {}} {
1529 incr treeheight($dir) $n
1530 set dir $treeparent($dir)
1534 proc treeopendir {w dir} {
1535 global treediropen treeheight treeparent treecontents treeindex
1537 set ix $treeindex($dir)
1538 $w conf -state normal
1539 $w image configure a:$ix -image tri-dn
1540 $w mark set e:$ix s:$ix
1541 $w mark gravity e:$ix right
1542 set lev 0
1543 set str "\n"
1544 set n [llength $treecontents($dir)]
1545 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1546 incr lev
1547 append str "\t"
1548 incr treeheight($x) $n
1550 foreach e $treecontents($dir) {
1551 set de $dir$e
1552 if {[string index $e end] eq "/"} {
1553 set iy $treeindex($de)
1554 $w mark set d:$iy e:$ix
1555 $w mark gravity d:$iy left
1556 $w insert e:$ix $str
1557 set treediropen($de) 0
1558 $w image create e:$ix -align center -image tri-rt -padx 1 \
1559 -name a:$iy
1560 $w insert e:$ix $e [highlight_tag $de]
1561 $w mark set s:$iy e:$ix
1562 $w mark gravity s:$iy left
1563 set treeheight($de) 1
1564 } else {
1565 $w insert e:$ix $str
1566 $w insert e:$ix $e [highlight_tag $de]
1569 $w mark gravity e:$ix left
1570 $w conf -state disabled
1571 set treediropen($dir) 1
1572 set top [lindex [split [$w index @0,0] .] 0]
1573 set ht [$w cget -height]
1574 set l [lindex [split [$w index s:$ix] .] 0]
1575 if {$l < $top} {
1576 $w yview $l.0
1577 } elseif {$l + $n + 1 > $top + $ht} {
1578 set top [expr {$l + $n + 2 - $ht}]
1579 if {$l < $top} {
1580 set top $l
1582 $w yview $top.0
1586 proc treeclick {w x y} {
1587 global treediropen cmitmode ctext cflist cflist_top
1589 if {$cmitmode ne "tree"} return
1590 if {![info exists cflist_top]} return
1591 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1592 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1593 $cflist tag add highlight $l.0 "$l.0 lineend"
1594 set cflist_top $l
1595 if {$l == 1} {
1596 $ctext yview 1.0
1597 return
1599 set e [linetoelt $l]
1600 if {[string index $e end] ne "/"} {
1601 showfile $e
1602 } elseif {$treediropen($e)} {
1603 treeclosedir $w $e
1604 } else {
1605 treeopendir $w $e
1609 proc setfilelist {id} {
1610 global treefilelist cflist
1612 treeview $cflist $treefilelist($id) 0
1615 image create bitmap tri-rt -background black -foreground blue -data {
1616 #define tri-rt_width 13
1617 #define tri-rt_height 13
1618 static unsigned char tri-rt_bits[] = {
1619 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1620 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1621 0x00, 0x00};
1622 } -maskdata {
1623 #define tri-rt-mask_width 13
1624 #define tri-rt-mask_height 13
1625 static unsigned char tri-rt-mask_bits[] = {
1626 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1627 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1628 0x08, 0x00};
1630 image create bitmap tri-dn -background black -foreground blue -data {
1631 #define tri-dn_width 13
1632 #define tri-dn_height 13
1633 static unsigned char tri-dn_bits[] = {
1634 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1635 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1636 0x00, 0x00};
1637 } -maskdata {
1638 #define tri-dn-mask_width 13
1639 #define tri-dn-mask_height 13
1640 static unsigned char tri-dn-mask_bits[] = {
1641 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1642 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1643 0x00, 0x00};
1646 image create bitmap reficon-T -background black -foreground yellow -data {
1647 #define tagicon_width 13
1648 #define tagicon_height 9
1649 static unsigned char tagicon_bits[] = {
1650 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1651 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1652 } -maskdata {
1653 #define tagicon-mask_width 13
1654 #define tagicon-mask_height 9
1655 static unsigned char tagicon-mask_bits[] = {
1656 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1657 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1659 set rectdata {
1660 #define headicon_width 13
1661 #define headicon_height 9
1662 static unsigned char headicon_bits[] = {
1663 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1664 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1666 set rectmask {
1667 #define headicon-mask_width 13
1668 #define headicon-mask_height 9
1669 static unsigned char headicon-mask_bits[] = {
1670 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1671 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1673 image create bitmap reficon-H -background black -foreground green \
1674 -data $rectdata -maskdata $rectmask
1675 image create bitmap reficon-o -background black -foreground "#ddddff" \
1676 -data $rectdata -maskdata $rectmask
1678 proc init_flist {first} {
1679 global cflist cflist_top selectedline difffilestart
1681 $cflist conf -state normal
1682 $cflist delete 0.0 end
1683 if {$first ne {}} {
1684 $cflist insert end $first
1685 set cflist_top 1
1686 $cflist tag add highlight 1.0 "1.0 lineend"
1687 } else {
1688 catch {unset cflist_top}
1690 $cflist conf -state disabled
1691 set difffilestart {}
1694 proc highlight_tag {f} {
1695 global highlight_paths
1697 foreach p $highlight_paths {
1698 if {[string match $p $f]} {
1699 return "bold"
1702 return {}
1705 proc highlight_filelist {} {
1706 global cmitmode cflist
1708 $cflist conf -state normal
1709 if {$cmitmode ne "tree"} {
1710 set end [lindex [split [$cflist index end] .] 0]
1711 for {set l 2} {$l < $end} {incr l} {
1712 set line [$cflist get $l.0 "$l.0 lineend"]
1713 if {[highlight_tag $line] ne {}} {
1714 $cflist tag add bold $l.0 "$l.0 lineend"
1717 } else {
1718 highlight_tree 2 {}
1720 $cflist conf -state disabled
1723 proc unhighlight_filelist {} {
1724 global cflist
1726 $cflist conf -state normal
1727 $cflist tag remove bold 1.0 end
1728 $cflist conf -state disabled
1731 proc add_flist {fl} {
1732 global cflist
1734 $cflist conf -state normal
1735 foreach f $fl {
1736 $cflist insert end "\n"
1737 $cflist insert end $f [highlight_tag $f]
1739 $cflist conf -state disabled
1742 proc sel_flist {w x y} {
1743 global ctext difffilestart cflist cflist_top cmitmode
1745 if {$cmitmode eq "tree"} return
1746 if {![info exists cflist_top]} return
1747 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1748 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1749 $cflist tag add highlight $l.0 "$l.0 lineend"
1750 set cflist_top $l
1751 if {$l == 1} {
1752 $ctext yview 1.0
1753 } else {
1754 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1758 proc pop_flist_menu {w X Y x y} {
1759 global ctext cflist cmitmode flist_menu flist_menu_file
1760 global treediffs diffids
1762 stopfinding
1763 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1764 if {$l <= 1} return
1765 if {$cmitmode eq "tree"} {
1766 set e [linetoelt $l]
1767 if {[string index $e end] eq "/"} return
1768 } else {
1769 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1771 set flist_menu_file $e
1772 tk_popup $flist_menu $X $Y
1775 proc flist_hl {only} {
1776 global flist_menu_file findstring gdttype
1778 set x [shellquote $flist_menu_file]
1779 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
1780 set findstring $x
1781 } else {
1782 append findstring " " $x
1784 set gdttype [mc "touching paths:"]
1787 # Functions for adding and removing shell-type quoting
1789 proc shellquote {str} {
1790 if {![string match "*\['\"\\ \t]*" $str]} {
1791 return $str
1793 if {![string match "*\['\"\\]*" $str]} {
1794 return "\"$str\""
1796 if {![string match "*'*" $str]} {
1797 return "'$str'"
1799 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1802 proc shellarglist {l} {
1803 set str {}
1804 foreach a $l {
1805 if {$str ne {}} {
1806 append str " "
1808 append str [shellquote $a]
1810 return $str
1813 proc shelldequote {str} {
1814 set ret {}
1815 set used -1
1816 while {1} {
1817 incr used
1818 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1819 append ret [string range $str $used end]
1820 set used [string length $str]
1821 break
1823 set first [lindex $first 0]
1824 set ch [string index $str $first]
1825 if {$first > $used} {
1826 append ret [string range $str $used [expr {$first - 1}]]
1827 set used $first
1829 if {$ch eq " " || $ch eq "\t"} break
1830 incr used
1831 if {$ch eq "'"} {
1832 set first [string first "'" $str $used]
1833 if {$first < 0} {
1834 error "unmatched single-quote"
1836 append ret [string range $str $used [expr {$first - 1}]]
1837 set used $first
1838 continue
1840 if {$ch eq "\\"} {
1841 if {$used >= [string length $str]} {
1842 error "trailing backslash"
1844 append ret [string index $str $used]
1845 continue
1847 # here ch == "\""
1848 while {1} {
1849 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1850 error "unmatched double-quote"
1852 set first [lindex $first 0]
1853 set ch [string index $str $first]
1854 if {$first > $used} {
1855 append ret [string range $str $used [expr {$first - 1}]]
1856 set used $first
1858 if {$ch eq "\""} break
1859 incr used
1860 append ret [string index $str $used]
1861 incr used
1864 return [list $used $ret]
1867 proc shellsplit {str} {
1868 set l {}
1869 while {1} {
1870 set str [string trimleft $str]
1871 if {$str eq {}} break
1872 set dq [shelldequote $str]
1873 set n [lindex $dq 0]
1874 set word [lindex $dq 1]
1875 set str [string range $str $n end]
1876 lappend l $word
1878 return $l
1881 # Code to implement multiple views
1883 proc newview {ishighlight} {
1884 global nextviewnum newviewname newviewperm newishighlight
1885 global newviewargs revtreeargs viewargscmd newviewargscmd curview
1887 set newishighlight $ishighlight
1888 set top .gitkview
1889 if {[winfo exists $top]} {
1890 raise $top
1891 return
1893 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
1894 set newviewperm($nextviewnum) 0
1895 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1896 set newviewargscmd($nextviewnum) $viewargscmd($curview)
1897 vieweditor $top $nextviewnum [mc "Gitk view definition"]
1900 proc editview {} {
1901 global curview
1902 global viewname viewperm newviewname newviewperm
1903 global viewargs newviewargs viewargscmd newviewargscmd
1905 set top .gitkvedit-$curview
1906 if {[winfo exists $top]} {
1907 raise $top
1908 return
1910 set newviewname($curview) $viewname($curview)
1911 set newviewperm($curview) $viewperm($curview)
1912 set newviewargs($curview) [shellarglist $viewargs($curview)]
1913 set newviewargscmd($curview) $viewargscmd($curview)
1914 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1917 proc vieweditor {top n title} {
1918 global newviewname newviewperm viewfiles bgcolor
1920 toplevel $top
1921 wm title $top $title
1922 label $top.nl -text [mc "Name"]
1923 entry $top.name -width 20 -textvariable newviewname($n)
1924 grid $top.nl $top.name -sticky w -pady 5
1925 checkbutton $top.perm -text [mc "Remember this view"] \
1926 -variable newviewperm($n)
1927 grid $top.perm - -pady 5 -sticky w
1928 message $top.al -aspect 1000 \
1929 -text [mc "Commits to include (arguments to git rev-list):"]
1930 grid $top.al - -sticky w -pady 5
1931 entry $top.args -width 50 -textvariable newviewargs($n) \
1932 -background $bgcolor
1933 grid $top.args - -sticky ew -padx 5
1935 message $top.ac -aspect 1000 \
1936 -text [mc "Command to generate more commits to include:"]
1937 grid $top.ac - -sticky w -pady 5
1938 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
1939 -background white
1940 grid $top.argscmd - -sticky ew -padx 5
1942 message $top.l -aspect 1000 \
1943 -text [mc "Enter files and directories to include, one per line:"]
1944 grid $top.l - -sticky w
1945 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
1946 if {[info exists viewfiles($n)]} {
1947 foreach f $viewfiles($n) {
1948 $top.t insert end $f
1949 $top.t insert end "\n"
1951 $top.t delete {end - 1c} end
1952 $top.t mark set insert 0.0
1954 grid $top.t - -sticky ew -padx 5
1955 frame $top.buts
1956 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
1957 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
1958 grid $top.buts.ok $top.buts.can
1959 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1960 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1961 grid $top.buts - -pady 10 -sticky ew
1962 focus $top.t
1965 proc doviewmenu {m first cmd op argv} {
1966 set nmenu [$m index end]
1967 for {set i $first} {$i <= $nmenu} {incr i} {
1968 if {[$m entrycget $i -command] eq $cmd} {
1969 eval $m $op $i $argv
1970 break
1975 proc allviewmenus {n op args} {
1976 # global viewhlmenu
1978 doviewmenu .bar.view 5 [list showview $n] $op $args
1979 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1982 proc newviewok {top n} {
1983 global nextviewnum newviewperm newviewname newishighlight
1984 global viewname viewfiles viewperm selectedview curview
1985 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
1987 if {[catch {
1988 set newargs [shellsplit $newviewargs($n)]
1989 } err]} {
1990 error_popup "[mc "Error in commit selection arguments:"] $err"
1991 wm raise $top
1992 focus $top
1993 return
1995 set files {}
1996 foreach f [split [$top.t get 0.0 end] "\n"] {
1997 set ft [string trim $f]
1998 if {$ft ne {}} {
1999 lappend files $ft
2002 if {![info exists viewfiles($n)]} {
2003 # creating a new view
2004 incr nextviewnum
2005 set viewname($n) $newviewname($n)
2006 set viewperm($n) $newviewperm($n)
2007 set viewfiles($n) $files
2008 set viewargs($n) $newargs
2009 set viewargscmd($n) $newviewargscmd($n)
2010 addviewmenu $n
2011 if {!$newishighlight} {
2012 run showview $n
2013 } else {
2014 run addvhighlight $n
2016 } else {
2017 # editing an existing view
2018 set viewperm($n) $newviewperm($n)
2019 if {$newviewname($n) ne $viewname($n)} {
2020 set viewname($n) $newviewname($n)
2021 doviewmenu .bar.view 5 [list showview $n] \
2022 entryconf [list -label $viewname($n)]
2023 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2024 # entryconf [list -label $viewname($n) -value $viewname($n)]
2026 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
2027 $newviewargscmd($n) ne $viewargscmd($n)} {
2028 set viewfiles($n) $files
2029 set viewargs($n) $newargs
2030 set viewargscmd($n) $newviewargscmd($n)
2031 if {$curview == $n} {
2032 run updatecommits
2036 catch {destroy $top}
2039 proc delview {} {
2040 global curview viewdata viewperm hlview selectedhlview
2042 if {$curview == 0} return
2043 if {[info exists hlview] && $hlview == $curview} {
2044 set selectedhlview [mc "None"]
2045 unset hlview
2047 allviewmenus $curview delete
2048 set viewdata($curview) {}
2049 set viewperm($curview) 0
2050 showview 0
2053 proc addviewmenu {n} {
2054 global viewname viewhlmenu
2056 .bar.view add radiobutton -label $viewname($n) \
2057 -command [list showview $n] -variable selectedview -value $n
2058 #$viewhlmenu add radiobutton -label $viewname($n) \
2059 # -command [list addvhighlight $n] -variable selectedhlview
2062 proc flatten {var} {
2063 global $var
2065 set ret {}
2066 foreach i [array names $var] {
2067 lappend ret $i [set $var\($i\)]
2069 return $ret
2072 proc unflatten {var l} {
2073 global $var
2075 catch {unset $var}
2076 foreach {i v} $l {
2077 set $var\($i\) $v
2081 proc showview {n} {
2082 global curview viewdata viewfiles
2083 global displayorder parentlist rowidlist rowisopt rowfinal
2084 global colormap rowtextx commitrow nextcolor canvxmax
2085 global numcommits commitlisted
2086 global selectedline currentid canv canvy0
2087 global treediffs
2088 global pending_select phase
2089 global commitidx
2090 global commfd
2091 global selectedview selectfirst
2092 global vparentlist vdisporder vcmitlisted
2093 global hlview selectedhlview commitinterest
2095 if {$n == $curview} return
2096 set selid {}
2097 if {[info exists selectedline]} {
2098 set selid $currentid
2099 set y [yc $selectedline]
2100 set ymax [lindex [$canv cget -scrollregion] 3]
2101 set span [$canv yview]
2102 set ytop [expr {[lindex $span 0] * $ymax}]
2103 set ybot [expr {[lindex $span 1] * $ymax}]
2104 if {$ytop < $y && $y < $ybot} {
2105 set yscreen [expr {$y - $ytop}]
2107 } elseif {[info exists pending_select]} {
2108 set selid $pending_select
2109 unset pending_select
2111 unselectline
2112 normalline
2113 if {$curview >= 0} {
2114 set vparentlist($curview) $parentlist
2115 set vdisporder($curview) $displayorder
2116 set vcmitlisted($curview) $commitlisted
2117 if {$phase ne {} ||
2118 ![info exists viewdata($curview)] ||
2119 [lindex $viewdata($curview) 0] ne {}} {
2120 set viewdata($curview) \
2121 [list $phase $rowidlist $rowisopt $rowfinal]
2124 catch {unset treediffs}
2125 clear_display
2126 if {[info exists hlview] && $hlview == $n} {
2127 unset hlview
2128 set selectedhlview [mc "None"]
2130 catch {unset commitinterest}
2132 set curview $n
2133 set selectedview $n
2134 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2135 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2137 run refill_reflist
2138 if {![info exists viewdata($n)]} {
2139 if {$selid ne {}} {
2140 set pending_select $selid
2142 getcommits
2143 return
2146 set v $viewdata($n)
2147 set phase [lindex $v 0]
2148 set displayorder $vdisporder($n)
2149 set parentlist $vparentlist($n)
2150 set commitlisted $vcmitlisted($n)
2151 set rowidlist [lindex $v 1]
2152 set rowisopt [lindex $v 2]
2153 set rowfinal [lindex $v 3]
2154 set numcommits $commitidx($n)
2156 catch {unset colormap}
2157 catch {unset rowtextx}
2158 set nextcolor 0
2159 set canvxmax [$canv cget -width]
2160 set curview $n
2161 set row 0
2162 setcanvscroll
2163 set yf 0
2164 set row {}
2165 set selectfirst 0
2166 if {[info exists yscreen] && [info exists commitrow($n,$selid)]} {
2167 set row $commitrow($n,$selid)
2168 # try to get the selected row in the same position on the screen
2169 set ymax [lindex [$canv cget -scrollregion] 3]
2170 set ytop [expr {[yc $row] - $yscreen}]
2171 if {$ytop < 0} {
2172 set ytop 0
2174 set yf [expr {$ytop * 1.0 / $ymax}]
2176 allcanvs yview moveto $yf
2177 drawvisible
2178 if {$row ne {}} {
2179 selectline $row 0
2180 } elseif {$selid ne {}} {
2181 set pending_select $selid
2182 } else {
2183 set row [first_real_row]
2184 if {$row < $numcommits} {
2185 selectline $row 0
2186 } else {
2187 set selectfirst 1
2190 if {$phase ne {}} {
2191 if {$phase eq "getcommits"} {
2192 show_status [mc "Reading commits..."]
2194 run chewcommits $n
2195 } elseif {$numcommits == 0} {
2196 show_status [mc "No commits selected"]
2200 # Stuff relating to the highlighting facility
2202 proc ishighlighted {row} {
2203 global vhighlights fhighlights nhighlights rhighlights
2205 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2206 return $nhighlights($row)
2208 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2209 return $vhighlights($row)
2211 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2212 return $fhighlights($row)
2214 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2215 return $rhighlights($row)
2217 return 0
2220 proc bolden {row font} {
2221 global canv linehtag selectedline boldrows
2223 lappend boldrows $row
2224 $canv itemconf $linehtag($row) -font $font
2225 if {[info exists selectedline] && $row == $selectedline} {
2226 $canv delete secsel
2227 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2228 -outline {{}} -tags secsel \
2229 -fill [$canv cget -selectbackground]]
2230 $canv lower $t
2234 proc bolden_name {row font} {
2235 global canv2 linentag selectedline boldnamerows
2237 lappend boldnamerows $row
2238 $canv2 itemconf $linentag($row) -font $font
2239 if {[info exists selectedline] && $row == $selectedline} {
2240 $canv2 delete secsel
2241 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2242 -outline {{}} -tags secsel \
2243 -fill [$canv2 cget -selectbackground]]
2244 $canv2 lower $t
2248 proc unbolden {} {
2249 global boldrows
2251 set stillbold {}
2252 foreach row $boldrows {
2253 if {![ishighlighted $row]} {
2254 bolden $row mainfont
2255 } else {
2256 lappend stillbold $row
2259 set boldrows $stillbold
2262 proc addvhighlight {n} {
2263 global hlview curview viewdata vhl_done vhighlights commitidx
2265 if {[info exists hlview]} {
2266 delvhighlight
2268 set hlview $n
2269 if {$n != $curview && ![info exists viewdata($n)]} {
2270 set viewdata($n) [list getcommits {{}} 0 0 0]
2271 set vparentlist($n) {}
2272 set vdisporder($n) {}
2273 set vcmitlisted($n) {}
2274 start_rev_list $n
2276 set vhl_done $commitidx($hlview)
2277 if {$vhl_done > 0} {
2278 drawvisible
2282 proc delvhighlight {} {
2283 global hlview vhighlights
2285 if {![info exists hlview]} return
2286 unset hlview
2287 catch {unset vhighlights}
2288 unbolden
2291 proc vhighlightmore {} {
2292 global hlview vhl_done commitidx vhighlights
2293 global displayorder vdisporder curview
2295 set max $commitidx($hlview)
2296 if {$hlview == $curview} {
2297 set disp $displayorder
2298 } else {
2299 set disp $vdisporder($hlview)
2301 set vr [visiblerows]
2302 set r0 [lindex $vr 0]
2303 set r1 [lindex $vr 1]
2304 for {set i $vhl_done} {$i < $max} {incr i} {
2305 set id [lindex $disp $i]
2306 if {[info exists commitrow($curview,$id)]} {
2307 set row $commitrow($curview,$id)
2308 if {$r0 <= $row && $row <= $r1} {
2309 if {![highlighted $row]} {
2310 bolden $row mainfontbold
2312 set vhighlights($row) 1
2316 set vhl_done $max
2319 proc askvhighlight {row id} {
2320 global hlview vhighlights commitrow iddrawn
2322 if {[info exists commitrow($hlview,$id)]} {
2323 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2324 bolden $row mainfontbold
2326 set vhighlights($row) 1
2327 } else {
2328 set vhighlights($row) 0
2332 proc hfiles_change {} {
2333 global highlight_files filehighlight fhighlights fh_serial
2334 global highlight_paths gdttype
2336 if {[info exists filehighlight]} {
2337 # delete previous highlights
2338 catch {close $filehighlight}
2339 unset filehighlight
2340 catch {unset fhighlights}
2341 unbolden
2342 unhighlight_filelist
2344 set highlight_paths {}
2345 after cancel do_file_hl $fh_serial
2346 incr fh_serial
2347 if {$highlight_files ne {}} {
2348 after 300 do_file_hl $fh_serial
2352 proc gdttype_change {name ix op} {
2353 global gdttype highlight_files findstring findpattern
2355 stopfinding
2356 if {$findstring ne {}} {
2357 if {$gdttype eq [mc "containing:"]} {
2358 if {$highlight_files ne {}} {
2359 set highlight_files {}
2360 hfiles_change
2362 findcom_change
2363 } else {
2364 if {$findpattern ne {}} {
2365 set findpattern {}
2366 findcom_change
2368 set highlight_files $findstring
2369 hfiles_change
2371 drawvisible
2373 # enable/disable findtype/findloc menus too
2376 proc find_change {name ix op} {
2377 global gdttype findstring highlight_files
2379 stopfinding
2380 if {$gdttype eq [mc "containing:"]} {
2381 findcom_change
2382 } else {
2383 if {$highlight_files ne $findstring} {
2384 set highlight_files $findstring
2385 hfiles_change
2388 drawvisible
2391 proc findcom_change args {
2392 global nhighlights boldnamerows
2393 global findpattern findtype findstring gdttype
2395 stopfinding
2396 # delete previous highlights, if any
2397 foreach row $boldnamerows {
2398 bolden_name $row mainfont
2400 set boldnamerows {}
2401 catch {unset nhighlights}
2402 unbolden
2403 unmarkmatches
2404 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
2405 set findpattern {}
2406 } elseif {$findtype eq [mc "Regexp"]} {
2407 set findpattern $findstring
2408 } else {
2409 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2410 $findstring]
2411 set findpattern "*$e*"
2415 proc makepatterns {l} {
2416 set ret {}
2417 foreach e $l {
2418 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2419 if {[string index $ee end] eq "/"} {
2420 lappend ret "$ee*"
2421 } else {
2422 lappend ret $ee
2423 lappend ret "$ee/*"
2426 return $ret
2429 proc do_file_hl {serial} {
2430 global highlight_files filehighlight highlight_paths gdttype fhl_list
2432 if {$gdttype eq [mc "touching paths:"]} {
2433 if {[catch {set paths [shellsplit $highlight_files]}]} return
2434 set highlight_paths [makepatterns $paths]
2435 highlight_filelist
2436 set gdtargs [concat -- $paths]
2437 } elseif {$gdttype eq [mc "adding/removing string:"]} {
2438 set gdtargs [list "-S$highlight_files"]
2439 } else {
2440 # must be "containing:", i.e. we're searching commit info
2441 return
2443 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2444 set filehighlight [open $cmd r+]
2445 fconfigure $filehighlight -blocking 0
2446 filerun $filehighlight readfhighlight
2447 set fhl_list {}
2448 drawvisible
2449 flushhighlights
2452 proc flushhighlights {} {
2453 global filehighlight fhl_list
2455 if {[info exists filehighlight]} {
2456 lappend fhl_list {}
2457 puts $filehighlight ""
2458 flush $filehighlight
2462 proc askfilehighlight {row id} {
2463 global filehighlight fhighlights fhl_list
2465 lappend fhl_list $id
2466 set fhighlights($row) -1
2467 puts $filehighlight $id
2470 proc readfhighlight {} {
2471 global filehighlight fhighlights commitrow curview iddrawn
2472 global fhl_list find_dirn
2474 if {![info exists filehighlight]} {
2475 return 0
2477 set nr 0
2478 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2479 set line [string trim $line]
2480 set i [lsearch -exact $fhl_list $line]
2481 if {$i < 0} continue
2482 for {set j 0} {$j < $i} {incr j} {
2483 set id [lindex $fhl_list $j]
2484 if {[info exists commitrow($curview,$id)]} {
2485 set fhighlights($commitrow($curview,$id)) 0
2488 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2489 if {$line eq {}} continue
2490 if {![info exists commitrow($curview,$line)]} continue
2491 set row $commitrow($curview,$line)
2492 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2493 bolden $row mainfontbold
2495 set fhighlights($row) 1
2497 if {[eof $filehighlight]} {
2498 # strange...
2499 puts "oops, git diff-tree died"
2500 catch {close $filehighlight}
2501 unset filehighlight
2502 return 0
2504 if {[info exists find_dirn]} {
2505 run findmore
2507 return 1
2510 proc doesmatch {f} {
2511 global findtype findpattern
2513 if {$findtype eq [mc "Regexp"]} {
2514 return [regexp $findpattern $f]
2515 } elseif {$findtype eq [mc "IgnCase"]} {
2516 return [string match -nocase $findpattern $f]
2517 } else {
2518 return [string match $findpattern $f]
2522 proc askfindhighlight {row id} {
2523 global nhighlights commitinfo iddrawn
2524 global findloc
2525 global markingmatches
2527 if {![info exists commitinfo($id)]} {
2528 getcommit $id
2530 set info $commitinfo($id)
2531 set isbold 0
2532 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
2533 foreach f $info ty $fldtypes {
2534 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
2535 [doesmatch $f]} {
2536 if {$ty eq [mc "Author"]} {
2537 set isbold 2
2538 break
2540 set isbold 1
2543 if {$isbold && [info exists iddrawn($id)]} {
2544 if {![ishighlighted $row]} {
2545 bolden $row mainfontbold
2546 if {$isbold > 1} {
2547 bolden_name $row mainfontbold
2550 if {$markingmatches} {
2551 markrowmatches $row $id
2554 set nhighlights($row) $isbold
2557 proc markrowmatches {row id} {
2558 global canv canv2 linehtag linentag commitinfo findloc
2560 set headline [lindex $commitinfo($id) 0]
2561 set author [lindex $commitinfo($id) 1]
2562 $canv delete match$row
2563 $canv2 delete match$row
2564 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
2565 set m [findmatches $headline]
2566 if {$m ne {}} {
2567 markmatches $canv $row $headline $linehtag($row) $m \
2568 [$canv itemcget $linehtag($row) -font] $row
2571 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
2572 set m [findmatches $author]
2573 if {$m ne {}} {
2574 markmatches $canv2 $row $author $linentag($row) $m \
2575 [$canv2 itemcget $linentag($row) -font] $row
2580 proc vrel_change {name ix op} {
2581 global highlight_related
2583 rhighlight_none
2584 if {$highlight_related ne [mc "None"]} {
2585 run drawvisible
2589 # prepare for testing whether commits are descendents or ancestors of a
2590 proc rhighlight_sel {a} {
2591 global descendent desc_todo ancestor anc_todo
2592 global highlight_related rhighlights
2594 catch {unset descendent}
2595 set desc_todo [list $a]
2596 catch {unset ancestor}
2597 set anc_todo [list $a]
2598 if {$highlight_related ne [mc "None"]} {
2599 rhighlight_none
2600 run drawvisible
2604 proc rhighlight_none {} {
2605 global rhighlights
2607 catch {unset rhighlights}
2608 unbolden
2611 proc is_descendent {a} {
2612 global curview children commitrow descendent desc_todo
2614 set v $curview
2615 set la $commitrow($v,$a)
2616 set todo $desc_todo
2617 set leftover {}
2618 set done 0
2619 for {set i 0} {$i < [llength $todo]} {incr i} {
2620 set do [lindex $todo $i]
2621 if {$commitrow($v,$do) < $la} {
2622 lappend leftover $do
2623 continue
2625 foreach nk $children($v,$do) {
2626 if {![info exists descendent($nk)]} {
2627 set descendent($nk) 1
2628 lappend todo $nk
2629 if {$nk eq $a} {
2630 set done 1
2634 if {$done} {
2635 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2636 return
2639 set descendent($a) 0
2640 set desc_todo $leftover
2643 proc is_ancestor {a} {
2644 global curview parentlist commitrow ancestor anc_todo
2646 set v $curview
2647 set la $commitrow($v,$a)
2648 set todo $anc_todo
2649 set leftover {}
2650 set done 0
2651 for {set i 0} {$i < [llength $todo]} {incr i} {
2652 set do [lindex $todo $i]
2653 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2654 lappend leftover $do
2655 continue
2657 foreach np [lindex $parentlist $commitrow($v,$do)] {
2658 if {![info exists ancestor($np)]} {
2659 set ancestor($np) 1
2660 lappend todo $np
2661 if {$np eq $a} {
2662 set done 1
2666 if {$done} {
2667 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2668 return
2671 set ancestor($a) 0
2672 set anc_todo $leftover
2675 proc askrelhighlight {row id} {
2676 global descendent highlight_related iddrawn rhighlights
2677 global selectedline ancestor
2679 if {![info exists selectedline]} return
2680 set isbold 0
2681 if {$highlight_related eq [mc "Descendant"] ||
2682 $highlight_related eq [mc "Not descendant"]} {
2683 if {![info exists descendent($id)]} {
2684 is_descendent $id
2686 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
2687 set isbold 1
2689 } elseif {$highlight_related eq [mc "Ancestor"] ||
2690 $highlight_related eq [mc "Not ancestor"]} {
2691 if {![info exists ancestor($id)]} {
2692 is_ancestor $id
2694 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
2695 set isbold 1
2698 if {[info exists iddrawn($id)]} {
2699 if {$isbold && ![ishighlighted $row]} {
2700 bolden $row mainfontbold
2703 set rhighlights($row) $isbold
2706 # Graph layout functions
2708 proc shortids {ids} {
2709 set res {}
2710 foreach id $ids {
2711 if {[llength $id] > 1} {
2712 lappend res [shortids $id]
2713 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2714 lappend res [string range $id 0 7]
2715 } else {
2716 lappend res $id
2719 return $res
2722 proc ntimes {n o} {
2723 set ret {}
2724 set o [list $o]
2725 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2726 if {($n & $mask) != 0} {
2727 set ret [concat $ret $o]
2729 set o [concat $o $o]
2731 return $ret
2734 # Work out where id should go in idlist so that order-token
2735 # values increase from left to right
2736 proc idcol {idlist id {i 0}} {
2737 global ordertok curview
2739 set t $ordertok($curview,$id)
2740 if {$i >= [llength $idlist] ||
2741 $t < $ordertok($curview,[lindex $idlist $i])} {
2742 if {$i > [llength $idlist]} {
2743 set i [llength $idlist]
2745 while {[incr i -1] >= 0 &&
2746 $t < $ordertok($curview,[lindex $idlist $i])} {}
2747 incr i
2748 } else {
2749 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2750 while {[incr i] < [llength $idlist] &&
2751 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2754 return $i
2757 proc initlayout {} {
2758 global rowidlist rowisopt rowfinal displayorder commitlisted
2759 global numcommits canvxmax canv
2760 global nextcolor
2761 global parentlist
2762 global colormap rowtextx
2763 global selectfirst
2765 set numcommits 0
2766 set displayorder {}
2767 set commitlisted {}
2768 set parentlist {}
2769 set nextcolor 0
2770 set rowidlist {}
2771 set rowisopt {}
2772 set rowfinal {}
2773 set canvxmax [$canv cget -width]
2774 catch {unset colormap}
2775 catch {unset rowtextx}
2776 set selectfirst 1
2779 proc setcanvscroll {} {
2780 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2782 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2783 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2784 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2785 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2788 proc visiblerows {} {
2789 global canv numcommits linespc
2791 set ymax [lindex [$canv cget -scrollregion] 3]
2792 if {$ymax eq {} || $ymax == 0} return
2793 set f [$canv yview]
2794 set y0 [expr {int([lindex $f 0] * $ymax)}]
2795 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2796 if {$r0 < 0} {
2797 set r0 0
2799 set y1 [expr {int([lindex $f 1] * $ymax)}]
2800 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2801 if {$r1 >= $numcommits} {
2802 set r1 [expr {$numcommits - 1}]
2804 return [list $r0 $r1]
2807 proc layoutmore {} {
2808 global commitidx viewcomplete numcommits
2809 global uparrowlen downarrowlen mingaplen curview
2811 set show $commitidx($curview)
2812 if {$show > $numcommits || $viewcomplete($curview)} {
2813 showstuff $show $viewcomplete($curview)
2817 proc showstuff {canshow last} {
2818 global numcommits commitrow pending_select selectedline curview
2819 global mainheadid displayorder selectfirst
2820 global lastscrollset commitinterest
2822 if {$numcommits == 0} {
2823 global phase
2824 set phase "incrdraw"
2825 allcanvs delete all
2827 set r0 $numcommits
2828 set prev $numcommits
2829 set numcommits $canshow
2830 set t [clock clicks -milliseconds]
2831 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2832 set lastscrollset $t
2833 setcanvscroll
2835 set rows [visiblerows]
2836 set r1 [lindex $rows 1]
2837 if {$r1 >= $canshow} {
2838 set r1 [expr {$canshow - 1}]
2840 if {$r0 <= $r1} {
2841 drawcommits $r0 $r1
2843 if {[info exists pending_select] &&
2844 [info exists commitrow($curview,$pending_select)] &&
2845 $commitrow($curview,$pending_select) < $numcommits} {
2846 selectline $commitrow($curview,$pending_select) 1
2848 if {$selectfirst} {
2849 if {[info exists selectedline] || [info exists pending_select]} {
2850 set selectfirst 0
2851 } else {
2852 set l [first_real_row]
2853 selectline $l 1
2854 set selectfirst 0
2859 proc doshowlocalchanges {} {
2860 global curview mainheadid phase commitrow
2862 if {[info exists commitrow($curview,$mainheadid)] &&
2863 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2864 dodiffindex
2865 } elseif {$phase ne {}} {
2866 lappend commitinterest($mainheadid) {}
2870 proc dohidelocalchanges {} {
2871 global localfrow localirow lserial
2873 if {$localfrow >= 0} {
2874 removerow $localfrow
2875 set localfrow -1
2876 if {$localirow > 0} {
2877 incr localirow -1
2880 if {$localirow >= 0} {
2881 removerow $localirow
2882 set localirow -1
2884 incr lserial
2887 # spawn off a process to do git diff-index --cached HEAD
2888 proc dodiffindex {} {
2889 global localirow localfrow lserial showlocalchanges
2890 global isworktree
2892 if {!$showlocalchanges || !$isworktree} return
2893 incr lserial
2894 set localfrow -1
2895 set localirow -1
2896 set fd [open "|git diff-index --cached HEAD" r]
2897 fconfigure $fd -blocking 0
2898 filerun $fd [list readdiffindex $fd $lserial]
2901 proc readdiffindex {fd serial} {
2902 global localirow commitrow mainheadid nullid2 curview
2903 global commitinfo commitdata lserial
2905 set isdiff 1
2906 if {[gets $fd line] < 0} {
2907 if {![eof $fd]} {
2908 return 1
2910 set isdiff 0
2912 # we only need to see one line and we don't really care what it says...
2913 close $fd
2915 # now see if there are any local changes not checked in to the index
2916 if {$serial == $lserial} {
2917 set fd [open "|git diff-files" r]
2918 fconfigure $fd -blocking 0
2919 filerun $fd [list readdifffiles $fd $serial]
2922 if {$isdiff && $serial == $lserial && $localirow == -1} {
2923 # add the line for the changes in the index to the graph
2924 set localirow $commitrow($curview,$mainheadid)
2925 set hl [mc "Local changes checked in to index but not committed"]
2926 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2927 set commitdata($nullid2) "\n $hl\n"
2928 insertrow $localirow $nullid2
2930 return 0
2933 proc readdifffiles {fd serial} {
2934 global localirow localfrow commitrow mainheadid nullid curview
2935 global commitinfo commitdata lserial
2937 set isdiff 1
2938 if {[gets $fd line] < 0} {
2939 if {![eof $fd]} {
2940 return 1
2942 set isdiff 0
2944 # we only need to see one line and we don't really care what it says...
2945 close $fd
2947 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2948 # add the line for the local diff to the graph
2949 if {$localirow >= 0} {
2950 set localfrow $localirow
2951 incr localirow
2952 } else {
2953 set localfrow $commitrow($curview,$mainheadid)
2955 set hl [mc "Local uncommitted changes, not checked in to index"]
2956 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2957 set commitdata($nullid) "\n $hl\n"
2958 insertrow $localfrow $nullid
2960 return 0
2963 proc nextuse {id row} {
2964 global commitrow curview children
2966 if {[info exists children($curview,$id)]} {
2967 foreach kid $children($curview,$id) {
2968 if {![info exists commitrow($curview,$kid)]} {
2969 return -1
2971 if {$commitrow($curview,$kid) > $row} {
2972 return $commitrow($curview,$kid)
2976 if {[info exists commitrow($curview,$id)]} {
2977 return $commitrow($curview,$id)
2979 return -1
2982 proc prevuse {id row} {
2983 global commitrow curview children
2985 set ret -1
2986 if {[info exists children($curview,$id)]} {
2987 foreach kid $children($curview,$id) {
2988 if {![info exists commitrow($curview,$kid)]} break
2989 if {$commitrow($curview,$kid) < $row} {
2990 set ret $commitrow($curview,$kid)
2994 return $ret
2997 proc make_idlist {row} {
2998 global displayorder parentlist uparrowlen downarrowlen mingaplen
2999 global commitidx curview ordertok children commitrow
3001 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3002 if {$r < 0} {
3003 set r 0
3005 set ra [expr {$row - $downarrowlen}]
3006 if {$ra < 0} {
3007 set ra 0
3009 set rb [expr {$row + $uparrowlen}]
3010 if {$rb > $commitidx($curview)} {
3011 set rb $commitidx($curview)
3013 set ids {}
3014 for {} {$r < $ra} {incr r} {
3015 set nextid [lindex $displayorder [expr {$r + 1}]]
3016 foreach p [lindex $parentlist $r] {
3017 if {$p eq $nextid} continue
3018 set rn [nextuse $p $r]
3019 if {$rn >= $row &&
3020 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3021 lappend ids [list $ordertok($curview,$p) $p]
3025 for {} {$r < $row} {incr r} {
3026 set nextid [lindex $displayorder [expr {$r + 1}]]
3027 foreach p [lindex $parentlist $r] {
3028 if {$p eq $nextid} continue
3029 set rn [nextuse $p $r]
3030 if {$rn < 0 || $rn >= $row} {
3031 lappend ids [list $ordertok($curview,$p) $p]
3035 set id [lindex $displayorder $row]
3036 lappend ids [list $ordertok($curview,$id) $id]
3037 while {$r < $rb} {
3038 foreach p [lindex $parentlist $r] {
3039 set firstkid [lindex $children($curview,$p) 0]
3040 if {$commitrow($curview,$firstkid) < $row} {
3041 lappend ids [list $ordertok($curview,$p) $p]
3044 incr r
3045 set id [lindex $displayorder $r]
3046 if {$id ne {}} {
3047 set firstkid [lindex $children($curview,$id) 0]
3048 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3049 lappend ids [list $ordertok($curview,$id) $id]
3053 set idlist {}
3054 foreach idx [lsort -unique $ids] {
3055 lappend idlist [lindex $idx 1]
3057 return $idlist
3060 proc rowsequal {a b} {
3061 while {[set i [lsearch -exact $a {}]] >= 0} {
3062 set a [lreplace $a $i $i]
3064 while {[set i [lsearch -exact $b {}]] >= 0} {
3065 set b [lreplace $b $i $i]
3067 return [expr {$a eq $b}]
3070 proc makeupline {id row rend col} {
3071 global rowidlist uparrowlen downarrowlen mingaplen
3073 for {set r $rend} {1} {set r $rstart} {
3074 set rstart [prevuse $id $r]
3075 if {$rstart < 0} return
3076 if {$rstart < $row} break
3078 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3079 set rstart [expr {$rend - $uparrowlen - 1}]
3081 for {set r $rstart} {[incr r] <= $row} {} {
3082 set idlist [lindex $rowidlist $r]
3083 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3084 set col [idcol $idlist $id $col]
3085 lset rowidlist $r [linsert $idlist $col $id]
3086 changedrow $r
3091 proc layoutrows {row endrow} {
3092 global rowidlist rowisopt rowfinal displayorder
3093 global uparrowlen downarrowlen maxwidth mingaplen
3094 global children parentlist
3095 global commitidx viewcomplete curview commitrow
3097 set idlist {}
3098 if {$row > 0} {
3099 set rm1 [expr {$row - 1}]
3100 foreach id [lindex $rowidlist $rm1] {
3101 if {$id ne {}} {
3102 lappend idlist $id
3105 set final [lindex $rowfinal $rm1]
3107 for {} {$row < $endrow} {incr row} {
3108 set rm1 [expr {$row - 1}]
3109 if {$rm1 < 0 || $idlist eq {}} {
3110 set idlist [make_idlist $row]
3111 set final 1
3112 } else {
3113 set id [lindex $displayorder $rm1]
3114 set col [lsearch -exact $idlist $id]
3115 set idlist [lreplace $idlist $col $col]
3116 foreach p [lindex $parentlist $rm1] {
3117 if {[lsearch -exact $idlist $p] < 0} {
3118 set col [idcol $idlist $p $col]
3119 set idlist [linsert $idlist $col $p]
3120 # if not the first child, we have to insert a line going up
3121 if {$id ne [lindex $children($curview,$p) 0]} {
3122 makeupline $p $rm1 $row $col
3126 set id [lindex $displayorder $row]
3127 if {$row > $downarrowlen} {
3128 set termrow [expr {$row - $downarrowlen - 1}]
3129 foreach p [lindex $parentlist $termrow] {
3130 set i [lsearch -exact $idlist $p]
3131 if {$i < 0} continue
3132 set nr [nextuse $p $termrow]
3133 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3134 set idlist [lreplace $idlist $i $i]
3138 set col [lsearch -exact $idlist $id]
3139 if {$col < 0} {
3140 set col [idcol $idlist $id]
3141 set idlist [linsert $idlist $col $id]
3142 if {$children($curview,$id) ne {}} {
3143 makeupline $id $rm1 $row $col
3146 set r [expr {$row + $uparrowlen - 1}]
3147 if {$r < $commitidx($curview)} {
3148 set x $col
3149 foreach p [lindex $parentlist $r] {
3150 if {[lsearch -exact $idlist $p] >= 0} continue
3151 set fk [lindex $children($curview,$p) 0]
3152 if {$commitrow($curview,$fk) < $row} {
3153 set x [idcol $idlist $p $x]
3154 set idlist [linsert $idlist $x $p]
3157 if {[incr r] < $commitidx($curview)} {
3158 set p [lindex $displayorder $r]
3159 if {[lsearch -exact $idlist $p] < 0} {
3160 set fk [lindex $children($curview,$p) 0]
3161 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3162 set x [idcol $idlist $p $x]
3163 set idlist [linsert $idlist $x $p]
3169 if {$final && !$viewcomplete($curview) &&
3170 $row + $uparrowlen + $mingaplen + $downarrowlen
3171 >= $commitidx($curview)} {
3172 set final 0
3174 set l [llength $rowidlist]
3175 if {$row == $l} {
3176 lappend rowidlist $idlist
3177 lappend rowisopt 0
3178 lappend rowfinal $final
3179 } elseif {$row < $l} {
3180 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3181 lset rowidlist $row $idlist
3182 changedrow $row
3184 lset rowfinal $row $final
3185 } else {
3186 set pad [ntimes [expr {$row - $l}] {}]
3187 set rowidlist [concat $rowidlist $pad]
3188 lappend rowidlist $idlist
3189 set rowfinal [concat $rowfinal $pad]
3190 lappend rowfinal $final
3191 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3194 return $row
3197 proc changedrow {row} {
3198 global displayorder iddrawn rowisopt need_redisplay
3200 set l [llength $rowisopt]
3201 if {$row < $l} {
3202 lset rowisopt $row 0
3203 if {$row + 1 < $l} {
3204 lset rowisopt [expr {$row + 1}] 0
3205 if {$row + 2 < $l} {
3206 lset rowisopt [expr {$row + 2}] 0
3210 set id [lindex $displayorder $row]
3211 if {[info exists iddrawn($id)]} {
3212 set need_redisplay 1
3216 proc insert_pad {row col npad} {
3217 global rowidlist
3219 set pad [ntimes $npad {}]
3220 set idlist [lindex $rowidlist $row]
3221 set bef [lrange $idlist 0 [expr {$col - 1}]]
3222 set aft [lrange $idlist $col end]
3223 set i [lsearch -exact $aft {}]
3224 if {$i > 0} {
3225 set aft [lreplace $aft $i $i]
3227 lset rowidlist $row [concat $bef $pad $aft]
3228 changedrow $row
3231 proc optimize_rows {row col endrow} {
3232 global rowidlist rowisopt displayorder curview children
3234 if {$row < 1} {
3235 set row 1
3237 for {} {$row < $endrow} {incr row; set col 0} {
3238 if {[lindex $rowisopt $row]} continue
3239 set haspad 0
3240 set y0 [expr {$row - 1}]
3241 set ym [expr {$row - 2}]
3242 set idlist [lindex $rowidlist $row]
3243 set previdlist [lindex $rowidlist $y0]
3244 if {$idlist eq {} || $previdlist eq {}} continue
3245 if {$ym >= 0} {
3246 set pprevidlist [lindex $rowidlist $ym]
3247 if {$pprevidlist eq {}} continue
3248 } else {
3249 set pprevidlist {}
3251 set x0 -1
3252 set xm -1
3253 for {} {$col < [llength $idlist]} {incr col} {
3254 set id [lindex $idlist $col]
3255 if {[lindex $previdlist $col] eq $id} continue
3256 if {$id eq {}} {
3257 set haspad 1
3258 continue
3260 set x0 [lsearch -exact $previdlist $id]
3261 if {$x0 < 0} continue
3262 set z [expr {$x0 - $col}]
3263 set isarrow 0
3264 set z0 {}
3265 if {$ym >= 0} {
3266 set xm [lsearch -exact $pprevidlist $id]
3267 if {$xm >= 0} {
3268 set z0 [expr {$xm - $x0}]
3271 if {$z0 eq {}} {
3272 # if row y0 is the first child of $id then it's not an arrow
3273 if {[lindex $children($curview,$id) 0] ne
3274 [lindex $displayorder $y0]} {
3275 set isarrow 1
3278 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3279 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3280 set isarrow 1
3282 # Looking at lines from this row to the previous row,
3283 # make them go straight up if they end in an arrow on
3284 # the previous row; otherwise make them go straight up
3285 # or at 45 degrees.
3286 if {$z < -1 || ($z < 0 && $isarrow)} {
3287 # Line currently goes left too much;
3288 # insert pads in the previous row, then optimize it
3289 set npad [expr {-1 - $z + $isarrow}]
3290 insert_pad $y0 $x0 $npad
3291 if {$y0 > 0} {
3292 optimize_rows $y0 $x0 $row
3294 set previdlist [lindex $rowidlist $y0]
3295 set x0 [lsearch -exact $previdlist $id]
3296 set z [expr {$x0 - $col}]
3297 if {$z0 ne {}} {
3298 set pprevidlist [lindex $rowidlist $ym]
3299 set xm [lsearch -exact $pprevidlist $id]
3300 set z0 [expr {$xm - $x0}]
3302 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3303 # Line currently goes right too much;
3304 # insert pads in this line
3305 set npad [expr {$z - 1 + $isarrow}]
3306 insert_pad $row $col $npad
3307 set idlist [lindex $rowidlist $row]
3308 incr col $npad
3309 set z [expr {$x0 - $col}]
3310 set haspad 1
3312 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3313 # this line links to its first child on row $row-2
3314 set id [lindex $displayorder $ym]
3315 set xc [lsearch -exact $pprevidlist $id]
3316 if {$xc >= 0} {
3317 set z0 [expr {$xc - $x0}]
3320 # avoid lines jigging left then immediately right
3321 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3322 insert_pad $y0 $x0 1
3323 incr x0
3324 optimize_rows $y0 $x0 $row
3325 set previdlist [lindex $rowidlist $y0]
3328 if {!$haspad} {
3329 # Find the first column that doesn't have a line going right
3330 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3331 set id [lindex $idlist $col]
3332 if {$id eq {}} break
3333 set x0 [lsearch -exact $previdlist $id]
3334 if {$x0 < 0} {
3335 # check if this is the link to the first child
3336 set kid [lindex $displayorder $y0]
3337 if {[lindex $children($curview,$id) 0] eq $kid} {
3338 # it is, work out offset to child
3339 set x0 [lsearch -exact $previdlist $kid]
3342 if {$x0 <= $col} break
3344 # Insert a pad at that column as long as it has a line and
3345 # isn't the last column
3346 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3347 set idlist [linsert $idlist $col {}]
3348 lset rowidlist $row $idlist
3349 changedrow $row
3355 proc xc {row col} {
3356 global canvx0 linespc
3357 return [expr {$canvx0 + $col * $linespc}]
3360 proc yc {row} {
3361 global canvy0 linespc
3362 return [expr {$canvy0 + $row * $linespc}]
3365 proc linewidth {id} {
3366 global thickerline lthickness
3368 set wid $lthickness
3369 if {[info exists thickerline] && $id eq $thickerline} {
3370 set wid [expr {2 * $lthickness}]
3372 return $wid
3375 proc rowranges {id} {
3376 global commitrow curview children uparrowlen downarrowlen
3377 global rowidlist
3379 set kids $children($curview,$id)
3380 if {$kids eq {}} {
3381 return {}
3383 set ret {}
3384 lappend kids $id
3385 foreach child $kids {
3386 if {![info exists commitrow($curview,$child)]} break
3387 set row $commitrow($curview,$child)
3388 if {![info exists prev]} {
3389 lappend ret [expr {$row + 1}]
3390 } else {
3391 if {$row <= $prevrow} {
3392 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3394 # see if the line extends the whole way from prevrow to row
3395 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3396 [lsearch -exact [lindex $rowidlist \
3397 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3398 # it doesn't, see where it ends
3399 set r [expr {$prevrow + $downarrowlen}]
3400 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3401 while {[incr r -1] > $prevrow &&
3402 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3403 } else {
3404 while {[incr r] <= $row &&
3405 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3406 incr r -1
3408 lappend ret $r
3409 # see where it starts up again
3410 set r [expr {$row - $uparrowlen}]
3411 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3412 while {[incr r] < $row &&
3413 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3414 } else {
3415 while {[incr r -1] >= $prevrow &&
3416 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3417 incr r
3419 lappend ret $r
3422 if {$child eq $id} {
3423 lappend ret $row
3425 set prev $id
3426 set prevrow $row
3428 return $ret
3431 proc drawlineseg {id row endrow arrowlow} {
3432 global rowidlist displayorder iddrawn linesegs
3433 global canv colormap linespc curview maxlinelen parentlist
3435 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3436 set le [expr {$row + 1}]
3437 set arrowhigh 1
3438 while {1} {
3439 set c [lsearch -exact [lindex $rowidlist $le] $id]
3440 if {$c < 0} {
3441 incr le -1
3442 break
3444 lappend cols $c
3445 set x [lindex $displayorder $le]
3446 if {$x eq $id} {
3447 set arrowhigh 0
3448 break
3450 if {[info exists iddrawn($x)] || $le == $endrow} {
3451 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3452 if {$c >= 0} {
3453 lappend cols $c
3454 set arrowhigh 0
3456 break
3458 incr le
3460 if {$le <= $row} {
3461 return $row
3464 set lines {}
3465 set i 0
3466 set joinhigh 0
3467 if {[info exists linesegs($id)]} {
3468 set lines $linesegs($id)
3469 foreach li $lines {
3470 set r0 [lindex $li 0]
3471 if {$r0 > $row} {
3472 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3473 set joinhigh 1
3475 break
3477 incr i
3480 set joinlow 0
3481 if {$i > 0} {
3482 set li [lindex $lines [expr {$i-1}]]
3483 set r1 [lindex $li 1]
3484 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3485 set joinlow 1
3489 set x [lindex $cols [expr {$le - $row}]]
3490 set xp [lindex $cols [expr {$le - 1 - $row}]]
3491 set dir [expr {$xp - $x}]
3492 if {$joinhigh} {
3493 set ith [lindex $lines $i 2]
3494 set coords [$canv coords $ith]
3495 set ah [$canv itemcget $ith -arrow]
3496 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3497 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3498 if {$x2 ne {} && $x - $x2 == $dir} {
3499 set coords [lrange $coords 0 end-2]
3501 } else {
3502 set coords [list [xc $le $x] [yc $le]]
3504 if {$joinlow} {
3505 set itl [lindex $lines [expr {$i-1}] 2]
3506 set al [$canv itemcget $itl -arrow]
3507 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3508 } elseif {$arrowlow} {
3509 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3510 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3511 set arrowlow 0
3514 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3515 for {set y $le} {[incr y -1] > $row} {} {
3516 set x $xp
3517 set xp [lindex $cols [expr {$y - 1 - $row}]]
3518 set ndir [expr {$xp - $x}]
3519 if {$dir != $ndir || $xp < 0} {
3520 lappend coords [xc $y $x] [yc $y]
3522 set dir $ndir
3524 if {!$joinlow} {
3525 if {$xp < 0} {
3526 # join parent line to first child
3527 set ch [lindex $displayorder $row]
3528 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3529 if {$xc < 0} {
3530 puts "oops: drawlineseg: child $ch not on row $row"
3531 } elseif {$xc != $x} {
3532 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3533 set d [expr {int(0.5 * $linespc)}]
3534 set x1 [xc $row $x]
3535 if {$xc < $x} {
3536 set x2 [expr {$x1 - $d}]
3537 } else {
3538 set x2 [expr {$x1 + $d}]
3540 set y2 [yc $row]
3541 set y1 [expr {$y2 + $d}]
3542 lappend coords $x1 $y1 $x2 $y2
3543 } elseif {$xc < $x - 1} {
3544 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3545 } elseif {$xc > $x + 1} {
3546 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3548 set x $xc
3550 lappend coords [xc $row $x] [yc $row]
3551 } else {
3552 set xn [xc $row $xp]
3553 set yn [yc $row]
3554 lappend coords $xn $yn
3556 if {!$joinhigh} {
3557 assigncolor $id
3558 set t [$canv create line $coords -width [linewidth $id] \
3559 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3560 $canv lower $t
3561 bindline $t $id
3562 set lines [linsert $lines $i [list $row $le $t]]
3563 } else {
3564 $canv coords $ith $coords
3565 if {$arrow ne $ah} {
3566 $canv itemconf $ith -arrow $arrow
3568 lset lines $i 0 $row
3570 } else {
3571 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3572 set ndir [expr {$xo - $xp}]
3573 set clow [$canv coords $itl]
3574 if {$dir == $ndir} {
3575 set clow [lrange $clow 2 end]
3577 set coords [concat $coords $clow]
3578 if {!$joinhigh} {
3579 lset lines [expr {$i-1}] 1 $le
3580 } else {
3581 # coalesce two pieces
3582 $canv delete $ith
3583 set b [lindex $lines [expr {$i-1}] 0]
3584 set e [lindex $lines $i 1]
3585 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3587 $canv coords $itl $coords
3588 if {$arrow ne $al} {
3589 $canv itemconf $itl -arrow $arrow
3593 set linesegs($id) $lines
3594 return $le
3597 proc drawparentlinks {id row} {
3598 global rowidlist canv colormap curview parentlist
3599 global idpos linespc
3601 set rowids [lindex $rowidlist $row]
3602 set col [lsearch -exact $rowids $id]
3603 if {$col < 0} return
3604 set olds [lindex $parentlist $row]
3605 set row2 [expr {$row + 1}]
3606 set x [xc $row $col]
3607 set y [yc $row]
3608 set y2 [yc $row2]
3609 set d [expr {int(0.5 * $linespc)}]
3610 set ymid [expr {$y + $d}]
3611 set ids [lindex $rowidlist $row2]
3612 # rmx = right-most X coord used
3613 set rmx 0
3614 foreach p $olds {
3615 set i [lsearch -exact $ids $p]
3616 if {$i < 0} {
3617 puts "oops, parent $p of $id not in list"
3618 continue
3620 set x2 [xc $row2 $i]
3621 if {$x2 > $rmx} {
3622 set rmx $x2
3624 set j [lsearch -exact $rowids $p]
3625 if {$j < 0} {
3626 # drawlineseg will do this one for us
3627 continue
3629 assigncolor $p
3630 # should handle duplicated parents here...
3631 set coords [list $x $y]
3632 if {$i != $col} {
3633 # if attaching to a vertical segment, draw a smaller
3634 # slant for visual distinctness
3635 if {$i == $j} {
3636 if {$i < $col} {
3637 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3638 } else {
3639 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3641 } elseif {$i < $col && $i < $j} {
3642 # segment slants towards us already
3643 lappend coords [xc $row $j] $y
3644 } else {
3645 if {$i < $col - 1} {
3646 lappend coords [expr {$x2 + $linespc}] $y
3647 } elseif {$i > $col + 1} {
3648 lappend coords [expr {$x2 - $linespc}] $y
3650 lappend coords $x2 $y2
3652 } else {
3653 lappend coords $x2 $y2
3655 set t [$canv create line $coords -width [linewidth $p] \
3656 -fill $colormap($p) -tags lines.$p]
3657 $canv lower $t
3658 bindline $t $p
3660 if {$rmx > [lindex $idpos($id) 1]} {
3661 lset idpos($id) 1 $rmx
3662 redrawtags $id
3666 proc drawlines {id} {
3667 global canv
3669 $canv itemconf lines.$id -width [linewidth $id]
3672 proc drawcmittext {id row col} {
3673 global linespc canv canv2 canv3 canvy0 fgcolor curview
3674 global commitlisted commitinfo rowidlist parentlist
3675 global rowtextx idpos idtags idheads idotherrefs
3676 global linehtag linentag linedtag selectedline
3677 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3679 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3680 set listed [lindex $commitlisted $row]
3681 if {$id eq $nullid} {
3682 set ofill red
3683 } elseif {$id eq $nullid2} {
3684 set ofill green
3685 } else {
3686 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
3688 set x [xc $row $col]
3689 set y [yc $row]
3690 set orad [expr {$linespc / 3}]
3691 if {$listed <= 2} {
3692 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3693 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3694 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3695 } elseif {$listed == 3} {
3696 # triangle pointing left for left-side commits
3697 set t [$canv create polygon \
3698 [expr {$x - $orad}] $y \
3699 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3700 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3701 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3702 } else {
3703 # triangle pointing right for right-side commits
3704 set t [$canv create polygon \
3705 [expr {$x + $orad - 1}] $y \
3706 [expr {$x - $orad}] [expr {$y - $orad}] \
3707 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3708 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3710 $canv raise $t
3711 $canv bind $t <1> {selcanvline {} %x %y}
3712 set rmx [llength [lindex $rowidlist $row]]
3713 set olds [lindex $parentlist $row]
3714 if {$olds ne {}} {
3715 set nextids [lindex $rowidlist [expr {$row + 1}]]
3716 foreach p $olds {
3717 set i [lsearch -exact $nextids $p]
3718 if {$i > $rmx} {
3719 set rmx $i
3723 set xt [xc $row $rmx]
3724 set rowtextx($row) $xt
3725 set idpos($id) [list $x $xt $y]
3726 if {[info exists idtags($id)] || [info exists idheads($id)]
3727 || [info exists idotherrefs($id)]} {
3728 set xt [drawtags $id $x $xt $y]
3730 set headline [lindex $commitinfo($id) 0]
3731 set name [lindex $commitinfo($id) 1]
3732 set date [lindex $commitinfo($id) 2]
3733 set date [formatdate $date]
3734 set font mainfont
3735 set nfont mainfont
3736 set isbold [ishighlighted $row]
3737 if {$isbold > 0} {
3738 lappend boldrows $row
3739 set font mainfontbold
3740 if {$isbold > 1} {
3741 lappend boldnamerows $row
3742 set nfont mainfontbold
3745 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3746 -text $headline -font $font -tags text]
3747 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3748 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3749 -text $name -font $nfont -tags text]
3750 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3751 -text $date -font mainfont -tags text]
3752 if {[info exists selectedline] && $selectedline == $row} {
3753 make_secsel $row
3755 set xr [expr {$xt + [font measure $font $headline]}]
3756 if {$xr > $canvxmax} {
3757 set canvxmax $xr
3758 setcanvscroll
3762 proc drawcmitrow {row} {
3763 global displayorder rowidlist nrows_drawn
3764 global iddrawn markingmatches
3765 global commitinfo parentlist numcommits
3766 global filehighlight fhighlights findpattern nhighlights
3767 global hlview vhighlights
3768 global highlight_related rhighlights
3770 if {$row >= $numcommits} return
3772 set id [lindex $displayorder $row]
3773 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3774 askvhighlight $row $id
3776 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3777 askfilehighlight $row $id
3779 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3780 askfindhighlight $row $id
3782 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($row)]} {
3783 askrelhighlight $row $id
3785 if {![info exists iddrawn($id)]} {
3786 set col [lsearch -exact [lindex $rowidlist $row] $id]
3787 if {$col < 0} {
3788 puts "oops, row $row id $id not in list"
3789 return
3791 if {![info exists commitinfo($id)]} {
3792 getcommit $id
3794 assigncolor $id
3795 drawcmittext $id $row $col
3796 set iddrawn($id) 1
3797 incr nrows_drawn
3799 if {$markingmatches} {
3800 markrowmatches $row $id
3804 proc drawcommits {row {endrow {}}} {
3805 global numcommits iddrawn displayorder curview need_redisplay
3806 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3808 if {$row < 0} {
3809 set row 0
3811 if {$endrow eq {}} {
3812 set endrow $row
3814 if {$endrow >= $numcommits} {
3815 set endrow [expr {$numcommits - 1}]
3818 set rl1 [expr {$row - $downarrowlen - 3}]
3819 if {$rl1 < 0} {
3820 set rl1 0
3822 set ro1 [expr {$row - 3}]
3823 if {$ro1 < 0} {
3824 set ro1 0
3826 set r2 [expr {$endrow + $uparrowlen + 3}]
3827 if {$r2 > $numcommits} {
3828 set r2 $numcommits
3830 for {set r $rl1} {$r < $r2} {incr r} {
3831 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3832 if {$rl1 < $r} {
3833 layoutrows $rl1 $r
3835 set rl1 [expr {$r + 1}]
3838 if {$rl1 < $r} {
3839 layoutrows $rl1 $r
3841 optimize_rows $ro1 0 $r2
3842 if {$need_redisplay || $nrows_drawn > 2000} {
3843 clear_display
3844 drawvisible
3847 # make the lines join to already-drawn rows either side
3848 set r [expr {$row - 1}]
3849 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3850 set r $row
3852 set er [expr {$endrow + 1}]
3853 if {$er >= $numcommits ||
3854 ![info exists iddrawn([lindex $displayorder $er])]} {
3855 set er $endrow
3857 for {} {$r <= $er} {incr r} {
3858 set id [lindex $displayorder $r]
3859 set wasdrawn [info exists iddrawn($id)]
3860 drawcmitrow $r
3861 if {$r == $er} break
3862 set nextid [lindex $displayorder [expr {$r + 1}]]
3863 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
3864 drawparentlinks $id $r
3866 set rowids [lindex $rowidlist $r]
3867 foreach lid $rowids {
3868 if {$lid eq {}} continue
3869 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
3870 if {$lid eq $id} {
3871 # see if this is the first child of any of its parents
3872 foreach p [lindex $parentlist $r] {
3873 if {[lsearch -exact $rowids $p] < 0} {
3874 # make this line extend up to the child
3875 set lineend($p) [drawlineseg $p $r $er 0]
3878 } else {
3879 set lineend($lid) [drawlineseg $lid $r $er 1]
3885 proc drawfrac {f0 f1} {
3886 global canv linespc
3888 set ymax [lindex [$canv cget -scrollregion] 3]
3889 if {$ymax eq {} || $ymax == 0} return
3890 set y0 [expr {int($f0 * $ymax)}]
3891 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3892 set y1 [expr {int($f1 * $ymax)}]
3893 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3894 drawcommits $row $endrow
3897 proc drawvisible {} {
3898 global canv
3899 eval drawfrac [$canv yview]
3902 proc clear_display {} {
3903 global iddrawn linesegs need_redisplay nrows_drawn
3904 global vhighlights fhighlights nhighlights rhighlights
3906 allcanvs delete all
3907 catch {unset iddrawn}
3908 catch {unset linesegs}
3909 catch {unset vhighlights}
3910 catch {unset fhighlights}
3911 catch {unset nhighlights}
3912 catch {unset rhighlights}
3913 set need_redisplay 0
3914 set nrows_drawn 0
3917 proc findcrossings {id} {
3918 global rowidlist parentlist numcommits displayorder
3920 set cross {}
3921 set ccross {}
3922 foreach {s e} [rowranges $id] {
3923 if {$e >= $numcommits} {
3924 set e [expr {$numcommits - 1}]
3926 if {$e <= $s} continue
3927 for {set row $e} {[incr row -1] >= $s} {} {
3928 set x [lsearch -exact [lindex $rowidlist $row] $id]
3929 if {$x < 0} break
3930 set olds [lindex $parentlist $row]
3931 set kid [lindex $displayorder $row]
3932 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3933 if {$kidx < 0} continue
3934 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3935 foreach p $olds {
3936 set px [lsearch -exact $nextrow $p]
3937 if {$px < 0} continue
3938 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3939 if {[lsearch -exact $ccross $p] >= 0} continue
3940 if {$x == $px + ($kidx < $px? -1: 1)} {
3941 lappend ccross $p
3942 } elseif {[lsearch -exact $cross $p] < 0} {
3943 lappend cross $p
3949 return [concat $ccross {{}} $cross]
3952 proc assigncolor {id} {
3953 global colormap colors nextcolor
3954 global commitrow parentlist children children curview
3956 if {[info exists colormap($id)]} return
3957 set ncolors [llength $colors]
3958 if {[info exists children($curview,$id)]} {
3959 set kids $children($curview,$id)
3960 } else {
3961 set kids {}
3963 if {[llength $kids] == 1} {
3964 set child [lindex $kids 0]
3965 if {[info exists colormap($child)]
3966 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3967 set colormap($id) $colormap($child)
3968 return
3971 set badcolors {}
3972 set origbad {}
3973 foreach x [findcrossings $id] {
3974 if {$x eq {}} {
3975 # delimiter between corner crossings and other crossings
3976 if {[llength $badcolors] >= $ncolors - 1} break
3977 set origbad $badcolors
3979 if {[info exists colormap($x)]
3980 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3981 lappend badcolors $colormap($x)
3984 if {[llength $badcolors] >= $ncolors} {
3985 set badcolors $origbad
3987 set origbad $badcolors
3988 if {[llength $badcolors] < $ncolors - 1} {
3989 foreach child $kids {
3990 if {[info exists colormap($child)]
3991 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3992 lappend badcolors $colormap($child)
3994 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3995 if {[info exists colormap($p)]
3996 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3997 lappend badcolors $colormap($p)
4001 if {[llength $badcolors] >= $ncolors} {
4002 set badcolors $origbad
4005 for {set i 0} {$i <= $ncolors} {incr i} {
4006 set c [lindex $colors $nextcolor]
4007 if {[incr nextcolor] >= $ncolors} {
4008 set nextcolor 0
4010 if {[lsearch -exact $badcolors $c]} break
4012 set colormap($id) $c
4015 proc bindline {t id} {
4016 global canv
4018 $canv bind $t <Enter> "lineenter %x %y $id"
4019 $canv bind $t <Motion> "linemotion %x %y $id"
4020 $canv bind $t <Leave> "lineleave $id"
4021 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4024 proc drawtags {id x xt y1} {
4025 global idtags idheads idotherrefs mainhead
4026 global linespc lthickness
4027 global canv commitrow rowtextx curview fgcolor bgcolor
4029 set marks {}
4030 set ntags 0
4031 set nheads 0
4032 if {[info exists idtags($id)]} {
4033 set marks $idtags($id)
4034 set ntags [llength $marks]
4036 if {[info exists idheads($id)]} {
4037 set marks [concat $marks $idheads($id)]
4038 set nheads [llength $idheads($id)]
4040 if {[info exists idotherrefs($id)]} {
4041 set marks [concat $marks $idotherrefs($id)]
4043 if {$marks eq {}} {
4044 return $xt
4047 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4048 set yt [expr {$y1 - 0.5 * $linespc}]
4049 set yb [expr {$yt + $linespc - 1}]
4050 set xvals {}
4051 set wvals {}
4052 set i -1
4053 foreach tag $marks {
4054 incr i
4055 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4056 set wid [font measure mainfontbold $tag]
4057 } else {
4058 set wid [font measure mainfont $tag]
4060 lappend xvals $xt
4061 lappend wvals $wid
4062 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4064 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4065 -width $lthickness -fill black -tags tag.$id]
4066 $canv lower $t
4067 foreach tag $marks x $xvals wid $wvals {
4068 set xl [expr {$x + $delta}]
4069 set xr [expr {$x + $delta + $wid + $lthickness}]
4070 set font mainfont
4071 if {[incr ntags -1] >= 0} {
4072 # draw a tag
4073 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4074 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4075 -width 1 -outline black -fill yellow -tags tag.$id]
4076 $canv bind $t <1> [list showtag $tag 1]
4077 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4078 } else {
4079 # draw a head or other ref
4080 if {[incr nheads -1] >= 0} {
4081 set col green
4082 if {$tag eq $mainhead} {
4083 set font mainfontbold
4085 } else {
4086 set col "#ddddff"
4088 set xl [expr {$xl - $delta/2}]
4089 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4090 -width 1 -outline black -fill $col -tags tag.$id
4091 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4092 set rwid [font measure mainfont $remoteprefix]
4093 set xi [expr {$x + 1}]
4094 set yti [expr {$yt + 1}]
4095 set xri [expr {$x + $rwid}]
4096 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4097 -width 0 -fill "#ffddaa" -tags tag.$id
4100 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4101 -font $font -tags [list tag.$id text]]
4102 if {$ntags >= 0} {
4103 $canv bind $t <1> [list showtag $tag 1]
4104 } elseif {$nheads >= 0} {
4105 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4108 return $xt
4111 proc xcoord {i level ln} {
4112 global canvx0 xspc1 xspc2
4114 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4115 if {$i > 0 && $i == $level} {
4116 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4117 } elseif {$i > $level} {
4118 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4120 return $x
4123 proc show_status {msg} {
4124 global canv fgcolor
4126 clear_display
4127 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4128 -tags text -fill $fgcolor
4131 # Insert a new commit as the child of the commit on row $row.
4132 # The new commit will be displayed on row $row and the commits
4133 # on that row and below will move down one row.
4134 proc insertrow {row newcmit} {
4135 global displayorder parentlist commitlisted children
4136 global commitrow curview rowidlist rowisopt rowfinal numcommits
4137 global numcommits
4138 global selectedline commitidx ordertok
4140 if {$row >= $numcommits} {
4141 puts "oops, inserting new row $row but only have $numcommits rows"
4142 return
4144 set p [lindex $displayorder $row]
4145 set displayorder [linsert $displayorder $row $newcmit]
4146 set parentlist [linsert $parentlist $row $p]
4147 set kids $children($curview,$p)
4148 lappend kids $newcmit
4149 set children($curview,$p) $kids
4150 set children($curview,$newcmit) {}
4151 set commitlisted [linsert $commitlisted $row 1]
4152 set l [llength $displayorder]
4153 for {set r $row} {$r < $l} {incr r} {
4154 set id [lindex $displayorder $r]
4155 set commitrow($curview,$id) $r
4157 incr commitidx($curview)
4158 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4160 if {$row < [llength $rowidlist]} {
4161 set idlist [lindex $rowidlist $row]
4162 if {$idlist ne {}} {
4163 if {[llength $kids] == 1} {
4164 set col [lsearch -exact $idlist $p]
4165 lset idlist $col $newcmit
4166 } else {
4167 set col [llength $idlist]
4168 lappend idlist $newcmit
4171 set rowidlist [linsert $rowidlist $row $idlist]
4172 set rowisopt [linsert $rowisopt $row 0]
4173 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4176 incr numcommits
4178 if {[info exists selectedline] && $selectedline >= $row} {
4179 incr selectedline
4181 redisplay
4184 # Remove a commit that was inserted with insertrow on row $row.
4185 proc removerow {row} {
4186 global displayorder parentlist commitlisted children
4187 global commitrow curview rowidlist rowisopt rowfinal numcommits
4188 global numcommits
4189 global linesegends selectedline commitidx
4191 if {$row >= $numcommits} {
4192 puts "oops, removing row $row but only have $numcommits rows"
4193 return
4195 set rp1 [expr {$row + 1}]
4196 set id [lindex $displayorder $row]
4197 set p [lindex $parentlist $row]
4198 set displayorder [lreplace $displayorder $row $row]
4199 set parentlist [lreplace $parentlist $row $row]
4200 set commitlisted [lreplace $commitlisted $row $row]
4201 set kids $children($curview,$p)
4202 set i [lsearch -exact $kids $id]
4203 if {$i >= 0} {
4204 set kids [lreplace $kids $i $i]
4205 set children($curview,$p) $kids
4207 set l [llength $displayorder]
4208 for {set r $row} {$r < $l} {incr r} {
4209 set id [lindex $displayorder $r]
4210 set commitrow($curview,$id) $r
4212 incr commitidx($curview) -1
4214 if {$row < [llength $rowidlist]} {
4215 set rowidlist [lreplace $rowidlist $row $row]
4216 set rowisopt [lreplace $rowisopt $row $row]
4217 set rowfinal [lreplace $rowfinal $row $row]
4220 incr numcommits -1
4222 if {[info exists selectedline] && $selectedline > $row} {
4223 incr selectedline -1
4225 redisplay
4228 # Don't change the text pane cursor if it is currently the hand cursor,
4229 # showing that we are over a sha1 ID link.
4230 proc settextcursor {c} {
4231 global ctext curtextcursor
4233 if {[$ctext cget -cursor] == $curtextcursor} {
4234 $ctext config -cursor $c
4236 set curtextcursor $c
4239 proc nowbusy {what {name {}}} {
4240 global isbusy busyname statusw
4242 if {[array names isbusy] eq {}} {
4243 . config -cursor watch
4244 settextcursor watch
4246 set isbusy($what) 1
4247 set busyname($what) $name
4248 if {$name ne {}} {
4249 $statusw conf -text $name
4253 proc notbusy {what} {
4254 global isbusy maincursor textcursor busyname statusw
4256 catch {
4257 unset isbusy($what)
4258 if {$busyname($what) ne {} &&
4259 [$statusw cget -text] eq $busyname($what)} {
4260 $statusw conf -text {}
4263 if {[array names isbusy] eq {}} {
4264 . config -cursor $maincursor
4265 settextcursor $textcursor
4269 proc findmatches {f} {
4270 global findtype findstring
4271 if {$findtype == [mc "Regexp"]} {
4272 set matches [regexp -indices -all -inline $findstring $f]
4273 } else {
4274 set fs $findstring
4275 if {$findtype == [mc "IgnCase"]} {
4276 set f [string tolower $f]
4277 set fs [string tolower $fs]
4279 set matches {}
4280 set i 0
4281 set l [string length $fs]
4282 while {[set j [string first $fs $f $i]] >= 0} {
4283 lappend matches [list $j [expr {$j+$l-1}]]
4284 set i [expr {$j + $l}]
4287 return $matches
4290 proc dofind {{dirn 1} {wrap 1}} {
4291 global findstring findstartline findcurline selectedline numcommits
4292 global gdttype filehighlight fh_serial find_dirn findallowwrap
4294 if {[info exists find_dirn]} {
4295 if {$find_dirn == $dirn} return
4296 stopfinding
4298 focus .
4299 if {$findstring eq {} || $numcommits == 0} return
4300 if {![info exists selectedline]} {
4301 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4302 } else {
4303 set findstartline $selectedline
4305 set findcurline $findstartline
4306 nowbusy finding [mc "Searching"]
4307 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
4308 after cancel do_file_hl $fh_serial
4309 do_file_hl $fh_serial
4311 set find_dirn $dirn
4312 set findallowwrap $wrap
4313 run findmore
4316 proc stopfinding {} {
4317 global find_dirn findcurline fprogcoord
4319 if {[info exists find_dirn]} {
4320 unset find_dirn
4321 unset findcurline
4322 notbusy finding
4323 set fprogcoord 0
4324 adjustprogress
4328 proc findmore {} {
4329 global commitdata commitinfo numcommits findpattern findloc
4330 global findstartline findcurline displayorder
4331 global find_dirn gdttype fhighlights fprogcoord
4332 global findallowwrap
4334 if {![info exists find_dirn]} {
4335 return 0
4337 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
4338 set l $findcurline
4339 set moretodo 0
4340 if {$find_dirn > 0} {
4341 incr l
4342 if {$l >= $numcommits} {
4343 set l 0
4345 if {$l <= $findstartline} {
4346 set lim [expr {$findstartline + 1}]
4347 } else {
4348 set lim $numcommits
4349 set moretodo $findallowwrap
4351 } else {
4352 if {$l == 0} {
4353 set l $numcommits
4355 incr l -1
4356 if {$l >= $findstartline} {
4357 set lim [expr {$findstartline - 1}]
4358 } else {
4359 set lim -1
4360 set moretodo $findallowwrap
4363 set n [expr {($lim - $l) * $find_dirn}]
4364 if {$n > 500} {
4365 set n 500
4366 set moretodo 1
4368 set found 0
4369 set domore 1
4370 if {$gdttype eq [mc "containing:"]} {
4371 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4372 set id [lindex $displayorder $l]
4373 # shouldn't happen unless git log doesn't give all the commits...
4374 if {![info exists commitdata($id)]} continue
4375 if {![doesmatch $commitdata($id)]} continue
4376 if {![info exists commitinfo($id)]} {
4377 getcommit $id
4379 set info $commitinfo($id)
4380 foreach f $info ty $fldtypes {
4381 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4382 [doesmatch $f]} {
4383 set found 1
4384 break
4387 if {$found} break
4389 } else {
4390 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4391 set id [lindex $displayorder $l]
4392 if {![info exists fhighlights($l)]} {
4393 askfilehighlight $l $id
4394 if {$domore} {
4395 set domore 0
4396 set findcurline [expr {$l - $find_dirn}]
4398 } elseif {$fhighlights($l)} {
4399 set found $domore
4400 break
4404 if {$found || ($domore && !$moretodo)} {
4405 unset findcurline
4406 unset find_dirn
4407 notbusy finding
4408 set fprogcoord 0
4409 adjustprogress
4410 if {$found} {
4411 findselectline $l
4412 } else {
4413 bell
4415 return 0
4417 if {!$domore} {
4418 flushhighlights
4419 } else {
4420 set findcurline [expr {$l - $find_dirn}]
4422 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4423 if {$n < 0} {
4424 incr n $numcommits
4426 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4427 adjustprogress
4428 return $domore
4431 proc findselectline {l} {
4432 global findloc commentend ctext findcurline markingmatches gdttype
4434 set markingmatches 1
4435 set findcurline $l
4436 selectline $l 1
4437 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
4438 # highlight the matches in the comments
4439 set f [$ctext get 1.0 $commentend]
4440 set matches [findmatches $f]
4441 foreach match $matches {
4442 set start [lindex $match 0]
4443 set end [expr {[lindex $match 1] + 1}]
4444 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4447 drawvisible
4450 # mark the bits of a headline or author that match a find string
4451 proc markmatches {canv l str tag matches font row} {
4452 global selectedline
4454 set bbox [$canv bbox $tag]
4455 set x0 [lindex $bbox 0]
4456 set y0 [lindex $bbox 1]
4457 set y1 [lindex $bbox 3]
4458 foreach match $matches {
4459 set start [lindex $match 0]
4460 set end [lindex $match 1]
4461 if {$start > $end} continue
4462 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4463 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4464 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4465 [expr {$x0+$xlen+2}] $y1 \
4466 -outline {} -tags [list match$l matches] -fill yellow]
4467 $canv lower $t
4468 if {[info exists selectedline] && $row == $selectedline} {
4469 $canv raise $t secsel
4474 proc unmarkmatches {} {
4475 global markingmatches
4477 allcanvs delete matches
4478 set markingmatches 0
4479 stopfinding
4482 proc selcanvline {w x y} {
4483 global canv canvy0 ctext linespc
4484 global rowtextx
4485 set ymax [lindex [$canv cget -scrollregion] 3]
4486 if {$ymax == {}} return
4487 set yfrac [lindex [$canv yview] 0]
4488 set y [expr {$y + $yfrac * $ymax}]
4489 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4490 if {$l < 0} {
4491 set l 0
4493 if {$w eq $canv} {
4494 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4496 unmarkmatches
4497 selectline $l 1
4500 proc commit_descriptor {p} {
4501 global commitinfo
4502 if {![info exists commitinfo($p)]} {
4503 getcommit $p
4505 set l "..."
4506 if {[llength $commitinfo($p)] > 1} {
4507 set l [lindex $commitinfo($p) 0]
4509 return "$p ($l)\n"
4512 # append some text to the ctext widget, and make any SHA1 ID
4513 # that we know about be a clickable link.
4514 proc appendwithlinks {text tags} {
4515 global ctext commitrow linknum curview pendinglinks
4517 set start [$ctext index "end - 1c"]
4518 $ctext insert end $text $tags
4519 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4520 foreach l $links {
4521 set s [lindex $l 0]
4522 set e [lindex $l 1]
4523 set linkid [string range $text $s $e]
4524 incr e
4525 $ctext tag delete link$linknum
4526 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4527 setlink $linkid link$linknum
4528 incr linknum
4532 proc setlink {id lk} {
4533 global curview commitrow ctext pendinglinks commitinterest
4535 if {[info exists commitrow($curview,$id)]} {
4536 $ctext tag conf $lk -foreground blue -underline 1
4537 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4538 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4539 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4540 } else {
4541 lappend pendinglinks($id) $lk
4542 lappend commitinterest($id) {makelink %I}
4546 proc makelink {id} {
4547 global pendinglinks
4549 if {![info exists pendinglinks($id)]} return
4550 foreach lk $pendinglinks($id) {
4551 setlink $id $lk
4553 unset pendinglinks($id)
4556 proc linkcursor {w inc} {
4557 global linkentercount curtextcursor
4559 if {[incr linkentercount $inc] > 0} {
4560 $w configure -cursor hand2
4561 } else {
4562 $w configure -cursor $curtextcursor
4563 if {$linkentercount < 0} {
4564 set linkentercount 0
4569 proc viewnextline {dir} {
4570 global canv linespc
4572 $canv delete hover
4573 set ymax [lindex [$canv cget -scrollregion] 3]
4574 set wnow [$canv yview]
4575 set wtop [expr {[lindex $wnow 0] * $ymax}]
4576 set newtop [expr {$wtop + $dir * $linespc}]
4577 if {$newtop < 0} {
4578 set newtop 0
4579 } elseif {$newtop > $ymax} {
4580 set newtop $ymax
4582 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4585 # add a list of tag or branch names at position pos
4586 # returns the number of names inserted
4587 proc appendrefs {pos ids var} {
4588 global ctext commitrow linknum curview $var maxrefs
4590 if {[catch {$ctext index $pos}]} {
4591 return 0
4593 $ctext conf -state normal
4594 $ctext delete $pos "$pos lineend"
4595 set tags {}
4596 foreach id $ids {
4597 foreach tag [set $var\($id\)] {
4598 lappend tags [list $tag $id]
4601 if {[llength $tags] > $maxrefs} {
4602 $ctext insert $pos "many ([llength $tags])"
4603 } else {
4604 set tags [lsort -index 0 -decreasing $tags]
4605 set sep {}
4606 foreach ti $tags {
4607 set id [lindex $ti 1]
4608 set lk link$linknum
4609 incr linknum
4610 $ctext tag delete $lk
4611 $ctext insert $pos $sep
4612 $ctext insert $pos [lindex $ti 0] $lk
4613 setlink $id $lk
4614 set sep ", "
4617 $ctext conf -state disabled
4618 return [llength $tags]
4621 # called when we have finished computing the nearby tags
4622 proc dispneartags {delay} {
4623 global selectedline currentid showneartags tagphase
4625 if {![info exists selectedline] || !$showneartags} return
4626 after cancel dispnexttag
4627 if {$delay} {
4628 after 200 dispnexttag
4629 set tagphase -1
4630 } else {
4631 after idle dispnexttag
4632 set tagphase 0
4636 proc dispnexttag {} {
4637 global selectedline currentid showneartags tagphase ctext
4639 if {![info exists selectedline] || !$showneartags} return
4640 switch -- $tagphase {
4642 set dtags [desctags $currentid]
4643 if {$dtags ne {}} {
4644 appendrefs precedes $dtags idtags
4648 set atags [anctags $currentid]
4649 if {$atags ne {}} {
4650 appendrefs follows $atags idtags
4654 set dheads [descheads $currentid]
4655 if {$dheads ne {}} {
4656 if {[appendrefs branch $dheads idheads] > 1
4657 && [$ctext get "branch -3c"] eq "h"} {
4658 # turn "Branch" into "Branches"
4659 $ctext conf -state normal
4660 $ctext insert "branch -2c" "es"
4661 $ctext conf -state disabled
4666 if {[incr tagphase] <= 2} {
4667 after idle dispnexttag
4671 proc make_secsel {l} {
4672 global linehtag linentag linedtag canv canv2 canv3
4674 if {![info exists linehtag($l)]} return
4675 $canv delete secsel
4676 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4677 -tags secsel -fill [$canv cget -selectbackground]]
4678 $canv lower $t
4679 $canv2 delete secsel
4680 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4681 -tags secsel -fill [$canv2 cget -selectbackground]]
4682 $canv2 lower $t
4683 $canv3 delete secsel
4684 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4685 -tags secsel -fill [$canv3 cget -selectbackground]]
4686 $canv3 lower $t
4689 proc selectline {l isnew} {
4690 global canv ctext commitinfo selectedline
4691 global displayorder
4692 global canvy0 linespc parentlist children curview
4693 global currentid sha1entry
4694 global commentend idtags linknum
4695 global mergemax numcommits pending_select
4696 global cmitmode showneartags allcommits
4697 global autoselect
4699 catch {unset pending_select}
4700 $canv delete hover
4701 normalline
4702 unsel_reflist
4703 stopfinding
4704 if {$l < 0 || $l >= $numcommits} return
4705 set y [expr {$canvy0 + $l * $linespc}]
4706 set ymax [lindex [$canv cget -scrollregion] 3]
4707 set ytop [expr {$y - $linespc - 1}]
4708 set ybot [expr {$y + $linespc + 1}]
4709 set wnow [$canv yview]
4710 set wtop [expr {[lindex $wnow 0] * $ymax}]
4711 set wbot [expr {[lindex $wnow 1] * $ymax}]
4712 set wh [expr {$wbot - $wtop}]
4713 set newtop $wtop
4714 if {$ytop < $wtop} {
4715 if {$ybot < $wtop} {
4716 set newtop [expr {$y - $wh / 2.0}]
4717 } else {
4718 set newtop $ytop
4719 if {$newtop > $wtop - $linespc} {
4720 set newtop [expr {$wtop - $linespc}]
4723 } elseif {$ybot > $wbot} {
4724 if {$ytop > $wbot} {
4725 set newtop [expr {$y - $wh / 2.0}]
4726 } else {
4727 set newtop [expr {$ybot - $wh}]
4728 if {$newtop < $wtop + $linespc} {
4729 set newtop [expr {$wtop + $linespc}]
4733 if {$newtop != $wtop} {
4734 if {$newtop < 0} {
4735 set newtop 0
4737 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4738 drawvisible
4741 make_secsel $l
4743 if {$isnew} {
4744 addtohistory [list selectline $l 0]
4747 set selectedline $l
4749 set id [lindex $displayorder $l]
4750 set currentid $id
4751 $sha1entry delete 0 end
4752 $sha1entry insert 0 $id
4753 if {$autoselect} {
4754 $sha1entry selection from 0
4755 $sha1entry selection to end
4757 rhighlight_sel $id
4759 $ctext conf -state normal
4760 clear_ctext
4761 set linknum 0
4762 set info $commitinfo($id)
4763 set date [formatdate [lindex $info 2]]
4764 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
4765 set date [formatdate [lindex $info 4]]
4766 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
4767 if {[info exists idtags($id)]} {
4768 $ctext insert end [mc "Tags:"]
4769 foreach tag $idtags($id) {
4770 $ctext insert end " $tag"
4772 $ctext insert end "\n"
4775 set headers {}
4776 set olds [lindex $parentlist $l]
4777 if {[llength $olds] > 1} {
4778 set np 0
4779 foreach p $olds {
4780 if {$np >= $mergemax} {
4781 set tag mmax
4782 } else {
4783 set tag m$np
4785 $ctext insert end "[mc "Parent"]: " $tag
4786 appendwithlinks [commit_descriptor $p] {}
4787 incr np
4789 } else {
4790 foreach p $olds {
4791 append headers "[mc "Parent"]: [commit_descriptor $p]"
4795 foreach c $children($curview,$id) {
4796 append headers "[mc "Child"]: [commit_descriptor $c]"
4799 # make anything that looks like a SHA1 ID be a clickable link
4800 appendwithlinks $headers {}
4801 if {$showneartags} {
4802 if {![info exists allcommits]} {
4803 getallcommits
4805 $ctext insert end "[mc "Branch"]: "
4806 $ctext mark set branch "end -1c"
4807 $ctext mark gravity branch left
4808 $ctext insert end "\n[mc "Follows"]: "
4809 $ctext mark set follows "end -1c"
4810 $ctext mark gravity follows left
4811 $ctext insert end "\n[mc "Precedes"]: "
4812 $ctext mark set precedes "end -1c"
4813 $ctext mark gravity precedes left
4814 $ctext insert end "\n"
4815 dispneartags 1
4817 $ctext insert end "\n"
4818 set comment [lindex $info 5]
4819 if {[string first "\r" $comment] >= 0} {
4820 set comment [string map {"\r" "\n "} $comment]
4822 appendwithlinks $comment {comment}
4824 $ctext tag remove found 1.0 end
4825 $ctext conf -state disabled
4826 set commentend [$ctext index "end - 1c"]
4828 init_flist [mc "Comments"]
4829 if {$cmitmode eq "tree"} {
4830 gettree $id
4831 } elseif {[llength $olds] <= 1} {
4832 startdiff $id
4833 } else {
4834 mergediff $id $l
4838 proc selfirstline {} {
4839 unmarkmatches
4840 selectline 0 1
4843 proc sellastline {} {
4844 global numcommits
4845 unmarkmatches
4846 set l [expr {$numcommits - 1}]
4847 selectline $l 1
4850 proc selnextline {dir} {
4851 global selectedline
4852 focus .
4853 if {![info exists selectedline]} return
4854 set l [expr {$selectedline + $dir}]
4855 unmarkmatches
4856 selectline $l 1
4859 proc selnextpage {dir} {
4860 global canv linespc selectedline numcommits
4862 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4863 if {$lpp < 1} {
4864 set lpp 1
4866 allcanvs yview scroll [expr {$dir * $lpp}] units
4867 drawvisible
4868 if {![info exists selectedline]} return
4869 set l [expr {$selectedline + $dir * $lpp}]
4870 if {$l < 0} {
4871 set l 0
4872 } elseif {$l >= $numcommits} {
4873 set l [expr $numcommits - 1]
4875 unmarkmatches
4876 selectline $l 1
4879 proc unselectline {} {
4880 global selectedline currentid
4882 catch {unset selectedline}
4883 catch {unset currentid}
4884 allcanvs delete secsel
4885 rhighlight_none
4888 proc reselectline {} {
4889 global selectedline
4891 if {[info exists selectedline]} {
4892 selectline $selectedline 0
4896 proc addtohistory {cmd} {
4897 global history historyindex curview
4899 set elt [list $curview $cmd]
4900 if {$historyindex > 0
4901 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4902 return
4905 if {$historyindex < [llength $history]} {
4906 set history [lreplace $history $historyindex end $elt]
4907 } else {
4908 lappend history $elt
4910 incr historyindex
4911 if {$historyindex > 1} {
4912 .tf.bar.leftbut conf -state normal
4913 } else {
4914 .tf.bar.leftbut conf -state disabled
4916 .tf.bar.rightbut conf -state disabled
4919 proc godo {elt} {
4920 global curview
4922 set view [lindex $elt 0]
4923 set cmd [lindex $elt 1]
4924 if {$curview != $view} {
4925 showview $view
4927 eval $cmd
4930 proc goback {} {
4931 global history historyindex
4932 focus .
4934 if {$historyindex > 1} {
4935 incr historyindex -1
4936 godo [lindex $history [expr {$historyindex - 1}]]
4937 .tf.bar.rightbut conf -state normal
4939 if {$historyindex <= 1} {
4940 .tf.bar.leftbut conf -state disabled
4944 proc goforw {} {
4945 global history historyindex
4946 focus .
4948 if {$historyindex < [llength $history]} {
4949 set cmd [lindex $history $historyindex]
4950 incr historyindex
4951 godo $cmd
4952 .tf.bar.leftbut conf -state normal
4954 if {$historyindex >= [llength $history]} {
4955 .tf.bar.rightbut conf -state disabled
4959 proc gettree {id} {
4960 global treefilelist treeidlist diffids diffmergeid treepending
4961 global nullid nullid2
4963 set diffids $id
4964 catch {unset diffmergeid}
4965 if {![info exists treefilelist($id)]} {
4966 if {![info exists treepending]} {
4967 if {$id eq $nullid} {
4968 set cmd [list | git ls-files]
4969 } elseif {$id eq $nullid2} {
4970 set cmd [list | git ls-files --stage -t]
4971 } else {
4972 set cmd [list | git ls-tree -r $id]
4974 if {[catch {set gtf [open $cmd r]}]} {
4975 return
4977 set treepending $id
4978 set treefilelist($id) {}
4979 set treeidlist($id) {}
4980 fconfigure $gtf -blocking 0
4981 filerun $gtf [list gettreeline $gtf $id]
4983 } else {
4984 setfilelist $id
4988 proc gettreeline {gtf id} {
4989 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4991 set nl 0
4992 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4993 if {$diffids eq $nullid} {
4994 set fname $line
4995 } else {
4996 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4997 set i [string first "\t" $line]
4998 if {$i < 0} continue
4999 set sha1 [lindex $line 2]
5000 set fname [string range $line [expr {$i+1}] end]
5001 if {[string index $fname 0] eq "\""} {
5002 set fname [lindex $fname 0]
5004 lappend treeidlist($id) $sha1
5006 lappend treefilelist($id) $fname
5008 if {![eof $gtf]} {
5009 return [expr {$nl >= 1000? 2: 1}]
5011 close $gtf
5012 unset treepending
5013 if {$cmitmode ne "tree"} {
5014 if {![info exists diffmergeid]} {
5015 gettreediffs $diffids
5017 } elseif {$id ne $diffids} {
5018 gettree $diffids
5019 } else {
5020 setfilelist $id
5022 return 0
5025 proc showfile {f} {
5026 global treefilelist treeidlist diffids nullid nullid2
5027 global ctext commentend
5029 set i [lsearch -exact $treefilelist($diffids) $f]
5030 if {$i < 0} {
5031 puts "oops, $f not in list for id $diffids"
5032 return
5034 if {$diffids eq $nullid} {
5035 if {[catch {set bf [open $f r]} err]} {
5036 puts "oops, can't read $f: $err"
5037 return
5039 } else {
5040 set blob [lindex $treeidlist($diffids) $i]
5041 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5042 puts "oops, error reading blob $blob: $err"
5043 return
5046 fconfigure $bf -blocking 0
5047 filerun $bf [list getblobline $bf $diffids]
5048 $ctext config -state normal
5049 clear_ctext $commentend
5050 $ctext insert end "\n"
5051 $ctext insert end "$f\n" filesep
5052 $ctext config -state disabled
5053 $ctext yview $commentend
5054 settabs 0
5057 proc getblobline {bf id} {
5058 global diffids cmitmode ctext
5060 if {$id ne $diffids || $cmitmode ne "tree"} {
5061 catch {close $bf}
5062 return 0
5064 $ctext config -state normal
5065 set nl 0
5066 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5067 $ctext insert end "$line\n"
5069 if {[eof $bf]} {
5070 # delete last newline
5071 $ctext delete "end - 2c" "end - 1c"
5072 close $bf
5073 return 0
5075 $ctext config -state disabled
5076 return [expr {$nl >= 1000? 2: 1}]
5079 proc mergediff {id l} {
5080 global diffmergeid mdifffd
5081 global diffids
5082 global diffcontext
5083 global parentlist
5084 global limitdiffs viewfiles curview
5086 set diffmergeid $id
5087 set diffids $id
5088 # this doesn't seem to actually affect anything...
5089 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5090 if {$limitdiffs && $viewfiles($curview) ne {}} {
5091 set cmd [concat $cmd -- $viewfiles($curview)]
5093 if {[catch {set mdf [open $cmd r]} err]} {
5094 error_popup "[mc "Error getting merge diffs:"] $err"
5095 return
5097 fconfigure $mdf -blocking 0
5098 set mdifffd($id) $mdf
5099 set np [llength [lindex $parentlist $l]]
5100 settabs $np
5101 filerun $mdf [list getmergediffline $mdf $id $np]
5104 proc getmergediffline {mdf id np} {
5105 global diffmergeid ctext cflist mergemax
5106 global difffilestart mdifffd
5108 $ctext conf -state normal
5109 set nr 0
5110 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5111 if {![info exists diffmergeid] || $id != $diffmergeid
5112 || $mdf != $mdifffd($id)} {
5113 close $mdf
5114 return 0
5116 if {[regexp {^diff --cc (.*)} $line match fname]} {
5117 # start of a new file
5118 $ctext insert end "\n"
5119 set here [$ctext index "end - 1c"]
5120 lappend difffilestart $here
5121 add_flist [list $fname]
5122 set l [expr {(78 - [string length $fname]) / 2}]
5123 set pad [string range "----------------------------------------" 1 $l]
5124 $ctext insert end "$pad $fname $pad\n" filesep
5125 } elseif {[regexp {^@@} $line]} {
5126 $ctext insert end "$line\n" hunksep
5127 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5128 # do nothing
5129 } else {
5130 # parse the prefix - one ' ', '-' or '+' for each parent
5131 set spaces {}
5132 set minuses {}
5133 set pluses {}
5134 set isbad 0
5135 for {set j 0} {$j < $np} {incr j} {
5136 set c [string range $line $j $j]
5137 if {$c == " "} {
5138 lappend spaces $j
5139 } elseif {$c == "-"} {
5140 lappend minuses $j
5141 } elseif {$c == "+"} {
5142 lappend pluses $j
5143 } else {
5144 set isbad 1
5145 break
5148 set tags {}
5149 set num {}
5150 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5151 # line doesn't appear in result, parents in $minuses have the line
5152 set num [lindex $minuses 0]
5153 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5154 # line appears in result, parents in $pluses don't have the line
5155 lappend tags mresult
5156 set num [lindex $spaces 0]
5158 if {$num ne {}} {
5159 if {$num >= $mergemax} {
5160 set num "max"
5162 lappend tags m$num
5164 $ctext insert end "$line\n" $tags
5167 $ctext conf -state disabled
5168 if {[eof $mdf]} {
5169 close $mdf
5170 return 0
5172 return [expr {$nr >= 1000? 2: 1}]
5175 proc startdiff {ids} {
5176 global treediffs diffids treepending diffmergeid nullid nullid2
5178 settabs 1
5179 set diffids $ids
5180 catch {unset diffmergeid}
5181 if {![info exists treediffs($ids)] ||
5182 [lsearch -exact $ids $nullid] >= 0 ||
5183 [lsearch -exact $ids $nullid2] >= 0} {
5184 if {![info exists treepending]} {
5185 gettreediffs $ids
5187 } else {
5188 addtocflist $ids
5192 proc path_filter {filter name} {
5193 foreach p $filter {
5194 set l [string length $p]
5195 if {[string index $p end] eq "/"} {
5196 if {[string compare -length $l $p $name] == 0} {
5197 return 1
5199 } else {
5200 if {[string compare -length $l $p $name] == 0 &&
5201 ([string length $name] == $l ||
5202 [string index $name $l] eq "/")} {
5203 return 1
5207 return 0
5210 proc addtocflist {ids} {
5211 global treediffs
5213 add_flist $treediffs($ids)
5214 getblobdiffs $ids
5217 proc diffcmd {ids flags} {
5218 global nullid nullid2
5220 set i [lsearch -exact $ids $nullid]
5221 set j [lsearch -exact $ids $nullid2]
5222 if {$i >= 0} {
5223 if {[llength $ids] > 1 && $j < 0} {
5224 # comparing working directory with some specific revision
5225 set cmd [concat | git diff-index $flags]
5226 if {$i == 0} {
5227 lappend cmd -R [lindex $ids 1]
5228 } else {
5229 lappend cmd [lindex $ids 0]
5231 } else {
5232 # comparing working directory with index
5233 set cmd [concat | git diff-files $flags]
5234 if {$j == 1} {
5235 lappend cmd -R
5238 } elseif {$j >= 0} {
5239 set cmd [concat | git diff-index --cached $flags]
5240 if {[llength $ids] > 1} {
5241 # comparing index with specific revision
5242 if {$i == 0} {
5243 lappend cmd -R [lindex $ids 1]
5244 } else {
5245 lappend cmd [lindex $ids 0]
5247 } else {
5248 # comparing index with HEAD
5249 lappend cmd HEAD
5251 } else {
5252 set cmd [concat | git diff-tree -r $flags $ids]
5254 return $cmd
5257 proc gettreediffs {ids} {
5258 global treediff treepending
5260 set treepending $ids
5261 set treediff {}
5262 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5263 fconfigure $gdtf -blocking 0
5264 filerun $gdtf [list gettreediffline $gdtf $ids]
5267 proc gettreediffline {gdtf ids} {
5268 global treediff treediffs treepending diffids diffmergeid
5269 global cmitmode viewfiles curview limitdiffs
5271 set nr 0
5272 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5273 set i [string first "\t" $line]
5274 if {$i >= 0} {
5275 set file [string range $line [expr {$i+1}] end]
5276 if {[string index $file 0] eq "\""} {
5277 set file [lindex $file 0]
5279 lappend treediff $file
5282 if {![eof $gdtf]} {
5283 return [expr {$nr >= 1000? 2: 1}]
5285 close $gdtf
5286 if {$limitdiffs && $viewfiles($curview) ne {}} {
5287 set flist {}
5288 foreach f $treediff {
5289 if {[path_filter $viewfiles($curview) $f]} {
5290 lappend flist $f
5293 set treediffs($ids) $flist
5294 } else {
5295 set treediffs($ids) $treediff
5297 unset treepending
5298 if {$cmitmode eq "tree"} {
5299 gettree $diffids
5300 } elseif {$ids != $diffids} {
5301 if {![info exists diffmergeid]} {
5302 gettreediffs $diffids
5304 } else {
5305 addtocflist $ids
5307 return 0
5310 # empty string or positive integer
5311 proc diffcontextvalidate {v} {
5312 return [regexp {^(|[1-9][0-9]*)$} $v]
5315 proc diffcontextchange {n1 n2 op} {
5316 global diffcontextstring diffcontext
5318 if {[string is integer -strict $diffcontextstring]} {
5319 if {$diffcontextstring > 0} {
5320 set diffcontext $diffcontextstring
5321 reselectline
5326 proc changeignorespace {} {
5327 reselectline
5330 proc getblobdiffs {ids} {
5331 global blobdifffd diffids env
5332 global diffinhdr treediffs
5333 global diffcontext
5334 global ignorespace
5335 global limitdiffs viewfiles curview
5337 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5338 if {$ignorespace} {
5339 append cmd " -w"
5341 if {$limitdiffs && $viewfiles($curview) ne {}} {
5342 set cmd [concat $cmd -- $viewfiles($curview)]
5344 if {[catch {set bdf [open $cmd r]} err]} {
5345 puts "error getting diffs: $err"
5346 return
5348 set diffinhdr 0
5349 fconfigure $bdf -blocking 0
5350 set blobdifffd($ids) $bdf
5351 filerun $bdf [list getblobdiffline $bdf $diffids]
5354 proc setinlist {var i val} {
5355 global $var
5357 while {[llength [set $var]] < $i} {
5358 lappend $var {}
5360 if {[llength [set $var]] == $i} {
5361 lappend $var $val
5362 } else {
5363 lset $var $i $val
5367 proc makediffhdr {fname ids} {
5368 global ctext curdiffstart treediffs
5370 set i [lsearch -exact $treediffs($ids) $fname]
5371 if {$i >= 0} {
5372 setinlist difffilestart $i $curdiffstart
5374 set l [expr {(78 - [string length $fname]) / 2}]
5375 set pad [string range "----------------------------------------" 1 $l]
5376 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5379 proc getblobdiffline {bdf ids} {
5380 global diffids blobdifffd ctext curdiffstart
5381 global diffnexthead diffnextnote difffilestart
5382 global diffinhdr treediffs
5384 set nr 0
5385 $ctext conf -state normal
5386 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5387 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5388 close $bdf
5389 return 0
5391 if {![string compare -length 11 "diff --git " $line]} {
5392 # trim off "diff --git "
5393 set line [string range $line 11 end]
5394 set diffinhdr 1
5395 # start of a new file
5396 $ctext insert end "\n"
5397 set curdiffstart [$ctext index "end - 1c"]
5398 $ctext insert end "\n" filesep
5399 # If the name hasn't changed the length will be odd,
5400 # the middle char will be a space, and the two bits either
5401 # side will be a/name and b/name, or "a/name" and "b/name".
5402 # If the name has changed we'll get "rename from" and
5403 # "rename to" or "copy from" and "copy to" lines following this,
5404 # and we'll use them to get the filenames.
5405 # This complexity is necessary because spaces in the filename(s)
5406 # don't get escaped.
5407 set l [string length $line]
5408 set i [expr {$l / 2}]
5409 if {!(($l & 1) && [string index $line $i] eq " " &&
5410 [string range $line 2 [expr {$i - 1}]] eq \
5411 [string range $line [expr {$i + 3}] end])} {
5412 continue
5414 # unescape if quoted and chop off the a/ from the front
5415 if {[string index $line 0] eq "\""} {
5416 set fname [string range [lindex $line 0] 2 end]
5417 } else {
5418 set fname [string range $line 2 [expr {$i - 1}]]
5420 makediffhdr $fname $ids
5422 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5423 $line match f1l f1c f2l f2c rest]} {
5424 $ctext insert end "$line\n" hunksep
5425 set diffinhdr 0
5427 } elseif {$diffinhdr} {
5428 if {![string compare -length 12 "rename from " $line]} {
5429 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5430 if {[string index $fname 0] eq "\""} {
5431 set fname [lindex $fname 0]
5433 set i [lsearch -exact $treediffs($ids) $fname]
5434 if {$i >= 0} {
5435 setinlist difffilestart $i $curdiffstart
5437 } elseif {![string compare -length 10 $line "rename to "] ||
5438 ![string compare -length 8 $line "copy to "]} {
5439 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5440 if {[string index $fname 0] eq "\""} {
5441 set fname [lindex $fname 0]
5443 makediffhdr $fname $ids
5444 } elseif {[string compare -length 3 $line "---"] == 0} {
5445 # do nothing
5446 continue
5447 } elseif {[string compare -length 3 $line "+++"] == 0} {
5448 set diffinhdr 0
5449 continue
5451 $ctext insert end "$line\n" filesep
5453 } else {
5454 set x [string range $line 0 0]
5455 if {$x == "-" || $x == "+"} {
5456 set tag [expr {$x == "+"}]
5457 $ctext insert end "$line\n" d$tag
5458 } elseif {$x == " "} {
5459 $ctext insert end "$line\n"
5460 } else {
5461 # "\ No newline at end of file",
5462 # or something else we don't recognize
5463 $ctext insert end "$line\n" hunksep
5467 $ctext conf -state disabled
5468 if {[eof $bdf]} {
5469 close $bdf
5470 return 0
5472 return [expr {$nr >= 1000? 2: 1}]
5475 proc changediffdisp {} {
5476 global ctext diffelide
5478 $ctext tag conf d0 -elide [lindex $diffelide 0]
5479 $ctext tag conf d1 -elide [lindex $diffelide 1]
5482 proc prevfile {} {
5483 global difffilestart ctext
5484 set prev [lindex $difffilestart 0]
5485 set here [$ctext index @0,0]
5486 foreach loc $difffilestart {
5487 if {[$ctext compare $loc >= $here]} {
5488 $ctext yview $prev
5489 return
5491 set prev $loc
5493 $ctext yview $prev
5496 proc nextfile {} {
5497 global difffilestart ctext
5498 set here [$ctext index @0,0]
5499 foreach loc $difffilestart {
5500 if {[$ctext compare $loc > $here]} {
5501 $ctext yview $loc
5502 return
5507 proc clear_ctext {{first 1.0}} {
5508 global ctext smarktop smarkbot
5509 global pendinglinks
5511 set l [lindex [split $first .] 0]
5512 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5513 set smarktop $l
5515 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5516 set smarkbot $l
5518 $ctext delete $first end
5519 if {$first eq "1.0"} {
5520 catch {unset pendinglinks}
5524 proc settabs {{firstab {}}} {
5525 global firsttabstop tabstop ctext have_tk85
5527 if {$firstab ne {} && $have_tk85} {
5528 set firsttabstop $firstab
5530 set w [font measure textfont "0"]
5531 if {$firsttabstop != 0} {
5532 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5533 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5534 } elseif {$have_tk85 || $tabstop != 8} {
5535 $ctext conf -tabs [expr {$tabstop * $w}]
5536 } else {
5537 $ctext conf -tabs {}
5541 proc incrsearch {name ix op} {
5542 global ctext searchstring searchdirn
5544 $ctext tag remove found 1.0 end
5545 if {[catch {$ctext index anchor}]} {
5546 # no anchor set, use start of selection, or of visible area
5547 set sel [$ctext tag ranges sel]
5548 if {$sel ne {}} {
5549 $ctext mark set anchor [lindex $sel 0]
5550 } elseif {$searchdirn eq "-forwards"} {
5551 $ctext mark set anchor @0,0
5552 } else {
5553 $ctext mark set anchor @0,[winfo height $ctext]
5556 if {$searchstring ne {}} {
5557 set here [$ctext search $searchdirn -- $searchstring anchor]
5558 if {$here ne {}} {
5559 $ctext see $here
5561 searchmarkvisible 1
5565 proc dosearch {} {
5566 global sstring ctext searchstring searchdirn
5568 focus $sstring
5569 $sstring icursor end
5570 set searchdirn -forwards
5571 if {$searchstring ne {}} {
5572 set sel [$ctext tag ranges sel]
5573 if {$sel ne {}} {
5574 set start "[lindex $sel 0] + 1c"
5575 } elseif {[catch {set start [$ctext index anchor]}]} {
5576 set start "@0,0"
5578 set match [$ctext search -count mlen -- $searchstring $start]
5579 $ctext tag remove sel 1.0 end
5580 if {$match eq {}} {
5581 bell
5582 return
5584 $ctext see $match
5585 set mend "$match + $mlen c"
5586 $ctext tag add sel $match $mend
5587 $ctext mark unset anchor
5591 proc dosearchback {} {
5592 global sstring ctext searchstring searchdirn
5594 focus $sstring
5595 $sstring icursor end
5596 set searchdirn -backwards
5597 if {$searchstring ne {}} {
5598 set sel [$ctext tag ranges sel]
5599 if {$sel ne {}} {
5600 set start [lindex $sel 0]
5601 } elseif {[catch {set start [$ctext index anchor]}]} {
5602 set start @0,[winfo height $ctext]
5604 set match [$ctext search -backwards -count ml -- $searchstring $start]
5605 $ctext tag remove sel 1.0 end
5606 if {$match eq {}} {
5607 bell
5608 return
5610 $ctext see $match
5611 set mend "$match + $ml c"
5612 $ctext tag add sel $match $mend
5613 $ctext mark unset anchor
5617 proc searchmark {first last} {
5618 global ctext searchstring
5620 set mend $first.0
5621 while {1} {
5622 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5623 if {$match eq {}} break
5624 set mend "$match + $mlen c"
5625 $ctext tag add found $match $mend
5629 proc searchmarkvisible {doall} {
5630 global ctext smarktop smarkbot
5632 set topline [lindex [split [$ctext index @0,0] .] 0]
5633 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5634 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5635 # no overlap with previous
5636 searchmark $topline $botline
5637 set smarktop $topline
5638 set smarkbot $botline
5639 } else {
5640 if {$topline < $smarktop} {
5641 searchmark $topline [expr {$smarktop-1}]
5642 set smarktop $topline
5644 if {$botline > $smarkbot} {
5645 searchmark [expr {$smarkbot+1}] $botline
5646 set smarkbot $botline
5651 proc scrolltext {f0 f1} {
5652 global searchstring
5654 .bleft.bottom.sb set $f0 $f1
5655 if {$searchstring ne {}} {
5656 searchmarkvisible 0
5660 proc setcoords {} {
5661 global linespc charspc canvx0 canvy0
5662 global xspc1 xspc2 lthickness
5664 set linespc [font metrics mainfont -linespace]
5665 set charspc [font measure mainfont "m"]
5666 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5667 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5668 set lthickness [expr {int($linespc / 9) + 1}]
5669 set xspc1(0) $linespc
5670 set xspc2 $linespc
5673 proc redisplay {} {
5674 global canv
5675 global selectedline
5677 set ymax [lindex [$canv cget -scrollregion] 3]
5678 if {$ymax eq {} || $ymax == 0} return
5679 set span [$canv yview]
5680 clear_display
5681 setcanvscroll
5682 allcanvs yview moveto [lindex $span 0]
5683 drawvisible
5684 if {[info exists selectedline]} {
5685 selectline $selectedline 0
5686 allcanvs yview moveto [lindex $span 0]
5690 proc parsefont {f n} {
5691 global fontattr
5693 set fontattr($f,family) [lindex $n 0]
5694 set s [lindex $n 1]
5695 if {$s eq {} || $s == 0} {
5696 set s 10
5697 } elseif {$s < 0} {
5698 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5700 set fontattr($f,size) $s
5701 set fontattr($f,weight) normal
5702 set fontattr($f,slant) roman
5703 foreach style [lrange $n 2 end] {
5704 switch -- $style {
5705 "normal" -
5706 "bold" {set fontattr($f,weight) $style}
5707 "roman" -
5708 "italic" {set fontattr($f,slant) $style}
5713 proc fontflags {f {isbold 0}} {
5714 global fontattr
5716 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5717 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5718 -slant $fontattr($f,slant)]
5721 proc fontname {f} {
5722 global fontattr
5724 set n [list $fontattr($f,family) $fontattr($f,size)]
5725 if {$fontattr($f,weight) eq "bold"} {
5726 lappend n "bold"
5728 if {$fontattr($f,slant) eq "italic"} {
5729 lappend n "italic"
5731 return $n
5734 proc incrfont {inc} {
5735 global mainfont textfont ctext canv phase cflist showrefstop
5736 global stopped entries fontattr
5738 unmarkmatches
5739 set s $fontattr(mainfont,size)
5740 incr s $inc
5741 if {$s < 1} {
5742 set s 1
5744 set fontattr(mainfont,size) $s
5745 font config mainfont -size $s
5746 font config mainfontbold -size $s
5747 set mainfont [fontname mainfont]
5748 set s $fontattr(textfont,size)
5749 incr s $inc
5750 if {$s < 1} {
5751 set s 1
5753 set fontattr(textfont,size) $s
5754 font config textfont -size $s
5755 font config textfontbold -size $s
5756 set textfont [fontname textfont]
5757 setcoords
5758 settabs
5759 redisplay
5762 proc clearsha1 {} {
5763 global sha1entry sha1string
5764 if {[string length $sha1string] == 40} {
5765 $sha1entry delete 0 end
5769 proc sha1change {n1 n2 op} {
5770 global sha1string currentid sha1but
5771 if {$sha1string == {}
5772 || ([info exists currentid] && $sha1string == $currentid)} {
5773 set state disabled
5774 } else {
5775 set state normal
5777 if {[$sha1but cget -state] == $state} return
5778 if {$state == "normal"} {
5779 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
5780 } else {
5781 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
5785 proc gotocommit {} {
5786 global sha1string currentid commitrow tagids headids
5787 global displayorder numcommits curview
5789 if {$sha1string == {}
5790 || ([info exists currentid] && $sha1string == $currentid)} return
5791 if {[info exists tagids($sha1string)]} {
5792 set id $tagids($sha1string)
5793 } elseif {[info exists headids($sha1string)]} {
5794 set id $headids($sha1string)
5795 } else {
5796 set id [string tolower $sha1string]
5797 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5798 set matches {}
5799 foreach i $displayorder {
5800 if {[string match $id* $i]} {
5801 lappend matches $i
5804 if {$matches ne {}} {
5805 if {[llength $matches] > 1} {
5806 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
5807 return
5809 set id [lindex $matches 0]
5813 if {[info exists commitrow($curview,$id)]} {
5814 selectline $commitrow($curview,$id) 1
5815 return
5817 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5818 set msg [mc "SHA1 id %s is not known" $sha1string]
5819 } else {
5820 set msg [mc "Tag/Head %s is not known" $sha1string]
5822 error_popup $msg
5825 proc lineenter {x y id} {
5826 global hoverx hovery hoverid hovertimer
5827 global commitinfo canv
5829 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5830 set hoverx $x
5831 set hovery $y
5832 set hoverid $id
5833 if {[info exists hovertimer]} {
5834 after cancel $hovertimer
5836 set hovertimer [after 500 linehover]
5837 $canv delete hover
5840 proc linemotion {x y id} {
5841 global hoverx hovery hoverid hovertimer
5843 if {[info exists hoverid] && $id == $hoverid} {
5844 set hoverx $x
5845 set hovery $y
5846 if {[info exists hovertimer]} {
5847 after cancel $hovertimer
5849 set hovertimer [after 500 linehover]
5853 proc lineleave {id} {
5854 global hoverid hovertimer canv
5856 if {[info exists hoverid] && $id == $hoverid} {
5857 $canv delete hover
5858 if {[info exists hovertimer]} {
5859 after cancel $hovertimer
5860 unset hovertimer
5862 unset hoverid
5866 proc linehover {} {
5867 global hoverx hovery hoverid hovertimer
5868 global canv linespc lthickness
5869 global commitinfo
5871 set text [lindex $commitinfo($hoverid) 0]
5872 set ymax [lindex [$canv cget -scrollregion] 3]
5873 if {$ymax == {}} return
5874 set yfrac [lindex [$canv yview] 0]
5875 set x [expr {$hoverx + 2 * $linespc}]
5876 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5877 set x0 [expr {$x - 2 * $lthickness}]
5878 set y0 [expr {$y - 2 * $lthickness}]
5879 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5880 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5881 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5882 -fill \#ffff80 -outline black -width 1 -tags hover]
5883 $canv raise $t
5884 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5885 -font mainfont]
5886 $canv raise $t
5889 proc clickisonarrow {id y} {
5890 global lthickness
5892 set ranges [rowranges $id]
5893 set thresh [expr {2 * $lthickness + 6}]
5894 set n [expr {[llength $ranges] - 1}]
5895 for {set i 1} {$i < $n} {incr i} {
5896 set row [lindex $ranges $i]
5897 if {abs([yc $row] - $y) < $thresh} {
5898 return $i
5901 return {}
5904 proc arrowjump {id n y} {
5905 global canv
5907 # 1 <-> 2, 3 <-> 4, etc...
5908 set n [expr {(($n - 1) ^ 1) + 1}]
5909 set row [lindex [rowranges $id] $n]
5910 set yt [yc $row]
5911 set ymax [lindex [$canv cget -scrollregion] 3]
5912 if {$ymax eq {} || $ymax <= 0} return
5913 set view [$canv yview]
5914 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5915 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5916 if {$yfrac < 0} {
5917 set yfrac 0
5919 allcanvs yview moveto $yfrac
5922 proc lineclick {x y id isnew} {
5923 global ctext commitinfo children canv thickerline curview commitrow
5925 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5926 unmarkmatches
5927 unselectline
5928 normalline
5929 $canv delete hover
5930 # draw this line thicker than normal
5931 set thickerline $id
5932 drawlines $id
5933 if {$isnew} {
5934 set ymax [lindex [$canv cget -scrollregion] 3]
5935 if {$ymax eq {}} return
5936 set yfrac [lindex [$canv yview] 0]
5937 set y [expr {$y + $yfrac * $ymax}]
5939 set dirn [clickisonarrow $id $y]
5940 if {$dirn ne {}} {
5941 arrowjump $id $dirn $y
5942 return
5945 if {$isnew} {
5946 addtohistory [list lineclick $x $y $id 0]
5948 # fill the details pane with info about this line
5949 $ctext conf -state normal
5950 clear_ctext
5951 settabs 0
5952 $ctext insert end "[mc "Parent"]:\t"
5953 $ctext insert end $id link0
5954 setlink $id link0
5955 set info $commitinfo($id)
5956 $ctext insert end "\n\t[lindex $info 0]\n"
5957 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
5958 set date [formatdate [lindex $info 2]]
5959 $ctext insert end "\t[mc "Date"]:\t$date\n"
5960 set kids $children($curview,$id)
5961 if {$kids ne {}} {
5962 $ctext insert end "\n[mc "Children"]:"
5963 set i 0
5964 foreach child $kids {
5965 incr i
5966 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5967 set info $commitinfo($child)
5968 $ctext insert end "\n\t"
5969 $ctext insert end $child link$i
5970 setlink $child link$i
5971 $ctext insert end "\n\t[lindex $info 0]"
5972 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
5973 set date [formatdate [lindex $info 2]]
5974 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
5977 $ctext conf -state disabled
5978 init_flist {}
5981 proc normalline {} {
5982 global thickerline
5983 if {[info exists thickerline]} {
5984 set id $thickerline
5985 unset thickerline
5986 drawlines $id
5990 proc selbyid {id} {
5991 global commitrow curview
5992 if {[info exists commitrow($curview,$id)]} {
5993 selectline $commitrow($curview,$id) 1
5997 proc mstime {} {
5998 global startmstime
5999 if {![info exists startmstime]} {
6000 set startmstime [clock clicks -milliseconds]
6002 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6005 proc rowmenu {x y id} {
6006 global rowctxmenu commitrow selectedline rowmenuid curview
6007 global nullid nullid2 fakerowmenu mainhead
6009 stopfinding
6010 set rowmenuid $id
6011 if {![info exists selectedline]
6012 || $commitrow($curview,$id) eq $selectedline} {
6013 set state disabled
6014 } else {
6015 set state normal
6017 if {$id ne $nullid && $id ne $nullid2} {
6018 set menu $rowctxmenu
6019 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6020 } else {
6021 set menu $fakerowmenu
6023 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6024 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6025 $menu entryconfigure [mc "Make patch"] -state $state
6026 tk_popup $menu $x $y
6029 proc diffvssel {dirn} {
6030 global rowmenuid selectedline displayorder
6032 if {![info exists selectedline]} return
6033 if {$dirn} {
6034 set oldid [lindex $displayorder $selectedline]
6035 set newid $rowmenuid
6036 } else {
6037 set oldid $rowmenuid
6038 set newid [lindex $displayorder $selectedline]
6040 addtohistory [list doseldiff $oldid $newid]
6041 doseldiff $oldid $newid
6044 proc doseldiff {oldid newid} {
6045 global ctext
6046 global commitinfo
6048 $ctext conf -state normal
6049 clear_ctext
6050 init_flist [mc "Top"]
6051 $ctext insert end "[mc "From"] "
6052 $ctext insert end $oldid link0
6053 setlink $oldid link0
6054 $ctext insert end "\n "
6055 $ctext insert end [lindex $commitinfo($oldid) 0]
6056 $ctext insert end "\n\n[mc "To"] "
6057 $ctext insert end $newid link1
6058 setlink $newid link1
6059 $ctext insert end "\n "
6060 $ctext insert end [lindex $commitinfo($newid) 0]
6061 $ctext insert end "\n"
6062 $ctext conf -state disabled
6063 $ctext tag remove found 1.0 end
6064 startdiff [list $oldid $newid]
6067 proc mkpatch {} {
6068 global rowmenuid currentid commitinfo patchtop patchnum
6070 if {![info exists currentid]} return
6071 set oldid $currentid
6072 set oldhead [lindex $commitinfo($oldid) 0]
6073 set newid $rowmenuid
6074 set newhead [lindex $commitinfo($newid) 0]
6075 set top .patch
6076 set patchtop $top
6077 catch {destroy $top}
6078 toplevel $top
6079 label $top.title -text [mc "Generate patch"]
6080 grid $top.title - -pady 10
6081 label $top.from -text [mc "From:"]
6082 entry $top.fromsha1 -width 40 -relief flat
6083 $top.fromsha1 insert 0 $oldid
6084 $top.fromsha1 conf -state readonly
6085 grid $top.from $top.fromsha1 -sticky w
6086 entry $top.fromhead -width 60 -relief flat
6087 $top.fromhead insert 0 $oldhead
6088 $top.fromhead conf -state readonly
6089 grid x $top.fromhead -sticky w
6090 label $top.to -text [mc "To:"]
6091 entry $top.tosha1 -width 40 -relief flat
6092 $top.tosha1 insert 0 $newid
6093 $top.tosha1 conf -state readonly
6094 grid $top.to $top.tosha1 -sticky w
6095 entry $top.tohead -width 60 -relief flat
6096 $top.tohead insert 0 $newhead
6097 $top.tohead conf -state readonly
6098 grid x $top.tohead -sticky w
6099 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6100 grid $top.rev x -pady 10
6101 label $top.flab -text [mc "Output file:"]
6102 entry $top.fname -width 60
6103 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6104 incr patchnum
6105 grid $top.flab $top.fname -sticky w
6106 frame $top.buts
6107 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6108 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6109 grid $top.buts.gen $top.buts.can
6110 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6111 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6112 grid $top.buts - -pady 10 -sticky ew
6113 focus $top.fname
6116 proc mkpatchrev {} {
6117 global patchtop
6119 set oldid [$patchtop.fromsha1 get]
6120 set oldhead [$patchtop.fromhead get]
6121 set newid [$patchtop.tosha1 get]
6122 set newhead [$patchtop.tohead get]
6123 foreach e [list fromsha1 fromhead tosha1 tohead] \
6124 v [list $newid $newhead $oldid $oldhead] {
6125 $patchtop.$e conf -state normal
6126 $patchtop.$e delete 0 end
6127 $patchtop.$e insert 0 $v
6128 $patchtop.$e conf -state readonly
6132 proc mkpatchgo {} {
6133 global patchtop nullid nullid2
6135 set oldid [$patchtop.fromsha1 get]
6136 set newid [$patchtop.tosha1 get]
6137 set fname [$patchtop.fname get]
6138 set cmd [diffcmd [list $oldid $newid] -p]
6139 # trim off the initial "|"
6140 set cmd [lrange $cmd 1 end]
6141 lappend cmd >$fname &
6142 if {[catch {eval exec $cmd} err]} {
6143 error_popup "[mc "Error creating patch:"] $err"
6145 catch {destroy $patchtop}
6146 unset patchtop
6149 proc mkpatchcan {} {
6150 global patchtop
6152 catch {destroy $patchtop}
6153 unset patchtop
6156 proc mktag {} {
6157 global rowmenuid mktagtop commitinfo
6159 set top .maketag
6160 set mktagtop $top
6161 catch {destroy $top}
6162 toplevel $top
6163 label $top.title -text [mc "Create tag"]
6164 grid $top.title - -pady 10
6165 label $top.id -text [mc "ID:"]
6166 entry $top.sha1 -width 40 -relief flat
6167 $top.sha1 insert 0 $rowmenuid
6168 $top.sha1 conf -state readonly
6169 grid $top.id $top.sha1 -sticky w
6170 entry $top.head -width 60 -relief flat
6171 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6172 $top.head conf -state readonly
6173 grid x $top.head -sticky w
6174 label $top.tlab -text [mc "Tag name:"]
6175 entry $top.tag -width 60
6176 grid $top.tlab $top.tag -sticky w
6177 frame $top.buts
6178 button $top.buts.gen -text [mc "Create"] -command mktaggo
6179 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6180 grid $top.buts.gen $top.buts.can
6181 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6182 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6183 grid $top.buts - -pady 10 -sticky ew
6184 focus $top.tag
6187 proc domktag {} {
6188 global mktagtop env tagids idtags
6190 set id [$mktagtop.sha1 get]
6191 set tag [$mktagtop.tag get]
6192 if {$tag == {}} {
6193 error_popup [mc "No tag name specified"]
6194 return
6196 if {[info exists tagids($tag)]} {
6197 error_popup [mc "Tag \"%s\" already exists" $tag]
6198 return
6200 if {[catch {
6201 exec git tag $tag $id
6202 } err]} {
6203 error_popup "[mc "Error creating tag:"] $err"
6204 return
6207 set tagids($tag) $id
6208 lappend idtags($id) $tag
6209 redrawtags $id
6210 addedtag $id
6211 dispneartags 0
6212 run refill_reflist
6215 proc redrawtags {id} {
6216 global canv linehtag commitrow idpos selectedline curview
6217 global canvxmax iddrawn
6219 if {![info exists commitrow($curview,$id)]} return
6220 if {![info exists iddrawn($id)]} return
6221 drawcommits $commitrow($curview,$id)
6222 $canv delete tag.$id
6223 set xt [eval drawtags $id $idpos($id)]
6224 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6225 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6226 set xr [expr {$xt + [font measure mainfont $text]}]
6227 if {$xr > $canvxmax} {
6228 set canvxmax $xr
6229 setcanvscroll
6231 if {[info exists selectedline]
6232 && $selectedline == $commitrow($curview,$id)} {
6233 selectline $selectedline 0
6237 proc mktagcan {} {
6238 global mktagtop
6240 catch {destroy $mktagtop}
6241 unset mktagtop
6244 proc mktaggo {} {
6245 domktag
6246 mktagcan
6249 proc writecommit {} {
6250 global rowmenuid wrcomtop commitinfo wrcomcmd
6252 set top .writecommit
6253 set wrcomtop $top
6254 catch {destroy $top}
6255 toplevel $top
6256 label $top.title -text [mc "Write commit to file"]
6257 grid $top.title - -pady 10
6258 label $top.id -text [mc "ID:"]
6259 entry $top.sha1 -width 40 -relief flat
6260 $top.sha1 insert 0 $rowmenuid
6261 $top.sha1 conf -state readonly
6262 grid $top.id $top.sha1 -sticky w
6263 entry $top.head -width 60 -relief flat
6264 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6265 $top.head conf -state readonly
6266 grid x $top.head -sticky w
6267 label $top.clab -text [mc "Command:"]
6268 entry $top.cmd -width 60 -textvariable wrcomcmd
6269 grid $top.clab $top.cmd -sticky w -pady 10
6270 label $top.flab -text [mc "Output file:"]
6271 entry $top.fname -width 60
6272 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6273 grid $top.flab $top.fname -sticky w
6274 frame $top.buts
6275 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6276 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6277 grid $top.buts.gen $top.buts.can
6278 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6279 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6280 grid $top.buts - -pady 10 -sticky ew
6281 focus $top.fname
6284 proc wrcomgo {} {
6285 global wrcomtop
6287 set id [$wrcomtop.sha1 get]
6288 set cmd "echo $id | [$wrcomtop.cmd get]"
6289 set fname [$wrcomtop.fname get]
6290 if {[catch {exec sh -c $cmd >$fname &} err]} {
6291 error_popup "[mc "Error writing commit:"] $err"
6293 catch {destroy $wrcomtop}
6294 unset wrcomtop
6297 proc wrcomcan {} {
6298 global wrcomtop
6300 catch {destroy $wrcomtop}
6301 unset wrcomtop
6304 proc mkbranch {} {
6305 global rowmenuid mkbrtop
6307 set top .makebranch
6308 catch {destroy $top}
6309 toplevel $top
6310 label $top.title -text [mc "Create new branch"]
6311 grid $top.title - -pady 10
6312 label $top.id -text [mc "ID:"]
6313 entry $top.sha1 -width 40 -relief flat
6314 $top.sha1 insert 0 $rowmenuid
6315 $top.sha1 conf -state readonly
6316 grid $top.id $top.sha1 -sticky w
6317 label $top.nlab -text [mc "Name:"]
6318 entry $top.name -width 40
6319 grid $top.nlab $top.name -sticky w
6320 frame $top.buts
6321 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6322 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6323 grid $top.buts.go $top.buts.can
6324 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6325 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6326 grid $top.buts - -pady 10 -sticky ew
6327 focus $top.name
6330 proc mkbrgo {top} {
6331 global headids idheads
6333 set name [$top.name get]
6334 set id [$top.sha1 get]
6335 if {$name eq {}} {
6336 error_popup [mc "Please specify a name for the new branch"]
6337 return
6339 catch {destroy $top}
6340 nowbusy newbranch
6341 update
6342 if {[catch {
6343 exec git branch $name $id
6344 } err]} {
6345 notbusy newbranch
6346 error_popup $err
6347 } else {
6348 set headids($name) $id
6349 lappend idheads($id) $name
6350 addedhead $id $name
6351 notbusy newbranch
6352 redrawtags $id
6353 dispneartags 0
6354 run refill_reflist
6358 proc cherrypick {} {
6359 global rowmenuid curview commitrow
6360 global mainhead
6362 set oldhead [exec git rev-parse HEAD]
6363 set dheads [descheads $rowmenuid]
6364 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6365 set ok [confirm_popup [mc "Commit %s is already\
6366 included in branch %s -- really re-apply it?" \
6367 [string range $rowmenuid 0 7] $mainhead]]
6368 if {!$ok} return
6370 nowbusy cherrypick [mc "Cherry-picking"]
6371 update
6372 # Unfortunately git-cherry-pick writes stuff to stderr even when
6373 # no error occurs, and exec takes that as an indication of error...
6374 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6375 notbusy cherrypick
6376 error_popup $err
6377 return
6379 set newhead [exec git rev-parse HEAD]
6380 if {$newhead eq $oldhead} {
6381 notbusy cherrypick
6382 error_popup [mc "No changes committed"]
6383 return
6385 addnewchild $newhead $oldhead
6386 if {[info exists commitrow($curview,$oldhead)]} {
6387 insertrow $commitrow($curview,$oldhead) $newhead
6388 if {$mainhead ne {}} {
6389 movehead $newhead $mainhead
6390 movedhead $newhead $mainhead
6392 redrawtags $oldhead
6393 redrawtags $newhead
6395 notbusy cherrypick
6398 proc resethead {} {
6399 global mainheadid mainhead rowmenuid confirm_ok resettype
6401 set confirm_ok 0
6402 set w ".confirmreset"
6403 toplevel $w
6404 wm transient $w .
6405 wm title $w [mc "Confirm reset"]
6406 message $w.m -text \
6407 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
6408 -justify center -aspect 1000
6409 pack $w.m -side top -fill x -padx 20 -pady 20
6410 frame $w.f -relief sunken -border 2
6411 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
6412 grid $w.f.rt -sticky w
6413 set resettype mixed
6414 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6415 -text [mc "Soft: Leave working tree and index untouched"]
6416 grid $w.f.soft -sticky w
6417 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6418 -text [mc "Mixed: Leave working tree untouched, reset index"]
6419 grid $w.f.mixed -sticky w
6420 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6421 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
6422 grid $w.f.hard -sticky w
6423 pack $w.f -side top -fill x
6424 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
6425 pack $w.ok -side left -fill x -padx 20 -pady 20
6426 button $w.cancel -text [mc Cancel] -command "destroy $w"
6427 pack $w.cancel -side right -fill x -padx 20 -pady 20
6428 bind $w <Visibility> "grab $w; focus $w"
6429 tkwait window $w
6430 if {!$confirm_ok} return
6431 if {[catch {set fd [open \
6432 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6433 error_popup $err
6434 } else {
6435 dohidelocalchanges
6436 filerun $fd [list readresetstat $fd]
6437 nowbusy reset [mc "Resetting"]
6441 proc readresetstat {fd} {
6442 global mainhead mainheadid showlocalchanges rprogcoord
6444 if {[gets $fd line] >= 0} {
6445 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6446 set rprogcoord [expr {1.0 * $m / $n}]
6447 adjustprogress
6449 return 1
6451 set rprogcoord 0
6452 adjustprogress
6453 notbusy reset
6454 if {[catch {close $fd} err]} {
6455 error_popup $err
6457 set oldhead $mainheadid
6458 set newhead [exec git rev-parse HEAD]
6459 if {$newhead ne $oldhead} {
6460 movehead $newhead $mainhead
6461 movedhead $newhead $mainhead
6462 set mainheadid $newhead
6463 redrawtags $oldhead
6464 redrawtags $newhead
6466 if {$showlocalchanges} {
6467 doshowlocalchanges
6469 return 0
6472 # context menu for a head
6473 proc headmenu {x y id head} {
6474 global headmenuid headmenuhead headctxmenu mainhead
6476 stopfinding
6477 set headmenuid $id
6478 set headmenuhead $head
6479 set state normal
6480 if {$head eq $mainhead} {
6481 set state disabled
6483 $headctxmenu entryconfigure 0 -state $state
6484 $headctxmenu entryconfigure 1 -state $state
6485 tk_popup $headctxmenu $x $y
6488 proc cobranch {} {
6489 global headmenuid headmenuhead mainhead headids
6490 global showlocalchanges mainheadid
6492 # check the tree is clean first??
6493 set oldmainhead $mainhead
6494 nowbusy checkout [mc "Checking out"]
6495 update
6496 dohidelocalchanges
6497 if {[catch {
6498 exec git checkout -q $headmenuhead
6499 } err]} {
6500 notbusy checkout
6501 error_popup $err
6502 } else {
6503 notbusy checkout
6504 set mainhead $headmenuhead
6505 set mainheadid $headmenuid
6506 if {[info exists headids($oldmainhead)]} {
6507 redrawtags $headids($oldmainhead)
6509 redrawtags $headmenuid
6511 if {$showlocalchanges} {
6512 dodiffindex
6516 proc rmbranch {} {
6517 global headmenuid headmenuhead mainhead
6518 global idheads
6520 set head $headmenuhead
6521 set id $headmenuid
6522 # this check shouldn't be needed any more...
6523 if {$head eq $mainhead} {
6524 error_popup [mc "Cannot delete the currently checked-out branch"]
6525 return
6527 set dheads [descheads $id]
6528 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6529 # the stuff on this branch isn't on any other branch
6530 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
6531 branch.\nReally delete branch %s?" $head $head]]} return
6533 nowbusy rmbranch
6534 update
6535 if {[catch {exec git branch -D $head} err]} {
6536 notbusy rmbranch
6537 error_popup $err
6538 return
6540 removehead $id $head
6541 removedhead $id $head
6542 redrawtags $id
6543 notbusy rmbranch
6544 dispneartags 0
6545 run refill_reflist
6548 # Display a list of tags and heads
6549 proc showrefs {} {
6550 global showrefstop bgcolor fgcolor selectbgcolor
6551 global bglist fglist reflistfilter reflist maincursor
6553 set top .showrefs
6554 set showrefstop $top
6555 if {[winfo exists $top]} {
6556 raise $top
6557 refill_reflist
6558 return
6560 toplevel $top
6561 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
6562 text $top.list -background $bgcolor -foreground $fgcolor \
6563 -selectbackground $selectbgcolor -font mainfont \
6564 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6565 -width 30 -height 20 -cursor $maincursor \
6566 -spacing1 1 -spacing3 1 -state disabled
6567 $top.list tag configure highlight -background $selectbgcolor
6568 lappend bglist $top.list
6569 lappend fglist $top.list
6570 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6571 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6572 grid $top.list $top.ysb -sticky nsew
6573 grid $top.xsb x -sticky ew
6574 frame $top.f
6575 label $top.f.l -text "[mc "Filter"]: "
6576 entry $top.f.e -width 20 -textvariable reflistfilter
6577 set reflistfilter "*"
6578 trace add variable reflistfilter write reflistfilter_change
6579 pack $top.f.e -side right -fill x -expand 1
6580 pack $top.f.l -side left
6581 grid $top.f - -sticky ew -pady 2
6582 button $top.close -command [list destroy $top] -text [mc "Close"]
6583 grid $top.close -
6584 grid columnconfigure $top 0 -weight 1
6585 grid rowconfigure $top 0 -weight 1
6586 bind $top.list <1> {break}
6587 bind $top.list <B1-Motion> {break}
6588 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6589 set reflist {}
6590 refill_reflist
6593 proc sel_reflist {w x y} {
6594 global showrefstop reflist headids tagids otherrefids
6596 if {![winfo exists $showrefstop]} return
6597 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6598 set ref [lindex $reflist [expr {$l-1}]]
6599 set n [lindex $ref 0]
6600 switch -- [lindex $ref 1] {
6601 "H" {selbyid $headids($n)}
6602 "T" {selbyid $tagids($n)}
6603 "o" {selbyid $otherrefids($n)}
6605 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6608 proc unsel_reflist {} {
6609 global showrefstop
6611 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6612 $showrefstop.list tag remove highlight 0.0 end
6615 proc reflistfilter_change {n1 n2 op} {
6616 global reflistfilter
6618 after cancel refill_reflist
6619 after 200 refill_reflist
6622 proc refill_reflist {} {
6623 global reflist reflistfilter showrefstop headids tagids otherrefids
6624 global commitrow curview commitinterest
6626 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6627 set refs {}
6628 foreach n [array names headids] {
6629 if {[string match $reflistfilter $n]} {
6630 if {[info exists commitrow($curview,$headids($n))]} {
6631 lappend refs [list $n H]
6632 } else {
6633 set commitinterest($headids($n)) {run refill_reflist}
6637 foreach n [array names tagids] {
6638 if {[string match $reflistfilter $n]} {
6639 if {[info exists commitrow($curview,$tagids($n))]} {
6640 lappend refs [list $n T]
6641 } else {
6642 set commitinterest($tagids($n)) {run refill_reflist}
6646 foreach n [array names otherrefids] {
6647 if {[string match $reflistfilter $n]} {
6648 if {[info exists commitrow($curview,$otherrefids($n))]} {
6649 lappend refs [list $n o]
6650 } else {
6651 set commitinterest($otherrefids($n)) {run refill_reflist}
6655 set refs [lsort -index 0 $refs]
6656 if {$refs eq $reflist} return
6658 # Update the contents of $showrefstop.list according to the
6659 # differences between $reflist (old) and $refs (new)
6660 $showrefstop.list conf -state normal
6661 $showrefstop.list insert end "\n"
6662 set i 0
6663 set j 0
6664 while {$i < [llength $reflist] || $j < [llength $refs]} {
6665 if {$i < [llength $reflist]} {
6666 if {$j < [llength $refs]} {
6667 set cmp [string compare [lindex $reflist $i 0] \
6668 [lindex $refs $j 0]]
6669 if {$cmp == 0} {
6670 set cmp [string compare [lindex $reflist $i 1] \
6671 [lindex $refs $j 1]]
6673 } else {
6674 set cmp -1
6676 } else {
6677 set cmp 1
6679 switch -- $cmp {
6680 -1 {
6681 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6682 incr i
6685 incr i
6686 incr j
6689 set l [expr {$j + 1}]
6690 $showrefstop.list image create $l.0 -align baseline \
6691 -image reficon-[lindex $refs $j 1] -padx 2
6692 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6693 incr j
6697 set reflist $refs
6698 # delete last newline
6699 $showrefstop.list delete end-2c end-1c
6700 $showrefstop.list conf -state disabled
6703 # Stuff for finding nearby tags
6704 proc getallcommits {} {
6705 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6706 global idheads idtags idotherrefs allparents tagobjid
6708 if {![info exists allcommits]} {
6709 set nextarc 0
6710 set allcommits 0
6711 set seeds {}
6712 set allcwait 0
6713 set cachedarcs 0
6714 set allccache [file join [gitdir] "gitk.cache"]
6715 if {![catch {
6716 set f [open $allccache r]
6717 set allcwait 1
6718 getcache $f
6719 }]} return
6722 if {$allcwait} {
6723 return
6725 set cmd [list | git rev-list --parents]
6726 set allcupdate [expr {$seeds ne {}}]
6727 if {!$allcupdate} {
6728 set ids "--all"
6729 } else {
6730 set refs [concat [array names idheads] [array names idtags] \
6731 [array names idotherrefs]]
6732 set ids {}
6733 set tagobjs {}
6734 foreach name [array names tagobjid] {
6735 lappend tagobjs $tagobjid($name)
6737 foreach id [lsort -unique $refs] {
6738 if {![info exists allparents($id)] &&
6739 [lsearch -exact $tagobjs $id] < 0} {
6740 lappend ids $id
6743 if {$ids ne {}} {
6744 foreach id $seeds {
6745 lappend ids "^$id"
6749 if {$ids ne {}} {
6750 set fd [open [concat $cmd $ids] r]
6751 fconfigure $fd -blocking 0
6752 incr allcommits
6753 nowbusy allcommits
6754 filerun $fd [list getallclines $fd]
6755 } else {
6756 dispneartags 0
6760 # Since most commits have 1 parent and 1 child, we group strings of
6761 # such commits into "arcs" joining branch/merge points (BMPs), which
6762 # are commits that either don't have 1 parent or don't have 1 child.
6764 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6765 # arcout(id) - outgoing arcs for BMP
6766 # arcids(a) - list of IDs on arc including end but not start
6767 # arcstart(a) - BMP ID at start of arc
6768 # arcend(a) - BMP ID at end of arc
6769 # growing(a) - arc a is still growing
6770 # arctags(a) - IDs out of arcids (excluding end) that have tags
6771 # archeads(a) - IDs out of arcids (excluding end) that have heads
6772 # The start of an arc is at the descendent end, so "incoming" means
6773 # coming from descendents, and "outgoing" means going towards ancestors.
6775 proc getallclines {fd} {
6776 global allparents allchildren idtags idheads nextarc
6777 global arcnos arcids arctags arcout arcend arcstart archeads growing
6778 global seeds allcommits cachedarcs allcupdate
6780 set nid 0
6781 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6782 set id [lindex $line 0]
6783 if {[info exists allparents($id)]} {
6784 # seen it already
6785 continue
6787 set cachedarcs 0
6788 set olds [lrange $line 1 end]
6789 set allparents($id) $olds
6790 if {![info exists allchildren($id)]} {
6791 set allchildren($id) {}
6792 set arcnos($id) {}
6793 lappend seeds $id
6794 } else {
6795 set a $arcnos($id)
6796 if {[llength $olds] == 1 && [llength $a] == 1} {
6797 lappend arcids($a) $id
6798 if {[info exists idtags($id)]} {
6799 lappend arctags($a) $id
6801 if {[info exists idheads($id)]} {
6802 lappend archeads($a) $id
6804 if {[info exists allparents($olds)]} {
6805 # seen parent already
6806 if {![info exists arcout($olds)]} {
6807 splitarc $olds
6809 lappend arcids($a) $olds
6810 set arcend($a) $olds
6811 unset growing($a)
6813 lappend allchildren($olds) $id
6814 lappend arcnos($olds) $a
6815 continue
6818 foreach a $arcnos($id) {
6819 lappend arcids($a) $id
6820 set arcend($a) $id
6821 unset growing($a)
6824 set ao {}
6825 foreach p $olds {
6826 lappend allchildren($p) $id
6827 set a [incr nextarc]
6828 set arcstart($a) $id
6829 set archeads($a) {}
6830 set arctags($a) {}
6831 set archeads($a) {}
6832 set arcids($a) {}
6833 lappend ao $a
6834 set growing($a) 1
6835 if {[info exists allparents($p)]} {
6836 # seen it already, may need to make a new branch
6837 if {![info exists arcout($p)]} {
6838 splitarc $p
6840 lappend arcids($a) $p
6841 set arcend($a) $p
6842 unset growing($a)
6844 lappend arcnos($p) $a
6846 set arcout($id) $ao
6848 if {$nid > 0} {
6849 global cached_dheads cached_dtags cached_atags
6850 catch {unset cached_dheads}
6851 catch {unset cached_dtags}
6852 catch {unset cached_atags}
6854 if {![eof $fd]} {
6855 return [expr {$nid >= 1000? 2: 1}]
6857 set cacheok 1
6858 if {[catch {
6859 fconfigure $fd -blocking 1
6860 close $fd
6861 } err]} {
6862 # got an error reading the list of commits
6863 # if we were updating, try rereading the whole thing again
6864 if {$allcupdate} {
6865 incr allcommits -1
6866 dropcache $err
6867 return
6869 error_popup "[mc "Error reading commit topology information;\
6870 branch and preceding/following tag information\
6871 will be incomplete."]\n($err)"
6872 set cacheok 0
6874 if {[incr allcommits -1] == 0} {
6875 notbusy allcommits
6876 if {$cacheok} {
6877 run savecache
6880 dispneartags 0
6881 return 0
6884 proc recalcarc {a} {
6885 global arctags archeads arcids idtags idheads
6887 set at {}
6888 set ah {}
6889 foreach id [lrange $arcids($a) 0 end-1] {
6890 if {[info exists idtags($id)]} {
6891 lappend at $id
6893 if {[info exists idheads($id)]} {
6894 lappend ah $id
6897 set arctags($a) $at
6898 set archeads($a) $ah
6901 proc splitarc {p} {
6902 global arcnos arcids nextarc arctags archeads idtags idheads
6903 global arcstart arcend arcout allparents growing
6905 set a $arcnos($p)
6906 if {[llength $a] != 1} {
6907 puts "oops splitarc called but [llength $a] arcs already"
6908 return
6910 set a [lindex $a 0]
6911 set i [lsearch -exact $arcids($a) $p]
6912 if {$i < 0} {
6913 puts "oops splitarc $p not in arc $a"
6914 return
6916 set na [incr nextarc]
6917 if {[info exists arcend($a)]} {
6918 set arcend($na) $arcend($a)
6919 } else {
6920 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6921 set j [lsearch -exact $arcnos($l) $a]
6922 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6924 set tail [lrange $arcids($a) [expr {$i+1}] end]
6925 set arcids($a) [lrange $arcids($a) 0 $i]
6926 set arcend($a) $p
6927 set arcstart($na) $p
6928 set arcout($p) $na
6929 set arcids($na) $tail
6930 if {[info exists growing($a)]} {
6931 set growing($na) 1
6932 unset growing($a)
6935 foreach id $tail {
6936 if {[llength $arcnos($id)] == 1} {
6937 set arcnos($id) $na
6938 } else {
6939 set j [lsearch -exact $arcnos($id) $a]
6940 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6944 # reconstruct tags and heads lists
6945 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6946 recalcarc $a
6947 recalcarc $na
6948 } else {
6949 set arctags($na) {}
6950 set archeads($na) {}
6954 # Update things for a new commit added that is a child of one
6955 # existing commit. Used when cherry-picking.
6956 proc addnewchild {id p} {
6957 global allparents allchildren idtags nextarc
6958 global arcnos arcids arctags arcout arcend arcstart archeads growing
6959 global seeds allcommits
6961 if {![info exists allcommits] || ![info exists arcnos($p)]} return
6962 set allparents($id) [list $p]
6963 set allchildren($id) {}
6964 set arcnos($id) {}
6965 lappend seeds $id
6966 lappend allchildren($p) $id
6967 set a [incr nextarc]
6968 set arcstart($a) $id
6969 set archeads($a) {}
6970 set arctags($a) {}
6971 set arcids($a) [list $p]
6972 set arcend($a) $p
6973 if {![info exists arcout($p)]} {
6974 splitarc $p
6976 lappend arcnos($p) $a
6977 set arcout($id) [list $a]
6980 # This implements a cache for the topology information.
6981 # The cache saves, for each arc, the start and end of the arc,
6982 # the ids on the arc, and the outgoing arcs from the end.
6983 proc readcache {f} {
6984 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6985 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6986 global allcwait
6988 set a $nextarc
6989 set lim $cachedarcs
6990 if {$lim - $a > 500} {
6991 set lim [expr {$a + 500}]
6993 if {[catch {
6994 if {$a == $lim} {
6995 # finish reading the cache and setting up arctags, etc.
6996 set line [gets $f]
6997 if {$line ne "1"} {error "bad final version"}
6998 close $f
6999 foreach id [array names idtags] {
7000 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7001 [llength $allparents($id)] == 1} {
7002 set a [lindex $arcnos($id) 0]
7003 if {$arctags($a) eq {}} {
7004 recalcarc $a
7008 foreach id [array names idheads] {
7009 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7010 [llength $allparents($id)] == 1} {
7011 set a [lindex $arcnos($id) 0]
7012 if {$archeads($a) eq {}} {
7013 recalcarc $a
7017 foreach id [lsort -unique $possible_seeds] {
7018 if {$arcnos($id) eq {}} {
7019 lappend seeds $id
7022 set allcwait 0
7023 } else {
7024 while {[incr a] <= $lim} {
7025 set line [gets $f]
7026 if {[llength $line] != 3} {error "bad line"}
7027 set s [lindex $line 0]
7028 set arcstart($a) $s
7029 lappend arcout($s) $a
7030 if {![info exists arcnos($s)]} {
7031 lappend possible_seeds $s
7032 set arcnos($s) {}
7034 set e [lindex $line 1]
7035 if {$e eq {}} {
7036 set growing($a) 1
7037 } else {
7038 set arcend($a) $e
7039 if {![info exists arcout($e)]} {
7040 set arcout($e) {}
7043 set arcids($a) [lindex $line 2]
7044 foreach id $arcids($a) {
7045 lappend allparents($s) $id
7046 set s $id
7047 lappend arcnos($id) $a
7049 if {![info exists allparents($s)]} {
7050 set allparents($s) {}
7052 set arctags($a) {}
7053 set archeads($a) {}
7055 set nextarc [expr {$a - 1}]
7057 } err]} {
7058 dropcache $err
7059 return 0
7061 if {!$allcwait} {
7062 getallcommits
7064 return $allcwait
7067 proc getcache {f} {
7068 global nextarc cachedarcs possible_seeds
7070 if {[catch {
7071 set line [gets $f]
7072 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7073 # make sure it's an integer
7074 set cachedarcs [expr {int([lindex $line 1])}]
7075 if {$cachedarcs < 0} {error "bad number of arcs"}
7076 set nextarc 0
7077 set possible_seeds {}
7078 run readcache $f
7079 } err]} {
7080 dropcache $err
7082 return 0
7085 proc dropcache {err} {
7086 global allcwait nextarc cachedarcs seeds
7088 #puts "dropping cache ($err)"
7089 foreach v {arcnos arcout arcids arcstart arcend growing \
7090 arctags archeads allparents allchildren} {
7091 global $v
7092 catch {unset $v}
7094 set allcwait 0
7095 set nextarc 0
7096 set cachedarcs 0
7097 set seeds {}
7098 getallcommits
7101 proc writecache {f} {
7102 global cachearc cachedarcs allccache
7103 global arcstart arcend arcnos arcids arcout
7105 set a $cachearc
7106 set lim $cachedarcs
7107 if {$lim - $a > 1000} {
7108 set lim [expr {$a + 1000}]
7110 if {[catch {
7111 while {[incr a] <= $lim} {
7112 if {[info exists arcend($a)]} {
7113 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7114 } else {
7115 puts $f [list $arcstart($a) {} $arcids($a)]
7118 } err]} {
7119 catch {close $f}
7120 catch {file delete $allccache}
7121 #puts "writing cache failed ($err)"
7122 return 0
7124 set cachearc [expr {$a - 1}]
7125 if {$a > $cachedarcs} {
7126 puts $f "1"
7127 close $f
7128 return 0
7130 return 1
7133 proc savecache {} {
7134 global nextarc cachedarcs cachearc allccache
7136 if {$nextarc == $cachedarcs} return
7137 set cachearc 0
7138 set cachedarcs $nextarc
7139 catch {
7140 set f [open $allccache w]
7141 puts $f [list 1 $cachedarcs]
7142 run writecache $f
7146 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7147 # or 0 if neither is true.
7148 proc anc_or_desc {a b} {
7149 global arcout arcstart arcend arcnos cached_isanc
7151 if {$arcnos($a) eq $arcnos($b)} {
7152 # Both are on the same arc(s); either both are the same BMP,
7153 # or if one is not a BMP, the other is also not a BMP or is
7154 # the BMP at end of the arc (and it only has 1 incoming arc).
7155 # Or both can be BMPs with no incoming arcs.
7156 if {$a eq $b || $arcnos($a) eq {}} {
7157 return 0
7159 # assert {[llength $arcnos($a)] == 1}
7160 set arc [lindex $arcnos($a) 0]
7161 set i [lsearch -exact $arcids($arc) $a]
7162 set j [lsearch -exact $arcids($arc) $b]
7163 if {$i < 0 || $i > $j} {
7164 return 1
7165 } else {
7166 return -1
7170 if {![info exists arcout($a)]} {
7171 set arc [lindex $arcnos($a) 0]
7172 if {[info exists arcend($arc)]} {
7173 set aend $arcend($arc)
7174 } else {
7175 set aend {}
7177 set a $arcstart($arc)
7178 } else {
7179 set aend $a
7181 if {![info exists arcout($b)]} {
7182 set arc [lindex $arcnos($b) 0]
7183 if {[info exists arcend($arc)]} {
7184 set bend $arcend($arc)
7185 } else {
7186 set bend {}
7188 set b $arcstart($arc)
7189 } else {
7190 set bend $b
7192 if {$a eq $bend} {
7193 return 1
7195 if {$b eq $aend} {
7196 return -1
7198 if {[info exists cached_isanc($a,$bend)]} {
7199 if {$cached_isanc($a,$bend)} {
7200 return 1
7203 if {[info exists cached_isanc($b,$aend)]} {
7204 if {$cached_isanc($b,$aend)} {
7205 return -1
7207 if {[info exists cached_isanc($a,$bend)]} {
7208 return 0
7212 set todo [list $a $b]
7213 set anc($a) a
7214 set anc($b) b
7215 for {set i 0} {$i < [llength $todo]} {incr i} {
7216 set x [lindex $todo $i]
7217 if {$anc($x) eq {}} {
7218 continue
7220 foreach arc $arcnos($x) {
7221 set xd $arcstart($arc)
7222 if {$xd eq $bend} {
7223 set cached_isanc($a,$bend) 1
7224 set cached_isanc($b,$aend) 0
7225 return 1
7226 } elseif {$xd eq $aend} {
7227 set cached_isanc($b,$aend) 1
7228 set cached_isanc($a,$bend) 0
7229 return -1
7231 if {![info exists anc($xd)]} {
7232 set anc($xd) $anc($x)
7233 lappend todo $xd
7234 } elseif {$anc($xd) ne $anc($x)} {
7235 set anc($xd) {}
7239 set cached_isanc($a,$bend) 0
7240 set cached_isanc($b,$aend) 0
7241 return 0
7244 # This identifies whether $desc has an ancestor that is
7245 # a growing tip of the graph and which is not an ancestor of $anc
7246 # and returns 0 if so and 1 if not.
7247 # If we subsequently discover a tag on such a growing tip, and that
7248 # turns out to be a descendent of $anc (which it could, since we
7249 # don't necessarily see children before parents), then $desc
7250 # isn't a good choice to display as a descendent tag of
7251 # $anc (since it is the descendent of another tag which is
7252 # a descendent of $anc). Similarly, $anc isn't a good choice to
7253 # display as a ancestor tag of $desc.
7255 proc is_certain {desc anc} {
7256 global arcnos arcout arcstart arcend growing problems
7258 set certain {}
7259 if {[llength $arcnos($anc)] == 1} {
7260 # tags on the same arc are certain
7261 if {$arcnos($desc) eq $arcnos($anc)} {
7262 return 1
7264 if {![info exists arcout($anc)]} {
7265 # if $anc is partway along an arc, use the start of the arc instead
7266 set a [lindex $arcnos($anc) 0]
7267 set anc $arcstart($a)
7270 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7271 set x $desc
7272 } else {
7273 set a [lindex $arcnos($desc) 0]
7274 set x $arcend($a)
7276 if {$x == $anc} {
7277 return 1
7279 set anclist [list $x]
7280 set dl($x) 1
7281 set nnh 1
7282 set ngrowanc 0
7283 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7284 set x [lindex $anclist $i]
7285 if {$dl($x)} {
7286 incr nnh -1
7288 set done($x) 1
7289 foreach a $arcout($x) {
7290 if {[info exists growing($a)]} {
7291 if {![info exists growanc($x)] && $dl($x)} {
7292 set growanc($x) 1
7293 incr ngrowanc
7295 } else {
7296 set y $arcend($a)
7297 if {[info exists dl($y)]} {
7298 if {$dl($y)} {
7299 if {!$dl($x)} {
7300 set dl($y) 0
7301 if {![info exists done($y)]} {
7302 incr nnh -1
7304 if {[info exists growanc($x)]} {
7305 incr ngrowanc -1
7307 set xl [list $y]
7308 for {set k 0} {$k < [llength $xl]} {incr k} {
7309 set z [lindex $xl $k]
7310 foreach c $arcout($z) {
7311 if {[info exists arcend($c)]} {
7312 set v $arcend($c)
7313 if {[info exists dl($v)] && $dl($v)} {
7314 set dl($v) 0
7315 if {![info exists done($v)]} {
7316 incr nnh -1
7318 if {[info exists growanc($v)]} {
7319 incr ngrowanc -1
7321 lappend xl $v
7328 } elseif {$y eq $anc || !$dl($x)} {
7329 set dl($y) 0
7330 lappend anclist $y
7331 } else {
7332 set dl($y) 1
7333 lappend anclist $y
7334 incr nnh
7339 foreach x [array names growanc] {
7340 if {$dl($x)} {
7341 return 0
7343 return 0
7345 return 1
7348 proc validate_arctags {a} {
7349 global arctags idtags
7351 set i -1
7352 set na $arctags($a)
7353 foreach id $arctags($a) {
7354 incr i
7355 if {![info exists idtags($id)]} {
7356 set na [lreplace $na $i $i]
7357 incr i -1
7360 set arctags($a) $na
7363 proc validate_archeads {a} {
7364 global archeads idheads
7366 set i -1
7367 set na $archeads($a)
7368 foreach id $archeads($a) {
7369 incr i
7370 if {![info exists idheads($id)]} {
7371 set na [lreplace $na $i $i]
7372 incr i -1
7375 set archeads($a) $na
7378 # Return the list of IDs that have tags that are descendents of id,
7379 # ignoring IDs that are descendents of IDs already reported.
7380 proc desctags {id} {
7381 global arcnos arcstart arcids arctags idtags allparents
7382 global growing cached_dtags
7384 if {![info exists allparents($id)]} {
7385 return {}
7387 set t1 [clock clicks -milliseconds]
7388 set argid $id
7389 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7390 # part-way along an arc; check that arc first
7391 set a [lindex $arcnos($id) 0]
7392 if {$arctags($a) ne {}} {
7393 validate_arctags $a
7394 set i [lsearch -exact $arcids($a) $id]
7395 set tid {}
7396 foreach t $arctags($a) {
7397 set j [lsearch -exact $arcids($a) $t]
7398 if {$j >= $i} break
7399 set tid $t
7401 if {$tid ne {}} {
7402 return $tid
7405 set id $arcstart($a)
7406 if {[info exists idtags($id)]} {
7407 return $id
7410 if {[info exists cached_dtags($id)]} {
7411 return $cached_dtags($id)
7414 set origid $id
7415 set todo [list $id]
7416 set queued($id) 1
7417 set nc 1
7418 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7419 set id [lindex $todo $i]
7420 set done($id) 1
7421 set ta [info exists hastaggedancestor($id)]
7422 if {!$ta} {
7423 incr nc -1
7425 # ignore tags on starting node
7426 if {!$ta && $i > 0} {
7427 if {[info exists idtags($id)]} {
7428 set tagloc($id) $id
7429 set ta 1
7430 } elseif {[info exists cached_dtags($id)]} {
7431 set tagloc($id) $cached_dtags($id)
7432 set ta 1
7435 foreach a $arcnos($id) {
7436 set d $arcstart($a)
7437 if {!$ta && $arctags($a) ne {}} {
7438 validate_arctags $a
7439 if {$arctags($a) ne {}} {
7440 lappend tagloc($id) [lindex $arctags($a) end]
7443 if {$ta || $arctags($a) ne {}} {
7444 set tomark [list $d]
7445 for {set j 0} {$j < [llength $tomark]} {incr j} {
7446 set dd [lindex $tomark $j]
7447 if {![info exists hastaggedancestor($dd)]} {
7448 if {[info exists done($dd)]} {
7449 foreach b $arcnos($dd) {
7450 lappend tomark $arcstart($b)
7452 if {[info exists tagloc($dd)]} {
7453 unset tagloc($dd)
7455 } elseif {[info exists queued($dd)]} {
7456 incr nc -1
7458 set hastaggedancestor($dd) 1
7462 if {![info exists queued($d)]} {
7463 lappend todo $d
7464 set queued($d) 1
7465 if {![info exists hastaggedancestor($d)]} {
7466 incr nc
7471 set tags {}
7472 foreach id [array names tagloc] {
7473 if {![info exists hastaggedancestor($id)]} {
7474 foreach t $tagloc($id) {
7475 if {[lsearch -exact $tags $t] < 0} {
7476 lappend tags $t
7481 set t2 [clock clicks -milliseconds]
7482 set loopix $i
7484 # remove tags that are descendents of other tags
7485 for {set i 0} {$i < [llength $tags]} {incr i} {
7486 set a [lindex $tags $i]
7487 for {set j 0} {$j < $i} {incr j} {
7488 set b [lindex $tags $j]
7489 set r [anc_or_desc $a $b]
7490 if {$r == 1} {
7491 set tags [lreplace $tags $j $j]
7492 incr j -1
7493 incr i -1
7494 } elseif {$r == -1} {
7495 set tags [lreplace $tags $i $i]
7496 incr i -1
7497 break
7502 if {[array names growing] ne {}} {
7503 # graph isn't finished, need to check if any tag could get
7504 # eclipsed by another tag coming later. Simply ignore any
7505 # tags that could later get eclipsed.
7506 set ctags {}
7507 foreach t $tags {
7508 if {[is_certain $t $origid]} {
7509 lappend ctags $t
7512 if {$tags eq $ctags} {
7513 set cached_dtags($origid) $tags
7514 } else {
7515 set tags $ctags
7517 } else {
7518 set cached_dtags($origid) $tags
7520 set t3 [clock clicks -milliseconds]
7521 if {0 && $t3 - $t1 >= 100} {
7522 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7523 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7525 return $tags
7528 proc anctags {id} {
7529 global arcnos arcids arcout arcend arctags idtags allparents
7530 global growing cached_atags
7532 if {![info exists allparents($id)]} {
7533 return {}
7535 set t1 [clock clicks -milliseconds]
7536 set argid $id
7537 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7538 # part-way along an arc; check that arc first
7539 set a [lindex $arcnos($id) 0]
7540 if {$arctags($a) ne {}} {
7541 validate_arctags $a
7542 set i [lsearch -exact $arcids($a) $id]
7543 foreach t $arctags($a) {
7544 set j [lsearch -exact $arcids($a) $t]
7545 if {$j > $i} {
7546 return $t
7550 if {![info exists arcend($a)]} {
7551 return {}
7553 set id $arcend($a)
7554 if {[info exists idtags($id)]} {
7555 return $id
7558 if {[info exists cached_atags($id)]} {
7559 return $cached_atags($id)
7562 set origid $id
7563 set todo [list $id]
7564 set queued($id) 1
7565 set taglist {}
7566 set nc 1
7567 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7568 set id [lindex $todo $i]
7569 set done($id) 1
7570 set td [info exists hastaggeddescendent($id)]
7571 if {!$td} {
7572 incr nc -1
7574 # ignore tags on starting node
7575 if {!$td && $i > 0} {
7576 if {[info exists idtags($id)]} {
7577 set tagloc($id) $id
7578 set td 1
7579 } elseif {[info exists cached_atags($id)]} {
7580 set tagloc($id) $cached_atags($id)
7581 set td 1
7584 foreach a $arcout($id) {
7585 if {!$td && $arctags($a) ne {}} {
7586 validate_arctags $a
7587 if {$arctags($a) ne {}} {
7588 lappend tagloc($id) [lindex $arctags($a) 0]
7591 if {![info exists arcend($a)]} continue
7592 set d $arcend($a)
7593 if {$td || $arctags($a) ne {}} {
7594 set tomark [list $d]
7595 for {set j 0} {$j < [llength $tomark]} {incr j} {
7596 set dd [lindex $tomark $j]
7597 if {![info exists hastaggeddescendent($dd)]} {
7598 if {[info exists done($dd)]} {
7599 foreach b $arcout($dd) {
7600 if {[info exists arcend($b)]} {
7601 lappend tomark $arcend($b)
7604 if {[info exists tagloc($dd)]} {
7605 unset tagloc($dd)
7607 } elseif {[info exists queued($dd)]} {
7608 incr nc -1
7610 set hastaggeddescendent($dd) 1
7614 if {![info exists queued($d)]} {
7615 lappend todo $d
7616 set queued($d) 1
7617 if {![info exists hastaggeddescendent($d)]} {
7618 incr nc
7623 set t2 [clock clicks -milliseconds]
7624 set loopix $i
7625 set tags {}
7626 foreach id [array names tagloc] {
7627 if {![info exists hastaggeddescendent($id)]} {
7628 foreach t $tagloc($id) {
7629 if {[lsearch -exact $tags $t] < 0} {
7630 lappend tags $t
7636 # remove tags that are ancestors of other tags
7637 for {set i 0} {$i < [llength $tags]} {incr i} {
7638 set a [lindex $tags $i]
7639 for {set j 0} {$j < $i} {incr j} {
7640 set b [lindex $tags $j]
7641 set r [anc_or_desc $a $b]
7642 if {$r == -1} {
7643 set tags [lreplace $tags $j $j]
7644 incr j -1
7645 incr i -1
7646 } elseif {$r == 1} {
7647 set tags [lreplace $tags $i $i]
7648 incr i -1
7649 break
7654 if {[array names growing] ne {}} {
7655 # graph isn't finished, need to check if any tag could get
7656 # eclipsed by another tag coming later. Simply ignore any
7657 # tags that could later get eclipsed.
7658 set ctags {}
7659 foreach t $tags {
7660 if {[is_certain $origid $t]} {
7661 lappend ctags $t
7664 if {$tags eq $ctags} {
7665 set cached_atags($origid) $tags
7666 } else {
7667 set tags $ctags
7669 } else {
7670 set cached_atags($origid) $tags
7672 set t3 [clock clicks -milliseconds]
7673 if {0 && $t3 - $t1 >= 100} {
7674 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7675 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7677 return $tags
7680 # Return the list of IDs that have heads that are descendents of id,
7681 # including id itself if it has a head.
7682 proc descheads {id} {
7683 global arcnos arcstart arcids archeads idheads cached_dheads
7684 global allparents
7686 if {![info exists allparents($id)]} {
7687 return {}
7689 set aret {}
7690 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7691 # part-way along an arc; check it first
7692 set a [lindex $arcnos($id) 0]
7693 if {$archeads($a) ne {}} {
7694 validate_archeads $a
7695 set i [lsearch -exact $arcids($a) $id]
7696 foreach t $archeads($a) {
7697 set j [lsearch -exact $arcids($a) $t]
7698 if {$j > $i} break
7699 lappend aret $t
7702 set id $arcstart($a)
7704 set origid $id
7705 set todo [list $id]
7706 set seen($id) 1
7707 set ret {}
7708 for {set i 0} {$i < [llength $todo]} {incr i} {
7709 set id [lindex $todo $i]
7710 if {[info exists cached_dheads($id)]} {
7711 set ret [concat $ret $cached_dheads($id)]
7712 } else {
7713 if {[info exists idheads($id)]} {
7714 lappend ret $id
7716 foreach a $arcnos($id) {
7717 if {$archeads($a) ne {}} {
7718 validate_archeads $a
7719 if {$archeads($a) ne {}} {
7720 set ret [concat $ret $archeads($a)]
7723 set d $arcstart($a)
7724 if {![info exists seen($d)]} {
7725 lappend todo $d
7726 set seen($d) 1
7731 set ret [lsort -unique $ret]
7732 set cached_dheads($origid) $ret
7733 return [concat $ret $aret]
7736 proc addedtag {id} {
7737 global arcnos arcout cached_dtags cached_atags
7739 if {![info exists arcnos($id)]} return
7740 if {![info exists arcout($id)]} {
7741 recalcarc [lindex $arcnos($id) 0]
7743 catch {unset cached_dtags}
7744 catch {unset cached_atags}
7747 proc addedhead {hid head} {
7748 global arcnos arcout cached_dheads
7750 if {![info exists arcnos($hid)]} return
7751 if {![info exists arcout($hid)]} {
7752 recalcarc [lindex $arcnos($hid) 0]
7754 catch {unset cached_dheads}
7757 proc removedhead {hid head} {
7758 global cached_dheads
7760 catch {unset cached_dheads}
7763 proc movedhead {hid head} {
7764 global arcnos arcout cached_dheads
7766 if {![info exists arcnos($hid)]} return
7767 if {![info exists arcout($hid)]} {
7768 recalcarc [lindex $arcnos($hid) 0]
7770 catch {unset cached_dheads}
7773 proc changedrefs {} {
7774 global cached_dheads cached_dtags cached_atags
7775 global arctags archeads arcnos arcout idheads idtags
7777 foreach id [concat [array names idheads] [array names idtags]] {
7778 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7779 set a [lindex $arcnos($id) 0]
7780 if {![info exists donearc($a)]} {
7781 recalcarc $a
7782 set donearc($a) 1
7786 catch {unset cached_dtags}
7787 catch {unset cached_atags}
7788 catch {unset cached_dheads}
7791 proc rereadrefs {} {
7792 global idtags idheads idotherrefs mainhead
7794 set refids [concat [array names idtags] \
7795 [array names idheads] [array names idotherrefs]]
7796 foreach id $refids {
7797 if {![info exists ref($id)]} {
7798 set ref($id) [listrefs $id]
7801 set oldmainhead $mainhead
7802 readrefs
7803 changedrefs
7804 set refids [lsort -unique [concat $refids [array names idtags] \
7805 [array names idheads] [array names idotherrefs]]]
7806 foreach id $refids {
7807 set v [listrefs $id]
7808 if {![info exists ref($id)] || $ref($id) != $v ||
7809 ($id eq $oldmainhead && $id ne $mainhead) ||
7810 ($id eq $mainhead && $id ne $oldmainhead)} {
7811 redrawtags $id
7814 run refill_reflist
7817 proc listrefs {id} {
7818 global idtags idheads idotherrefs
7820 set x {}
7821 if {[info exists idtags($id)]} {
7822 set x $idtags($id)
7824 set y {}
7825 if {[info exists idheads($id)]} {
7826 set y $idheads($id)
7828 set z {}
7829 if {[info exists idotherrefs($id)]} {
7830 set z $idotherrefs($id)
7832 return [list $x $y $z]
7835 proc showtag {tag isnew} {
7836 global ctext tagcontents tagids linknum tagobjid
7838 if {$isnew} {
7839 addtohistory [list showtag $tag 0]
7841 $ctext conf -state normal
7842 clear_ctext
7843 settabs 0
7844 set linknum 0
7845 if {![info exists tagcontents($tag)]} {
7846 catch {
7847 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7850 if {[info exists tagcontents($tag)]} {
7851 set text $tagcontents($tag)
7852 } else {
7853 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
7855 appendwithlinks $text {}
7856 $ctext conf -state disabled
7857 init_flist {}
7860 proc doquit {} {
7861 global stopped
7862 set stopped 100
7863 savestuff .
7864 destroy .
7867 proc mkfontdisp {font top which} {
7868 global fontattr fontpref $font
7870 set fontpref($font) [set $font]
7871 button $top.${font}but -text $which -font optionfont \
7872 -command [list choosefont $font $which]
7873 label $top.$font -relief flat -font $font \
7874 -text $fontattr($font,family) -justify left
7875 grid x $top.${font}but $top.$font -sticky w
7878 proc choosefont {font which} {
7879 global fontparam fontlist fonttop fontattr
7881 set fontparam(which) $which
7882 set fontparam(font) $font
7883 set fontparam(family) [font actual $font -family]
7884 set fontparam(size) $fontattr($font,size)
7885 set fontparam(weight) $fontattr($font,weight)
7886 set fontparam(slant) $fontattr($font,slant)
7887 set top .gitkfont
7888 set fonttop $top
7889 if {![winfo exists $top]} {
7890 font create sample
7891 eval font config sample [font actual $font]
7892 toplevel $top
7893 wm title $top [mc "Gitk font chooser"]
7894 label $top.l -textvariable fontparam(which)
7895 pack $top.l -side top
7896 set fontlist [lsort [font families]]
7897 frame $top.f
7898 listbox $top.f.fam -listvariable fontlist \
7899 -yscrollcommand [list $top.f.sb set]
7900 bind $top.f.fam <<ListboxSelect>> selfontfam
7901 scrollbar $top.f.sb -command [list $top.f.fam yview]
7902 pack $top.f.sb -side right -fill y
7903 pack $top.f.fam -side left -fill both -expand 1
7904 pack $top.f -side top -fill both -expand 1
7905 frame $top.g
7906 spinbox $top.g.size -from 4 -to 40 -width 4 \
7907 -textvariable fontparam(size) \
7908 -validatecommand {string is integer -strict %s}
7909 checkbutton $top.g.bold -padx 5 \
7910 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7911 -variable fontparam(weight) -onvalue bold -offvalue normal
7912 checkbutton $top.g.ital -padx 5 \
7913 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7914 -variable fontparam(slant) -onvalue italic -offvalue roman
7915 pack $top.g.size $top.g.bold $top.g.ital -side left
7916 pack $top.g -side top
7917 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7918 -background white
7919 $top.c create text 100 25 -anchor center -text $which -font sample \
7920 -fill black -tags text
7921 bind $top.c <Configure> [list centertext $top.c]
7922 pack $top.c -side top -fill x
7923 frame $top.buts
7924 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7925 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7926 grid $top.buts.ok $top.buts.can
7927 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7928 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7929 pack $top.buts -side bottom -fill x
7930 trace add variable fontparam write chg_fontparam
7931 } else {
7932 raise $top
7933 $top.c itemconf text -text $which
7935 set i [lsearch -exact $fontlist $fontparam(family)]
7936 if {$i >= 0} {
7937 $top.f.fam selection set $i
7938 $top.f.fam see $i
7942 proc centertext {w} {
7943 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7946 proc fontok {} {
7947 global fontparam fontpref prefstop
7949 set f $fontparam(font)
7950 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7951 if {$fontparam(weight) eq "bold"} {
7952 lappend fontpref($f) "bold"
7954 if {$fontparam(slant) eq "italic"} {
7955 lappend fontpref($f) "italic"
7957 set w $prefstop.$f
7958 $w conf -text $fontparam(family) -font $fontpref($f)
7960 fontcan
7963 proc fontcan {} {
7964 global fonttop fontparam
7966 if {[info exists fonttop]} {
7967 catch {destroy $fonttop}
7968 catch {font delete sample}
7969 unset fonttop
7970 unset fontparam
7974 proc selfontfam {} {
7975 global fonttop fontparam
7977 set i [$fonttop.f.fam curselection]
7978 if {$i ne {}} {
7979 set fontparam(family) [$fonttop.f.fam get $i]
7983 proc chg_fontparam {v sub op} {
7984 global fontparam
7986 font config sample -$sub $fontparam($sub)
7989 proc doprefs {} {
7990 global maxwidth maxgraphpct
7991 global oldprefs prefstop showneartags showlocalchanges
7992 global bgcolor fgcolor ctext diffcolors selectbgcolor
7993 global tabstop limitdiffs autoselect
7995 set top .gitkprefs
7996 set prefstop $top
7997 if {[winfo exists $top]} {
7998 raise $top
7999 return
8001 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8002 limitdiffs tabstop} {
8003 set oldprefs($v) [set $v]
8005 toplevel $top
8006 wm title $top [mc "Gitk preferences"]
8007 label $top.ldisp -text [mc "Commit list display options"]
8008 grid $top.ldisp - -sticky w -pady 10
8009 label $top.spacer -text " "
8010 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8011 -font optionfont
8012 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8013 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8014 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8015 -font optionfont
8016 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8017 grid x $top.maxpctl $top.maxpct -sticky w
8018 frame $top.showlocal
8019 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8020 checkbutton $top.showlocal.b -variable showlocalchanges
8021 pack $top.showlocal.b $top.showlocal.l -side left
8022 grid x $top.showlocal -sticky w
8023 frame $top.autoselect
8024 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8025 checkbutton $top.autoselect.b -variable autoselect
8026 pack $top.autoselect.b $top.autoselect.l -side left
8027 grid x $top.autoselect -sticky w
8029 label $top.ddisp -text [mc "Diff display options"]
8030 grid $top.ddisp - -sticky w -pady 10
8031 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8032 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8033 grid x $top.tabstopl $top.tabstop -sticky w
8034 frame $top.ntag
8035 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8036 checkbutton $top.ntag.b -variable showneartags
8037 pack $top.ntag.b $top.ntag.l -side left
8038 grid x $top.ntag -sticky w
8039 frame $top.ldiff
8040 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8041 checkbutton $top.ldiff.b -variable limitdiffs
8042 pack $top.ldiff.b $top.ldiff.l -side left
8043 grid x $top.ldiff -sticky w
8045 label $top.cdisp -text [mc "Colors: press to choose"]
8046 grid $top.cdisp - -sticky w -pady 10
8047 label $top.bg -padx 40 -relief sunk -background $bgcolor
8048 button $top.bgbut -text [mc "Background"] -font optionfont \
8049 -command [list choosecolor bgcolor {} $top.bg background setbg]
8050 grid x $top.bgbut $top.bg -sticky w
8051 label $top.fg -padx 40 -relief sunk -background $fgcolor
8052 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8053 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
8054 grid x $top.fgbut $top.fg -sticky w
8055 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8056 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8057 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8058 [list $ctext tag conf d0 -foreground]]
8059 grid x $top.diffoldbut $top.diffold -sticky w
8060 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8061 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8062 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8063 [list $ctext tag conf d1 -foreground]]
8064 grid x $top.diffnewbut $top.diffnew -sticky w
8065 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8066 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8067 -command [list choosecolor diffcolors 2 $top.hunksep \
8068 "diff hunk header" \
8069 [list $ctext tag conf hunksep -foreground]]
8070 grid x $top.hunksepbut $top.hunksep -sticky w
8071 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8072 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8073 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
8074 grid x $top.selbgbut $top.selbgsep -sticky w
8076 label $top.cfont -text [mc "Fonts: press to choose"]
8077 grid $top.cfont - -sticky w -pady 10
8078 mkfontdisp mainfont $top [mc "Main font"]
8079 mkfontdisp textfont $top [mc "Diff display font"]
8080 mkfontdisp uifont $top [mc "User interface font"]
8082 frame $top.buts
8083 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8084 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8085 grid $top.buts.ok $top.buts.can
8086 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8087 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8088 grid $top.buts - - -pady 10 -sticky ew
8089 bind $top <Visibility> "focus $top.buts.ok"
8092 proc choosecolor {v vi w x cmd} {
8093 global $v
8095 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8096 -title [mc "Gitk: choose color for %s" $x]]
8097 if {$c eq {}} return
8098 $w conf -background $c
8099 lset $v $vi $c
8100 eval $cmd $c
8103 proc setselbg {c} {
8104 global bglist cflist
8105 foreach w $bglist {
8106 $w configure -selectbackground $c
8108 $cflist tag configure highlight \
8109 -background [$cflist cget -selectbackground]
8110 allcanvs itemconf secsel -fill $c
8113 proc setbg {c} {
8114 global bglist
8116 foreach w $bglist {
8117 $w conf -background $c
8121 proc setfg {c} {
8122 global fglist canv
8124 foreach w $fglist {
8125 $w conf -foreground $c
8127 allcanvs itemconf text -fill $c
8128 $canv itemconf circle -outline $c
8131 proc prefscan {} {
8132 global oldprefs prefstop
8134 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8135 limitdiffs tabstop} {
8136 global $v
8137 set $v $oldprefs($v)
8139 catch {destroy $prefstop}
8140 unset prefstop
8141 fontcan
8144 proc prefsok {} {
8145 global maxwidth maxgraphpct
8146 global oldprefs prefstop showneartags showlocalchanges
8147 global fontpref mainfont textfont uifont
8148 global limitdiffs treediffs
8150 catch {destroy $prefstop}
8151 unset prefstop
8152 fontcan
8153 set fontchanged 0
8154 if {$mainfont ne $fontpref(mainfont)} {
8155 set mainfont $fontpref(mainfont)
8156 parsefont mainfont $mainfont
8157 eval font configure mainfont [fontflags mainfont]
8158 eval font configure mainfontbold [fontflags mainfont 1]
8159 setcoords
8160 set fontchanged 1
8162 if {$textfont ne $fontpref(textfont)} {
8163 set textfont $fontpref(textfont)
8164 parsefont textfont $textfont
8165 eval font configure textfont [fontflags textfont]
8166 eval font configure textfontbold [fontflags textfont 1]
8168 if {$uifont ne $fontpref(uifont)} {
8169 set uifont $fontpref(uifont)
8170 parsefont uifont $uifont
8171 eval font configure uifont [fontflags uifont]
8173 settabs
8174 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8175 if {$showlocalchanges} {
8176 doshowlocalchanges
8177 } else {
8178 dohidelocalchanges
8181 if {$limitdiffs != $oldprefs(limitdiffs)} {
8182 # treediffs elements are limited by path
8183 catch {unset treediffs}
8185 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8186 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8187 redisplay
8188 } elseif {$showneartags != $oldprefs(showneartags) ||
8189 $limitdiffs != $oldprefs(limitdiffs)} {
8190 reselectline
8194 proc formatdate {d} {
8195 global datetimeformat
8196 if {$d ne {}} {
8197 set d [clock format $d -format $datetimeformat]
8199 return $d
8202 # This list of encoding names and aliases is distilled from
8203 # http://www.iana.org/assignments/character-sets.
8204 # Not all of them are supported by Tcl.
8205 set encoding_aliases {
8206 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8207 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8208 { ISO-10646-UTF-1 csISO10646UTF1 }
8209 { ISO_646.basic:1983 ref csISO646basic1983 }
8210 { INVARIANT csINVARIANT }
8211 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8212 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8213 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8214 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8215 { NATS-DANO iso-ir-9-1 csNATSDANO }
8216 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8217 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8218 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8219 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8220 { ISO-2022-KR csISO2022KR }
8221 { EUC-KR csEUCKR }
8222 { ISO-2022-JP csISO2022JP }
8223 { ISO-2022-JP-2 csISO2022JP2 }
8224 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8225 csISO13JISC6220jp }
8226 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8227 { IT iso-ir-15 ISO646-IT csISO15Italian }
8228 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8229 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8230 { greek7-old iso-ir-18 csISO18Greek7Old }
8231 { latin-greek iso-ir-19 csISO19LatinGreek }
8232 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8233 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8234 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8235 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8236 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8237 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8238 { INIS iso-ir-49 csISO49INIS }
8239 { INIS-8 iso-ir-50 csISO50INIS8 }
8240 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8241 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8242 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8243 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8244 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8245 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8246 csISO60Norwegian1 }
8247 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8248 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8249 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8250 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8251 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8252 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8253 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8254 { greek7 iso-ir-88 csISO88Greek7 }
8255 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8256 { iso-ir-90 csISO90 }
8257 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8258 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8259 csISO92JISC62991984b }
8260 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8261 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8262 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8263 csISO95JIS62291984handadd }
8264 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8265 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8266 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8267 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8268 CP819 csISOLatin1 }
8269 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8270 { T.61-7bit iso-ir-102 csISO102T617bit }
8271 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8272 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8273 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8274 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8275 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8276 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8277 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8278 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8279 arabic csISOLatinArabic }
8280 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8281 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8282 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8283 greek greek8 csISOLatinGreek }
8284 { T.101-G2 iso-ir-128 csISO128T101G2 }
8285 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8286 csISOLatinHebrew }
8287 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8288 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8289 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8290 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8291 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8292 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8293 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8294 csISOLatinCyrillic }
8295 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8296 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8297 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8298 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8299 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8300 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8301 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8302 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8303 { ISO_10367-box iso-ir-155 csISO10367Box }
8304 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8305 { latin-lap lap iso-ir-158 csISO158Lap }
8306 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8307 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8308 { us-dk csUSDK }
8309 { dk-us csDKUS }
8310 { JIS_X0201 X0201 csHalfWidthKatakana }
8311 { KSC5636 ISO646-KR csKSC5636 }
8312 { ISO-10646-UCS-2 csUnicode }
8313 { ISO-10646-UCS-4 csUCS4 }
8314 { DEC-MCS dec csDECMCS }
8315 { hp-roman8 roman8 r8 csHPRoman8 }
8316 { macintosh mac csMacintosh }
8317 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8318 csIBM037 }
8319 { IBM038 EBCDIC-INT cp038 csIBM038 }
8320 { IBM273 CP273 csIBM273 }
8321 { IBM274 EBCDIC-BE CP274 csIBM274 }
8322 { IBM275 EBCDIC-BR cp275 csIBM275 }
8323 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8324 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8325 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8326 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8327 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8328 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8329 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8330 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8331 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8332 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8333 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8334 { IBM437 cp437 437 csPC8CodePage437 }
8335 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8336 { IBM775 cp775 csPC775Baltic }
8337 { IBM850 cp850 850 csPC850Multilingual }
8338 { IBM851 cp851 851 csIBM851 }
8339 { IBM852 cp852 852 csPCp852 }
8340 { IBM855 cp855 855 csIBM855 }
8341 { IBM857 cp857 857 csIBM857 }
8342 { IBM860 cp860 860 csIBM860 }
8343 { IBM861 cp861 861 cp-is csIBM861 }
8344 { IBM862 cp862 862 csPC862LatinHebrew }
8345 { IBM863 cp863 863 csIBM863 }
8346 { IBM864 cp864 csIBM864 }
8347 { IBM865 cp865 865 csIBM865 }
8348 { IBM866 cp866 866 csIBM866 }
8349 { IBM868 CP868 cp-ar csIBM868 }
8350 { IBM869 cp869 869 cp-gr csIBM869 }
8351 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8352 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8353 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8354 { IBM891 cp891 csIBM891 }
8355 { IBM903 cp903 csIBM903 }
8356 { IBM904 cp904 904 csIBBM904 }
8357 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8358 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8359 { IBM1026 CP1026 csIBM1026 }
8360 { EBCDIC-AT-DE csIBMEBCDICATDE }
8361 { EBCDIC-AT-DE-A csEBCDICATDEA }
8362 { EBCDIC-CA-FR csEBCDICCAFR }
8363 { EBCDIC-DK-NO csEBCDICDKNO }
8364 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8365 { EBCDIC-FI-SE csEBCDICFISE }
8366 { EBCDIC-FI-SE-A csEBCDICFISEA }
8367 { EBCDIC-FR csEBCDICFR }
8368 { EBCDIC-IT csEBCDICIT }
8369 { EBCDIC-PT csEBCDICPT }
8370 { EBCDIC-ES csEBCDICES }
8371 { EBCDIC-ES-A csEBCDICESA }
8372 { EBCDIC-ES-S csEBCDICESS }
8373 { EBCDIC-UK csEBCDICUK }
8374 { EBCDIC-US csEBCDICUS }
8375 { UNKNOWN-8BIT csUnknown8BiT }
8376 { MNEMONIC csMnemonic }
8377 { MNEM csMnem }
8378 { VISCII csVISCII }
8379 { VIQR csVIQR }
8380 { KOI8-R csKOI8R }
8381 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8382 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8383 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8384 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8385 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8386 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8387 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8388 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8389 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8390 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8391 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8392 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8393 { IBM1047 IBM-1047 }
8394 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8395 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8396 { UNICODE-1-1 csUnicode11 }
8397 { CESU-8 csCESU-8 }
8398 { BOCU-1 csBOCU-1 }
8399 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8400 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8401 l8 }
8402 { ISO-8859-15 ISO_8859-15 Latin-9 }
8403 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8404 { GBK CP936 MS936 windows-936 }
8405 { JIS_Encoding csJISEncoding }
8406 { Shift_JIS MS_Kanji csShiftJIS }
8407 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8408 EUC-JP }
8409 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8410 { ISO-10646-UCS-Basic csUnicodeASCII }
8411 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8412 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8413 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8414 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8415 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8416 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8417 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8418 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8419 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8420 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8421 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8422 { Ventura-US csVenturaUS }
8423 { Ventura-International csVenturaInternational }
8424 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8425 { PC8-Turkish csPC8Turkish }
8426 { IBM-Symbols csIBMSymbols }
8427 { IBM-Thai csIBMThai }
8428 { HP-Legal csHPLegal }
8429 { HP-Pi-font csHPPiFont }
8430 { HP-Math8 csHPMath8 }
8431 { Adobe-Symbol-Encoding csHPPSMath }
8432 { HP-DeskTop csHPDesktop }
8433 { Ventura-Math csVenturaMath }
8434 { Microsoft-Publishing csMicrosoftPublishing }
8435 { Windows-31J csWindows31J }
8436 { GB2312 csGB2312 }
8437 { Big5 csBig5 }
8440 proc tcl_encoding {enc} {
8441 global encoding_aliases
8442 set names [encoding names]
8443 set lcnames [string tolower $names]
8444 set enc [string tolower $enc]
8445 set i [lsearch -exact $lcnames $enc]
8446 if {$i < 0} {
8447 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8448 if {[regsub {^iso[-_]} $enc iso encx]} {
8449 set i [lsearch -exact $lcnames $encx]
8452 if {$i < 0} {
8453 foreach l $encoding_aliases {
8454 set ll [string tolower $l]
8455 if {[lsearch -exact $ll $enc] < 0} continue
8456 # look through the aliases for one that tcl knows about
8457 foreach e $ll {
8458 set i [lsearch -exact $lcnames $e]
8459 if {$i < 0} {
8460 if {[regsub {^iso[-_]} $e iso ex]} {
8461 set i [lsearch -exact $lcnames $ex]
8464 if {$i >= 0} break
8466 break
8469 if {$i >= 0} {
8470 return [lindex $names $i]
8472 return {}
8475 # First check that Tcl/Tk is recent enough
8476 if {[catch {package require Tk 8.4} err]} {
8477 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8478 Gitk requires at least Tcl/Tk 8.4."]
8479 exit 1
8482 # defaults...
8483 set datemode 0
8484 set wrcomcmd "git diff-tree --stdin -p --pretty"
8486 set gitencoding {}
8487 catch {
8488 set gitencoding [exec git config --get i18n.commitencoding]
8490 if {$gitencoding == ""} {
8491 set gitencoding "utf-8"
8493 set tclencoding [tcl_encoding $gitencoding]
8494 if {$tclencoding == {}} {
8495 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8498 set mainfont {Helvetica 9}
8499 set textfont {Courier 9}
8500 set uifont {Helvetica 9 bold}
8501 set tabstop 8
8502 set findmergefiles 0
8503 set maxgraphpct 50
8504 set maxwidth 16
8505 set revlistorder 0
8506 set fastdate 0
8507 set uparrowlen 5
8508 set downarrowlen 5
8509 set mingaplen 100
8510 set cmitmode "patch"
8511 set wrapcomment "none"
8512 set showneartags 1
8513 set maxrefs 20
8514 set maxlinelen 200
8515 set showlocalchanges 1
8516 set limitdiffs 1
8517 set datetimeformat "%Y-%m-%d %H:%M:%S"
8518 set autoselect 1
8520 set colors {green red blue magenta darkgrey brown orange}
8521 set bgcolor white
8522 set fgcolor black
8523 set diffcolors {red "#00a000" blue}
8524 set diffcontext 3
8525 set ignorespace 0
8526 set selectbgcolor gray85
8528 ## For msgcat loading, first locate the installation location.
8529 if { [info exists ::env(GITK_MSGSDIR)] } {
8530 ## Msgsdir was manually set in the environment.
8531 set gitk_msgsdir $::env(GITK_MSGSDIR)
8532 } else {
8533 ## Let's guess the prefix from argv0.
8534 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8535 set gitk_libdir [file join $gitk_prefix share gitk lib]
8536 set gitk_msgsdir [file join $gitk_libdir msgs]
8537 unset gitk_prefix
8540 ## Internationalization (i18n) through msgcat and gettext. See
8541 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8542 package require msgcat
8543 namespace import ::msgcat::mc
8544 ## And eventually load the actual message catalog
8545 ::msgcat::mcload $gitk_msgsdir
8547 catch {source ~/.gitk}
8549 font create optionfont -family sans-serif -size -12
8551 parsefont mainfont $mainfont
8552 eval font create mainfont [fontflags mainfont]
8553 eval font create mainfontbold [fontflags mainfont 1]
8555 parsefont textfont $textfont
8556 eval font create textfont [fontflags textfont]
8557 eval font create textfontbold [fontflags textfont 1]
8559 parsefont uifont $uifont
8560 eval font create uifont [fontflags uifont]
8562 setoptions
8564 # check that we can find a .git directory somewhere...
8565 if {[catch {set gitdir [gitdir]}]} {
8566 show_error {} . [mc "Cannot find a git repository here."]
8567 exit 1
8569 if {![file isdirectory $gitdir]} {
8570 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8571 exit 1
8574 set mergeonly 0
8575 set revtreeargs {}
8576 set cmdline_files {}
8577 set i 0
8578 set revtreeargscmd {}
8579 foreach arg $argv {
8580 switch -glob -- $arg {
8581 "" { }
8582 "-d" { set datemode 1 }
8583 "--merge" {
8584 set mergeonly 1
8585 lappend revtreeargs $arg
8587 "--" {
8588 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8589 break
8591 "--argscmd=*" {
8592 set revtreeargscmd [string range $arg 10 end]
8594 default {
8595 lappend revtreeargs $arg
8598 incr i
8601 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8602 # no -- on command line, but some arguments (other than -d)
8603 if {[catch {
8604 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8605 set cmdline_files [split $f "\n"]
8606 set n [llength $cmdline_files]
8607 set revtreeargs [lrange $revtreeargs 0 end-$n]
8608 # Unfortunately git rev-parse doesn't produce an error when
8609 # something is both a revision and a filename. To be consistent
8610 # with git log and git rev-list, check revtreeargs for filenames.
8611 foreach arg $revtreeargs {
8612 if {[file exists $arg]} {
8613 show_error {} . [mc "Ambiguous argument '%s': both revision\
8614 and filename" $arg]
8615 exit 1
8618 } err]} {
8619 # unfortunately we get both stdout and stderr in $err,
8620 # so look for "fatal:".
8621 set i [string first "fatal:" $err]
8622 if {$i > 0} {
8623 set err [string range $err [expr {$i + 6}] end]
8625 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8626 exit 1
8630 if {$mergeonly} {
8631 # find the list of unmerged files
8632 set mlist {}
8633 set nr_unmerged 0
8634 if {[catch {
8635 set fd [open "| git ls-files -u" r]
8636 } err]} {
8637 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8638 exit 1
8640 while {[gets $fd line] >= 0} {
8641 set i [string first "\t" $line]
8642 if {$i < 0} continue
8643 set fname [string range $line [expr {$i+1}] end]
8644 if {[lsearch -exact $mlist $fname] >= 0} continue
8645 incr nr_unmerged
8646 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8647 lappend mlist $fname
8650 catch {close $fd}
8651 if {$mlist eq {}} {
8652 if {$nr_unmerged == 0} {
8653 show_error {} . [mc "No files selected: --merge specified but\
8654 no files are unmerged."]
8655 } else {
8656 show_error {} . [mc "No files selected: --merge specified but\
8657 no unmerged files are within file limit."]
8659 exit 1
8661 set cmdline_files $mlist
8664 set nullid "0000000000000000000000000000000000000000"
8665 set nullid2 "0000000000000000000000000000000000000001"
8667 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8669 set runq {}
8670 set history {}
8671 set historyindex 0
8672 set fh_serial 0
8673 set nhl_names {}
8674 set highlight_paths {}
8675 set findpattern {}
8676 set searchdirn -forwards
8677 set boldrows {}
8678 set boldnamerows {}
8679 set diffelide {0 0}
8680 set markingmatches 0
8681 set linkentercount 0
8682 set need_redisplay 0
8683 set nrows_drawn 0
8684 set firsttabstop 0
8686 set nextviewnum 1
8687 set curview 0
8688 set selectedview 0
8689 set selectedhlview [mc "None"]
8690 set highlight_related [mc "None"]
8691 set highlight_files {}
8692 set viewfiles(0) {}
8693 set viewperm(0) 0
8694 set viewargs(0) {}
8695 set viewargscmd(0) {}
8697 set cmdlineok 0
8698 set stopped 0
8699 set stuffsaved 0
8700 set patchnum 0
8701 set localirow -1
8702 set localfrow -1
8703 set lserial 0
8704 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
8705 setcoords
8706 makewindow
8707 # wait for the window to become visible
8708 tkwait visibility .
8709 wm title . "[file tail $argv0]: [file tail [pwd]]"
8710 readrefs
8712 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8713 # create a view for the files/dirs specified on the command line
8714 set curview 1
8715 set selectedview 1
8716 set nextviewnum 2
8717 set viewname(1) [mc "Command line"]
8718 set viewfiles(1) $cmdline_files
8719 set viewargs(1) $revtreeargs
8720 set viewargscmd(1) $revtreeargscmd
8721 set viewperm(1) 0
8722 addviewmenu 1
8723 .bar.view entryconf [mc "Edit view..."] -state normal
8724 .bar.view entryconf [mc "Delete view"] -state normal
8727 if {[info exists permviews]} {
8728 foreach v $permviews {
8729 set n $nextviewnum
8730 incr nextviewnum
8731 set viewname($n) [lindex $v 0]
8732 set viewfiles($n) [lindex $v 1]
8733 set viewargs($n) [lindex $v 2]
8734 set viewargscmd($n) [lindex $v 3]
8735 set viewperm($n) 1
8736 addviewmenu $n
8739 getcommits