2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "${1+$@}"
5 # Copyright (C) 2005 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 getcommits {rargs} {
11 global commits commfd phase canv mainfont env
12 global startmsecs nextupdate
13 global ctext maincursor textcursor leftover
15 # check that we can find a .git directory somewhere...
16 if {[info exists env(GIT_DIR)]} {
17 set gitdir $env(GIT_DIR)
21 if {![file isdirectory $gitdir]} {
22 error_popup "Cannot find the git directory \"$gitdir\"."
27 set startmsecs [clock clicks -milliseconds]
28 set nextupdate [expr $startmsecs + 100]
30 set parse_args [concat --default HEAD $rargs]
31 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
33 # if git-rev-parse failed for some reason...
37 set parsed_args $rargs
40 set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
42 puts stderr "Error executing git-rev-list: $err"
46 fconfigure $commfd -blocking 0 -translation binary
47 fileevent $commfd readable "getcommitlines $commfd"
49 $canv create text 3 3 -anchor nw -text "Reading commits..." \
50 -font $mainfont -tags textitems
51 . config -cursor watch
52 $ctext config -cursor watch
55 proc getcommitlines {commfd} {
56 global commits parents cdate children nchildren
57 global commitlisted phase commitinfo nextupdate
58 global stopped redisplaying leftover
60 set stuff [read $commfd]
62 if {![eof $commfd]} return
63 # this works around what is apparently a bug in Tcl...
64 fconfigure $commfd -blocking 1
65 if {![catch {close $commfd} err]} {
66 after idle finishcommits
69 if {[string range $err 0 4] == "usage"} {
71 {Gitk: error reading commits: bad arguments to git-rev-list.
72 (Note: arguments to gitk are passed to git-rev-list
73 to allow selection of commits to be displayed.)}
75 set err "Error reading commits: $err"
82 set i [string first "\0" $stuff $start]
84 append leftover [string range $stuff $start end]
87 set cmit [string range $stuff $start [expr {$i - 1}]]
89 set cmit "$leftover$cmit"
92 set start [expr {$i + 1}]
93 if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
95 if {[string length $shortcmit] > 80} {
96 set shortcmit "[string range $shortcmit 0 80]..."
98 error_popup "Can't parse git-rev-list output: {$shortcmit}"
101 set cmit [string range $cmit 41 end]
103 set commitlisted($id) 1
104 parsecommit $id $cmit 1
106 if {[clock clicks -milliseconds] >= $nextupdate} {
109 while {$redisplaying} {
113 set phase "getcommits"
114 foreach id $commits {
117 if {[clock clicks -milliseconds] >= $nextupdate} {
127 global commfd nextupdate
130 fileevent $commfd readable {}
132 fileevent $commfd readable "getcommitlines $commfd"
135 proc readcommit {id} {
136 if [catch {set contents [exec git-cat-file commit $id]}] return
137 parsecommit $id $contents 0
140 proc parsecommit {id contents listed} {
141 global commitinfo children nchildren parents nparents cdate ncleft
150 if {![info exists nchildren($id)]} {
157 foreach line [split $contents "\n"] {
162 set tag [lindex $line 0]
163 if {$tag == "parent"} {
164 set p [lindex $line 1]
165 if {![info exists nchildren($p)]} {
170 lappend parents($id) $p
172 # sometimes we get a commit that lists a parent twice...
173 if {$listed && [lsearch -exact $children($p) $id] < 0} {
174 lappend children($p) $id
178 } elseif {$tag == "author"} {
179 set x [expr {[llength $line] - 2}]
180 set audate [lindex $line $x]
181 set auname [lrange $line 1 [expr {$x - 1}]]
182 } elseif {$tag == "committer"} {
183 set x [expr {[llength $line] - 2}]
184 set comdate [lindex $line $x]
185 set comname [lrange $line 1 [expr {$x - 1}]]
189 if {$comment == {}} {
190 set headline [string trim $line]
195 # git-rev-list indents the comment by 4 spaces;
196 # if we got this via git-cat-file, add the indentation
203 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
205 if {$comdate != {}} {
206 set cdate($id) $comdate
207 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
209 set commitinfo($id) [list $headline $auname $audate \
210 $comname $comdate $comment]
214 global tagids idtags headids idheads
215 set tags [glob -nocomplain -types f .git/refs/tags/*]
220 if {[regexp {^[0-9a-f]{40}} $line id]} {
221 set direct [file tail $f]
222 set tagids($direct) $id
223 lappend idtags($id) $direct
224 set contents [split [exec git-cat-file tag $id] "\n"]
228 foreach l $contents {
230 switch -- [lindex $l 0] {
231 "object" {set obj [lindex $l 1]}
232 "type" {set type [lindex $l 1]}
233 "tag" {set tag [string range $l 4 end]}
236 if {$obj != {} && $type == "commit" && $tag != {}} {
237 set tagids($tag) $obj
238 lappend idtags($obj) $tag
244 set heads [glob -nocomplain -types f .git/refs/heads/*]
248 set line [read $fd 40]
249 if {[regexp {^[0-9a-f]{40}} $line id]} {
250 set head [file tail $f]
251 set headids($head) $line
252 lappend idheads($line) $head
259 proc error_popup msg {
263 message $w.m -text $msg -justify center -aspect 400
264 pack $w.m -side top -fill x -padx 20 -pady 20
265 button $w.ok -text OK -command "destroy $w"
266 pack $w.ok -side bottom -fill x
267 bind $w <Visibility> "grab $w; focus $w"
272 global canv canv2 canv3 linespc charspc ctext cflist textfont
273 global findtype findtypemenu findloc findstring fstring geometry
274 global entries sha1entry sha1string sha1but
275 global maincursor textcursor
279 .bar add cascade -label "File" -menu .bar.file
281 .bar.file add command -label "Quit" -command doquit
283 .bar add cascade -label "Help" -menu .bar.help
284 .bar.help add command -label "About gitk" -command about
285 . configure -menu .bar
287 if {![info exists geometry(canv1)]} {
288 set geometry(canv1) [expr 45 * $charspc]
289 set geometry(canv2) [expr 30 * $charspc]
290 set geometry(canv3) [expr 15 * $charspc]
291 set geometry(canvh) [expr 25 * $linespc + 4]
292 set geometry(ctextw) 80
293 set geometry(ctexth) 30
294 set geometry(cflistw) 30
296 panedwindow .ctop -orient vertical
297 if {[info exists geometry(width)]} {
298 .ctop conf -width $geometry(width) -height $geometry(height)
299 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
300 set geometry(ctexth) [expr {($texth - 8) /
301 [font metrics $textfont -linespace]}]
305 pack .ctop.top.bar -side bottom -fill x
306 set cscroll .ctop.top.csb
307 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
308 pack $cscroll -side right -fill y
309 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
310 pack .ctop.top.clist -side top -fill both -expand 1
312 set canv .ctop.top.clist.canv
313 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
315 -yscrollincr $linespc -yscrollcommand "$cscroll set"
316 .ctop.top.clist add $canv
317 set canv2 .ctop.top.clist.canv2
318 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
319 -bg white -bd 0 -yscrollincr $linespc
320 .ctop.top.clist add $canv2
321 set canv3 .ctop.top.clist.canv3
322 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
323 -bg white -bd 0 -yscrollincr $linespc
324 .ctop.top.clist add $canv3
325 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
327 set sha1entry .ctop.top.bar.sha1
328 set entries $sha1entry
329 set sha1but .ctop.top.bar.sha1label
330 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
331 -command gotocommit -width 8
332 $sha1but conf -disabledforeground [$sha1but cget -foreground]
333 pack .ctop.top.bar.sha1label -side left
334 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
335 trace add variable sha1string write sha1change
336 pack $sha1entry -side left -pady 2
337 button .ctop.top.bar.findbut -text "Find" -command dofind
338 pack .ctop.top.bar.findbut -side left
340 set fstring .ctop.top.bar.findstring
341 lappend entries $fstring
342 entry $fstring -width 30 -font $textfont -textvariable findstring
343 pack $fstring -side left -expand 1 -fill x
345 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
346 findtype Exact IgnCase Regexp]
347 set findloc "All fields"
348 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
349 Comments Author Committer Files Pickaxe
350 pack .ctop.top.bar.findloc -side right
351 pack .ctop.top.bar.findtype -side right
352 # for making sure type==Exact whenever loc==Pickaxe
353 trace add variable findloc write findlocchange
355 panedwindow .ctop.cdet -orient horizontal
357 frame .ctop.cdet.left
358 set ctext .ctop.cdet.left.ctext
359 text $ctext -bg white -state disabled -font $textfont \
360 -width $geometry(ctextw) -height $geometry(ctexth) \
361 -yscrollcommand ".ctop.cdet.left.sb set"
362 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
363 pack .ctop.cdet.left.sb -side right -fill y
364 pack $ctext -side left -fill both -expand 1
365 .ctop.cdet add .ctop.cdet.left
367 $ctext tag conf filesep -font [concat $textfont bold]
368 $ctext tag conf hunksep -back blue -fore white
369 $ctext tag conf d0 -back "#ff8080"
370 $ctext tag conf d1 -back green
371 $ctext tag conf found -back yellow
373 frame .ctop.cdet.right
374 set cflist .ctop.cdet.right.cfiles
375 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
376 -yscrollcommand ".ctop.cdet.right.sb set"
377 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
378 pack .ctop.cdet.right.sb -side right -fill y
379 pack $cflist -side left -fill both -expand 1
380 .ctop.cdet add .ctop.cdet.right
381 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
383 pack .ctop -side top -fill both -expand 1
385 bindall <1> {selcanvline %W %x %y}
386 #bindall <B1-Motion> {selcanvline %W %x %y}
387 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
388 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
389 bindall <2> "allcanvs scan mark 0 %y"
390 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
391 bind . <Key-Up> "selnextline -1"
392 bind . <Key-Down> "selnextline 1"
393 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
394 bind . <Key-Next> "allcanvs yview scroll 1 pages"
395 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
396 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
397 bindkey <Key-space> "$ctext yview scroll 1 pages"
398 bindkey p "selnextline -1"
399 bindkey n "selnextline 1"
400 bindkey b "$ctext yview scroll -1 pages"
401 bindkey d "$ctext yview scroll 18 units"
402 bindkey u "$ctext yview scroll -18 units"
403 bindkey / {findnext 1}
404 bindkey <Key-Return> {findnext 0}
407 bind . <Control-q> doquit
408 bind . <Control-f> dofind
409 bind . <Control-g> {findnext 0}
410 bind . <Control-r> findprev
411 bind . <Control-equal> {incrfont 1}
412 bind . <Control-KP_Add> {incrfont 1}
413 bind . <Control-minus> {incrfont -1}
414 bind . <Control-KP_Subtract> {incrfont -1}
415 bind $cflist <<ListboxSelect>> listboxsel
416 bind . <Destroy> {savestuff %W}
417 bind . <Button-1> "click %W"
418 bind $fstring <Key-Return> dofind
419 bind $sha1entry <Key-Return> gotocommit
420 bind $sha1entry <<PasteSelection>> clearsha1
422 set maincursor [. cget -cursor]
423 set textcursor [$ctext cget -cursor]
425 set rowctxmenu .rowctxmenu
426 menu $rowctxmenu -tearoff 0
427 $rowctxmenu add command -label "Diff this -> selected" \
428 -command {diffvssel 0}
429 $rowctxmenu add command -label "Diff selected -> this" \
430 -command {diffvssel 1}
431 $rowctxmenu add command -label "Make patch" -command mkpatch
432 $rowctxmenu add command -label "Create tag" -command mktag
433 $rowctxmenu add command -label "Write commit to file" -command writecommit
436 # when we make a key binding for the toplevel, make sure
437 # it doesn't get triggered when that key is pressed in the
438 # find string entry widget.
439 proc bindkey {ev script} {
442 set escript [bind Entry $ev]
443 if {$escript == {}} {
444 set escript [bind Entry <Key>]
447 bind $e $ev "$escript; break"
451 # set the focus back to the toplevel for any click outside
462 global canv canv2 canv3 ctext cflist mainfont textfont
464 if {$stuffsaved} return
465 if {![winfo viewable .]} return
467 set f [open "~/.gitk-new" w]
468 puts $f "set mainfont {$mainfont}"
469 puts $f "set textfont {$textfont}"
470 puts $f "set geometry(width) [winfo width .ctop]"
471 puts $f "set geometry(height) [winfo height .ctop]"
472 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
473 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
474 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
475 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
476 set wid [expr {([winfo width $ctext] - 8) \
477 / [font measure $textfont "0"]}]
478 puts $f "set geometry(ctextw) $wid"
479 set wid [expr {([winfo width $cflist] - 11) \
480 / [font measure [$cflist cget -font] "0"]}]
481 puts $f "set geometry(cflistw) $wid"
483 file rename -force "~/.gitk-new" "~/.gitk"
488 proc resizeclistpanes {win w} {
490 if [info exists oldwidth($win)] {
491 set s0 [$win sash coord 0]
492 set s1 [$win sash coord 1]
494 set sash0 [expr {int($w/2 - 2)}]
495 set sash1 [expr {int($w*5/6 - 2)}]
497 set factor [expr {1.0 * $w / $oldwidth($win)}]
498 set sash0 [expr {int($factor * [lindex $s0 0])}]
499 set sash1 [expr {int($factor * [lindex $s1 0])}]
503 if {$sash1 < $sash0 + 20} {
504 set sash1 [expr $sash0 + 20]
506 if {$sash1 > $w - 10} {
507 set sash1 [expr $w - 10]
508 if {$sash0 > $sash1 - 20} {
509 set sash0 [expr $sash1 - 20]
513 $win sash place 0 $sash0 [lindex $s0 1]
514 $win sash place 1 $sash1 [lindex $s1 1]
516 set oldwidth($win) $w
519 proc resizecdetpanes {win w} {
521 if [info exists oldwidth($win)] {
522 set s0 [$win sash coord 0]
524 set sash0 [expr {int($w*3/4 - 2)}]
526 set factor [expr {1.0 * $w / $oldwidth($win)}]
527 set sash0 [expr {int($factor * [lindex $s0 0])}]
531 if {$sash0 > $w - 15} {
532 set sash0 [expr $w - 15]
535 $win sash place 0 $sash0 [lindex $s0 1]
537 set oldwidth($win) $w
541 global canv canv2 canv3
547 proc bindall {event action} {
548 global canv canv2 canv3
549 bind $canv $event $action
550 bind $canv2 $event $action
551 bind $canv3 $event $action
556 if {[winfo exists $w]} {
561 wm title $w "About gitk"
565 Copyright © 2005 Paul Mackerras
567 Use and redistribute under the terms of the GNU General Public License} \
568 -justify center -aspect 400
569 pack $w.m -side top -fill x -padx 20 -pady 20
570 button $w.ok -text Close -command "destroy $w"
571 pack $w.ok -side bottom
574 proc assigncolor {id} {
575 global commitinfo colormap commcolors colors nextcolor
576 global parents nparents children nchildren
577 global cornercrossings crossings
579 if [info exists colormap($id)] return
580 set ncolors [llength $colors]
581 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
582 set child [lindex $children($id) 0]
583 if {[info exists colormap($child)]
584 && $nparents($child) == 1} {
585 set colormap($id) $colormap($child)
590 if {[info exists cornercrossings($id)]} {
591 foreach x $cornercrossings($id) {
592 if {[info exists colormap($x)]
593 && [lsearch -exact $badcolors $colormap($x)] < 0} {
594 lappend badcolors $colormap($x)
597 if {[llength $badcolors] >= $ncolors} {
601 set origbad $badcolors
602 if {[llength $badcolors] < $ncolors - 1} {
603 if {[info exists crossings($id)]} {
604 foreach x $crossings($id) {
605 if {[info exists colormap($x)]
606 && [lsearch -exact $badcolors $colormap($x)] < 0} {
607 lappend badcolors $colormap($x)
610 if {[llength $badcolors] >= $ncolors} {
611 set badcolors $origbad
614 set origbad $badcolors
616 if {[llength $badcolors] < $ncolors - 1} {
617 foreach child $children($id) {
618 if {[info exists colormap($child)]
619 && [lsearch -exact $badcolors $colormap($child)] < 0} {
620 lappend badcolors $colormap($child)
622 if {[info exists parents($child)]} {
623 foreach p $parents($child) {
624 if {[info exists colormap($p)]
625 && [lsearch -exact $badcolors $colormap($p)] < 0} {
626 lappend badcolors $colormap($p)
631 if {[llength $badcolors] >= $ncolors} {
632 set badcolors $origbad
635 for {set i 0} {$i <= $ncolors} {incr i} {
636 set c [lindex $colors $nextcolor]
637 if {[incr nextcolor] >= $ncolors} {
640 if {[lsearch -exact $badcolors $c]} break
646 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
647 global mainline sidelines
648 global nchildren ncleft
655 set lthickness [expr {int($linespc / 9) + 1}]
656 catch {unset mainline}
657 catch {unset sidelines}
658 foreach id [array names nchildren] {
659 set ncleft($id) $nchildren($id)
663 proc bindline {t id} {
666 $canv bind $t <Enter> "lineenter %x %y $id"
667 $canv bind $t <Motion> "linemotion %x %y $id"
668 $canv bind $t <Leave> "lineleave $id"
669 $canv bind $t <Button-1> "lineclick %x %y $id"
672 proc drawcommitline {level} {
673 global parents children nparents nchildren todo
674 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
675 global lineid linehtag linentag linedtag commitinfo
676 global colormap numcommits currentparents dupparents
677 global oldlevel oldnlines oldtodo
678 global idtags idline idheads
679 global lineno lthickness mainline sidelines
680 global commitlisted rowtextx idpos
684 set id [lindex $todo $level]
685 set lineid($lineno) $id
686 set idline($id) $lineno
687 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
688 if {![info exists commitinfo($id)]} {
690 if {![info exists commitinfo($id)]} {
691 set commitinfo($id) {"No commit information available"}
696 set currentparents {}
698 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
699 foreach p $parents($id) {
700 if {[lsearch -exact $currentparents $p] < 0} {
701 lappend currentparents $p
703 # remember that this parent was listed twice
704 lappend dupparents $p
708 set x [expr $canvx0 + $level * $linespc]
710 set canvy [expr $canvy + $linespc]
711 allcanvs conf -scrollregion \
712 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
713 if {[info exists mainline($id)]} {
714 lappend mainline($id) $x $y1
715 set t [$canv create line $mainline($id) \
716 -width $lthickness -fill $colormap($id)]
720 if {[info exists sidelines($id)]} {
721 foreach ls $sidelines($id) {
722 set coords [lindex $ls 0]
723 set thick [lindex $ls 1]
724 set t [$canv create line $coords -fill $colormap($id) \
725 -width [expr {$thick * $lthickness}]]
730 set orad [expr {$linespc / 3}]
731 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
732 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
733 -fill $ofill -outline black -width 1]
735 $canv bind $t <1> {selcanvline {} %x %y}
736 set xt [expr $canvx0 + [llength $todo] * $linespc]
737 if {[llength $currentparents] > 2} {
738 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
740 set rowtextx($lineno) $xt
741 set idpos($id) [list $x $xt $y1]
742 if {[info exists idtags($id)] || [info exists idheads($id)]} {
743 set xt [drawtags $id $x $xt $y1]
745 set headline [lindex $commitinfo($id) 0]
746 set name [lindex $commitinfo($id) 1]
747 set date [lindex $commitinfo($id) 2]
748 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
749 -text $headline -font $mainfont ]
750 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
751 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
752 -text $name -font $namefont]
753 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
754 -text $date -font $mainfont]
757 proc drawtags {id x xt y1} {
758 global idtags idheads
759 global linespc lthickness
764 if {[info exists idtags($id)]} {
765 set marks $idtags($id)
766 set ntags [llength $marks]
768 if {[info exists idheads($id)]} {
769 set marks [concat $marks $idheads($id)]
775 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
776 set yt [expr $y1 - 0.5 * $linespc]
777 set yb [expr $yt + $linespc - 1]
781 set wid [font measure $mainfont $tag]
784 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
786 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
787 -width $lthickness -fill black -tags tag.$id]
789 foreach tag $marks x $xvals wid $wvals {
790 set xl [expr $x + $delta]
791 set xr [expr $x + $delta + $wid + $lthickness]
792 if {[incr ntags -1] >= 0} {
794 $canv create polygon $x [expr $yt + $delta] $xl $yt\
795 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
796 -width 1 -outline black -fill yellow -tags tag.$id
799 set xl [expr $xl - $delta/2]
800 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
801 -width 1 -outline black -fill green -tags tag.$id
803 $canv create text $xl $y1 -anchor w -text $tag \
804 -font $mainfont -tags tag.$id
809 proc updatetodo {level noshortcut} {
810 global currentparents ncleft todo
811 global mainline oldlevel oldtodo oldnlines
812 global canvx0 canvy linespc mainline
817 set oldnlines [llength $todo]
818 if {!$noshortcut && [llength $currentparents] == 1} {
819 set p [lindex $currentparents 0]
820 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
822 set x [expr $canvx0 + $level * $linespc]
823 set y [expr $canvy - $linespc]
824 set mainline($p) [list $x $y]
825 set todo [lreplace $todo $level $level $p]
830 set todo [lreplace $todo $level $level]
832 foreach p $currentparents {
834 set k [lsearch -exact $todo $p]
836 set todo [linsert $todo $i $p]
843 proc notecrossings {id lo hi corner} {
844 global oldtodo crossings cornercrossings
846 for {set i $lo} {[incr i] < $hi} {} {
847 set p [lindex $oldtodo $i]
848 if {$p == {}} continue
850 if {![info exists cornercrossings($id)]
851 || [lsearch -exact $cornercrossings($id) $p] < 0} {
852 lappend cornercrossings($id) $p
854 if {![info exists cornercrossings($p)]
855 || [lsearch -exact $cornercrossings($p) $id] < 0} {
856 lappend cornercrossings($p) $id
859 if {![info exists crossings($id)]
860 || [lsearch -exact $crossings($id) $p] < 0} {
861 lappend crossings($id) $p
863 if {![info exists crossings($p)]
864 || [lsearch -exact $crossings($p) $id] < 0} {
865 lappend crossings($p) $id
872 global canv mainline sidelines canvx0 canvy linespc
873 global oldlevel oldtodo todo currentparents dupparents
874 global lthickness linespc canvy colormap
876 set y1 [expr $canvy - $linespc]
879 foreach id $oldtodo {
881 if {$id == {}} continue
882 set xi [expr {$canvx0 + $i * $linespc}]
883 if {$i == $oldlevel} {
884 foreach p $currentparents {
885 set j [lsearch -exact $todo $p]
886 set coords [list $xi $y1]
887 set xj [expr {$canvx0 + $j * $linespc}]
889 lappend coords [expr $xj + $linespc] $y1
890 notecrossings $p $j $i [expr {$j + 1}]
891 } elseif {$j > $i + 1} {
892 lappend coords [expr $xj - $linespc] $y1
893 notecrossings $p $i $j [expr {$j - 1}]
895 if {[lsearch -exact $dupparents $p] >= 0} {
896 # draw a double-width line to indicate the doubled parent
897 lappend coords $xj $y2
898 lappend sidelines($p) [list $coords 2]
899 if {![info exists mainline($p)]} {
900 set mainline($p) [list $xj $y2]
903 # normal case, no parent duplicated
904 if {![info exists mainline($p)]} {
906 lappend coords $xj $y2
908 set mainline($p) $coords
910 lappend coords $xj $y2
911 lappend sidelines($p) [list $coords 1]
915 } elseif {[lindex $todo $i] != $id} {
916 set j [lsearch -exact $todo $id]
917 set xj [expr {$canvx0 + $j * $linespc}]
918 lappend mainline($id) $xi $y1 $xj $y2
923 proc decidenext {{noread 0}} {
924 global parents children nchildren ncleft todo
925 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
926 global datemode cdate
928 global currentparents oldlevel oldnlines oldtodo
929 global lineno lthickness
931 # remove the null entry if present
932 set nullentry [lsearch -exact $todo {}]
933 if {$nullentry >= 0} {
934 set todo [lreplace $todo $nullentry $nullentry]
937 # choose which one to do next time around
938 set todol [llength $todo]
941 for {set k $todol} {[incr k -1] >= 0} {} {
942 set p [lindex $todo $k]
943 if {$ncleft($p) == 0} {
945 if {![info exists commitinfo($p)]} {
951 if {$latest == {} || $cdate($p) > $latest} {
953 set latest $cdate($p)
963 puts "ERROR: none of the pending commits can be done yet:"
965 puts " $p ($ncleft($p))"
971 # If we are reducing, put in a null entry
972 if {$todol < $oldnlines} {
973 if {$nullentry >= 0} {
976 && [lindex $oldtodo $i] == [lindex $todo $i]} {
986 set todo [linsert $todo $i {}]
995 proc drawcommit {id} {
996 global phase todo nchildren datemode nextupdate
999 if {$phase != "incrdraw"} {
1002 set startcommits $id
1005 updatetodo 0 $datemode
1007 if {$nchildren($id) == 0} {
1009 lappend startcommits $id
1011 set level [decidenext 1]
1012 if {$level == {} || $id != [lindex $todo $level]} {
1017 drawcommitline $level
1018 if {[updatetodo $level $datemode]} {
1019 set level [decidenext 1]
1020 if {$level == {}} break
1022 set id [lindex $todo $level]
1023 if {![info exists commitlisted($id)]} {
1026 if {[clock clicks -milliseconds] >= $nextupdate} {
1034 proc finishcommits {} {
1037 global canv mainfont ctext maincursor textcursor
1039 if {$phase != "incrdraw"} {
1041 $canv create text 3 3 -anchor nw -text "No commits selected" \
1042 -font $mainfont -tags textitems
1046 set level [decidenext]
1047 drawrest $level [llength $startcommits]
1049 . config -cursor $maincursor
1050 $ctext config -cursor $textcursor
1054 global nextupdate startmsecs startcommits todo
1056 if {$startcommits == {}} return
1057 set startmsecs [clock clicks -milliseconds]
1058 set nextupdate [expr $startmsecs + 100]
1060 set todo [lindex $startcommits 0]
1064 proc drawrest {level startix} {
1065 global phase stopped redisplaying selectedline
1066 global datemode currentparents todo
1068 global nextupdate startmsecs startcommits idline
1072 set startid [lindex $startcommits $startix]
1074 if {$startid != {}} {
1075 set startline $idline($startid)
1079 drawcommitline $level
1080 set hard [updatetodo $level $datemode]
1081 if {$numcommits == $startline} {
1082 lappend todo $startid
1085 set startid [lindex $startcommits $startix]
1087 if {$startid != {}} {
1088 set startline $idline($startid)
1092 set level [decidenext]
1093 if {$level < 0} break
1096 if {[clock clicks -milliseconds] >= $nextupdate} {
1103 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1104 #puts "overall $drawmsecs ms for $numcommits commits"
1105 if {$redisplaying} {
1106 if {$stopped == 0 && [info exists selectedline]} {
1107 selectline $selectedline
1109 if {$stopped == 1} {
1111 after idle drawgraph
1118 proc findmatches {f} {
1119 global findtype foundstring foundstrlen
1120 if {$findtype == "Regexp"} {
1121 set matches [regexp -indices -all -inline $foundstring $f]
1123 if {$findtype == "IgnCase"} {
1124 set str [string tolower $f]
1130 while {[set j [string first $foundstring $str $i]] >= 0} {
1131 lappend matches [list $j [expr $j+$foundstrlen-1]]
1132 set i [expr $j + $foundstrlen]
1139 global findtype findloc findstring markedmatches commitinfo
1140 global numcommits lineid linehtag linentag linedtag
1141 global mainfont namefont canv canv2 canv3 selectedline
1142 global matchinglines foundstring foundstrlen
1147 set matchinglines {}
1148 if {$findloc == "Pickaxe"} {
1152 if {$findtype == "IgnCase"} {
1153 set foundstring [string tolower $findstring]
1155 set foundstring $findstring
1157 set foundstrlen [string length $findstring]
1158 if {$foundstrlen == 0} return
1159 if {$findloc == "Files"} {
1163 if {![info exists selectedline]} {
1166 set oldsel $selectedline
1169 set fldtypes {Headline Author Date Committer CDate Comment}
1170 for {set l 0} {$l < $numcommits} {incr l} {
1172 set info $commitinfo($id)
1174 foreach f $info ty $fldtypes {
1175 if {$findloc != "All fields" && $findloc != $ty} {
1178 set matches [findmatches $f]
1179 if {$matches == {}} continue
1181 if {$ty == "Headline"} {
1182 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1183 } elseif {$ty == "Author"} {
1184 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1185 } elseif {$ty == "Date"} {
1186 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1190 lappend matchinglines $l
1191 if {!$didsel && $l > $oldsel} {
1197 if {$matchinglines == {}} {
1199 } elseif {!$didsel} {
1200 findselectline [lindex $matchinglines 0]
1204 proc findselectline {l} {
1205 global findloc commentend ctext
1207 if {$findloc == "All fields" || $findloc == "Comments"} {
1208 # highlight the matches in the comments
1209 set f [$ctext get 1.0 $commentend]
1210 set matches [findmatches $f]
1211 foreach match $matches {
1212 set start [lindex $match 0]
1213 set end [expr [lindex $match 1] + 1]
1214 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1219 proc findnext {restart} {
1220 global matchinglines selectedline
1221 if {![info exists matchinglines]} {
1227 if {![info exists selectedline]} return
1228 foreach l $matchinglines {
1229 if {$l > $selectedline} {
1238 global matchinglines selectedline
1239 if {![info exists matchinglines]} {
1243 if {![info exists selectedline]} return
1245 foreach l $matchinglines {
1246 if {$l >= $selectedline} break
1250 findselectline $prev
1256 proc findlocchange {name ix op} {
1257 global findloc findtype findtypemenu
1258 if {$findloc == "Pickaxe"} {
1264 $findtypemenu entryconf 1 -state $state
1265 $findtypemenu entryconf 2 -state $state
1268 proc stopfindproc {{done 0}} {
1269 global findprocpid findprocfile findids
1270 global ctext findoldcursor phase maincursor textcursor
1271 global findinprogress
1273 catch {unset findids}
1274 if {[info exists findprocpid]} {
1276 catch {exec kill $findprocpid}
1278 catch {close $findprocfile}
1281 if {[info exists findinprogress]} {
1282 unset findinprogress
1283 if {$phase != "incrdraw"} {
1284 . config -cursor $maincursor
1285 $ctext config -cursor $textcursor
1290 proc findpatches {} {
1291 global findstring selectedline numcommits
1292 global findprocpid findprocfile
1293 global finddidsel ctext lineid findinprogress
1294 global findinsertpos
1296 if {$numcommits == 0} return
1298 # make a list of all the ids to search, starting at the one
1299 # after the selected line (if any)
1300 if {[info exists selectedline]} {
1306 for {set i 0} {$i < $numcommits} {incr i} {
1307 if {[incr l] >= $numcommits} {
1310 append inputids $lineid($l) "\n"
1314 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1317 error_popup "Error starting search process: $err"
1321 set findinsertpos end
1323 set findprocpid [pid $f]
1324 fconfigure $f -blocking 0
1325 fileevent $f readable readfindproc
1327 . config -cursor watch
1328 $ctext config -cursor watch
1329 set findinprogress 1
1332 proc readfindproc {} {
1333 global findprocfile finddidsel
1334 global idline matchinglines findinsertpos
1336 set n [gets $findprocfile line]
1338 if {[eof $findprocfile]} {
1346 if {![regexp {^[0-9a-f]{40}} $line id]} {
1347 error_popup "Can't parse git-diff-tree output: $line"
1351 if {![info exists idline($id)]} {
1352 puts stderr "spurious id: $id"
1359 proc insertmatch {l id} {
1360 global matchinglines findinsertpos finddidsel
1362 if {$findinsertpos == "end"} {
1363 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1364 set matchinglines [linsert $matchinglines 0 $l]
1367 lappend matchinglines $l
1370 set matchinglines [linsert $matchinglines $findinsertpos $l]
1381 global selectedline numcommits lineid ctext
1382 global ffileline finddidsel parents nparents
1383 global findinprogress findstartline findinsertpos
1384 global treediffs fdiffids fdiffsneeded fdiffpos
1385 global findmergefiles
1387 if {$numcommits == 0} return
1389 if {[info exists selectedline]} {
1390 set l [expr {$selectedline + 1}]
1395 set findstartline $l
1400 if {$findmergefiles || $nparents($id) == 1} {
1401 foreach p $parents($id) {
1402 if {![info exists treediffs([list $id $p])]} {
1403 append diffsneeded "$id $p\n"
1404 lappend fdiffsneeded [list $id $p]
1408 if {[incr l] >= $numcommits} {
1411 if {$l == $findstartline} break
1414 # start off a git-diff-tree process if needed
1415 if {$diffsneeded ne {}} {
1417 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1419 error_popup "Error starting search process: $err"
1422 catch {unset fdiffids}
1424 fconfigure $df -blocking 0
1425 fileevent $df readable [list readfilediffs $df]
1429 set findinsertpos end
1431 set p [lindex $parents($id) 0]
1432 . config -cursor watch
1433 $ctext config -cursor watch
1434 set findinprogress 1
1435 findcont [list $id $p]
1439 proc readfilediffs {df} {
1440 global findids fdiffids fdiffs
1442 set n [gets $df line]
1446 if {[catch {close $df} err]} {
1449 error_popup "Error in git-diff-tree: $err"
1450 } elseif {[info exists findids]} {
1454 error_popup "Couldn't find diffs for {$ids}"
1459 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1460 # start of a new string of diffs
1462 set fdiffids [list $id $p]
1464 } elseif {[string match ":*" $line]} {
1465 lappend fdiffs [lindex $line 5]
1469 proc donefilediff {} {
1470 global fdiffids fdiffs treediffs findids
1471 global fdiffsneeded fdiffpos
1473 if {[info exists fdiffids]} {
1474 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1475 && $fdiffpos < [llength $fdiffsneeded]} {
1476 # git-diff-tree doesn't output anything for a commit
1477 # which doesn't change anything
1478 set nullids [lindex $fdiffsneeded $fdiffpos]
1479 set treediffs($nullids) {}
1480 if {[info exists findids] && $nullids eq $findids} {
1488 if {![info exists treediffs($fdiffids)]} {
1489 set treediffs($fdiffids) $fdiffs
1491 if {[info exists findids] && $fdiffids eq $findids} {
1498 proc findcont {ids} {
1499 global findids treediffs parents nparents treepending
1500 global ffileline findstartline finddidsel
1501 global lineid numcommits matchinglines findinprogress
1502 global findmergefiles
1504 set id [lindex $ids 0]
1505 set p [lindex $ids 1]
1506 set pi [lsearch -exact $parents($id) $p]
1509 if {$findmergefiles || $nparents($id) == 1} {
1510 if {![info exists treediffs($ids)]} {
1516 foreach f $treediffs($ids) {
1517 set x [findmatches $f]
1525 set pi $nparents($id)
1528 set pi $nparents($id)
1530 if {[incr pi] >= $nparents($id)} {
1532 if {[incr l] >= $numcommits} {
1535 if {$l == $findstartline} break
1538 set p [lindex $parents($id) $pi]
1539 set ids [list $id $p]
1547 # mark a commit as matching by putting a yellow background
1548 # behind the headline
1549 proc markheadline {l id} {
1550 global canv mainfont linehtag commitinfo
1552 set bbox [$canv bbox $linehtag($l)]
1553 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1557 # mark the bits of a headline, author or date that match a find string
1558 proc markmatches {canv l str tag matches font} {
1559 set bbox [$canv bbox $tag]
1560 set x0 [lindex $bbox 0]
1561 set y0 [lindex $bbox 1]
1562 set y1 [lindex $bbox 3]
1563 foreach match $matches {
1564 set start [lindex $match 0]
1565 set end [lindex $match 1]
1566 if {$start > $end} continue
1567 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1568 set xlen [font measure $font [string range $str 0 [expr $end]]]
1569 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1570 -outline {} -tags matches -fill yellow]
1575 proc unmarkmatches {} {
1576 global matchinglines findids
1577 allcanvs delete matches
1578 catch {unset matchinglines}
1579 catch {unset findids}
1582 proc selcanvline {w x y} {
1583 global canv canvy0 ctext linespc selectedline
1584 global lineid linehtag linentag linedtag rowtextx
1585 set ymax [lindex [$canv cget -scrollregion] 3]
1586 if {$ymax == {}} return
1587 set yfrac [lindex [$canv yview] 0]
1588 set y [expr {$y + $yfrac * $ymax}]
1589 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1594 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1600 proc selectline {l} {
1601 global canv canv2 canv3 ctext commitinfo selectedline
1602 global lineid linehtag linentag linedtag
1603 global canvy0 linespc parents nparents
1604 global cflist currentid sha1entry
1605 global commentend idtags
1607 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1609 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1610 -tags secsel -fill [$canv cget -selectbackground]]
1612 $canv2 delete secsel
1613 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1614 -tags secsel -fill [$canv2 cget -selectbackground]]
1616 $canv3 delete secsel
1617 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1618 -tags secsel -fill [$canv3 cget -selectbackground]]
1620 set y [expr {$canvy0 + $l * $linespc}]
1621 set ymax [lindex [$canv cget -scrollregion] 3]
1622 set ytop [expr {$y - $linespc - 1}]
1623 set ybot [expr {$y + $linespc + 1}]
1624 set wnow [$canv yview]
1625 set wtop [expr [lindex $wnow 0] * $ymax]
1626 set wbot [expr [lindex $wnow 1] * $ymax]
1627 set wh [expr {$wbot - $wtop}]
1629 if {$ytop < $wtop} {
1630 if {$ybot < $wtop} {
1631 set newtop [expr {$y - $wh / 2.0}]
1634 if {$newtop > $wtop - $linespc} {
1635 set newtop [expr {$wtop - $linespc}]
1638 } elseif {$ybot > $wbot} {
1639 if {$ytop > $wbot} {
1640 set newtop [expr {$y - $wh / 2.0}]
1642 set newtop [expr {$ybot - $wh}]
1643 if {$newtop < $wtop + $linespc} {
1644 set newtop [expr {$wtop + $linespc}]
1648 if {$newtop != $wtop} {
1652 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1658 $sha1entry delete 0 end
1659 $sha1entry insert 0 $id
1660 $sha1entry selection from 0
1661 $sha1entry selection to end
1663 $ctext conf -state normal
1664 $ctext delete 0.0 end
1665 $ctext mark set fmark.0 0.0
1666 $ctext mark gravity fmark.0 left
1667 set info $commitinfo($id)
1668 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1669 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1670 if {[info exists idtags($id)]} {
1671 $ctext insert end "Tags:"
1672 foreach tag $idtags($id) {
1673 $ctext insert end " $tag"
1675 $ctext insert end "\n"
1677 $ctext insert end "\n"
1678 $ctext insert end [lindex $info 5]
1679 $ctext insert end "\n"
1680 $ctext tag delete Comments
1681 $ctext tag remove found 1.0 end
1682 $ctext conf -state disabled
1683 set commentend [$ctext index "end - 1c"]
1685 $cflist delete 0 end
1686 $cflist insert end "Comments"
1687 startdiff $id $parents($id)
1690 proc startdiff {id vs} {
1691 global diffpending diffpindex
1692 global diffindex difffilestart
1693 global curdifftag curtagstart
1698 catch {unset difffilestart}
1699 set curdifftag Comments
1701 contdiff [list $id [lindex $vs 0]]
1704 proc contdiff {ids} {
1705 global treediffs diffids treepending
1708 if {![info exists treediffs($ids)]} {
1709 if {![info exists treepending]} {
1717 proc selnextline {dir} {
1719 if {![info exists selectedline]} return
1720 set l [expr $selectedline + $dir]
1725 proc addtocflist {ids} {
1726 global treediffs cflist diffpindex
1728 set colors {black blue green red cyan magenta}
1729 set color [lindex $colors [expr {$diffpindex % [llength $colors]}]]
1730 foreach f $treediffs($ids) {
1731 $cflist insert end $f
1732 $cflist itemconf end -foreground $color
1737 proc gettreediffs {ids} {
1738 global treediffs parents treepending
1739 set treepending $ids
1740 set treediffs($ids) {}
1741 set id [lindex $ids 0]
1742 set p [lindex $ids 1]
1743 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1744 fconfigure $gdtf -blocking 0
1745 fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1748 proc gettreediffline {gdtf ids} {
1749 global treediffs treepending diffids
1750 set n [gets $gdtf line]
1752 if {![eof $gdtf]} return
1755 if {[info exists diffids]} {
1756 if {$ids != $diffids} {
1757 gettreediffs $diffids
1764 set file [lindex $line 5]
1765 lappend treediffs($ids) $file
1768 proc getblobdiffs {ids} {
1769 global diffopts blobdifffd diffids env
1770 global nextupdate diffinhdr
1772 set id [lindex $ids 0]
1773 set p [lindex $ids 1]
1774 set env(GIT_DIFF_OPTS) $diffopts
1775 if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1776 puts "error getting diffs: $err"
1780 fconfigure $bdf -blocking 0
1781 set blobdifffd($ids) $bdf
1782 fileevent $bdf readable [list getblobdiffline $bdf $ids]
1783 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1786 proc getblobdiffline {bdf ids} {
1787 global diffids blobdifffd ctext curdifftag curtagstart
1788 global diffnexthead diffnextnote diffindex difffilestart
1789 global nextupdate diffpending diffpindex diffinhdr
1791 set n [gets $bdf line]
1795 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1796 $ctext tag add $curdifftag $curtagstart end
1797 if {[incr diffpindex] < [llength $diffpending]} {
1798 set id [lindex $ids 0]
1799 set p [lindex $diffpending $diffpindex]
1800 contdiff [list $id $p]
1806 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1809 $ctext conf -state normal
1810 if {[regexp {^diff --git a/(.*) b/} $line match fname]} {
1811 # start of a new file
1812 $ctext insert end "\n"
1813 $ctext tag add $curdifftag $curtagstart end
1814 set curtagstart [$ctext index "end - 1c"]
1816 set here [$ctext index "end - 1c"]
1817 set difffilestart($diffindex) $here
1819 # start mark names at fmark.1 for first file
1820 $ctext mark set fmark.$diffindex $here
1821 $ctext mark gravity fmark.$diffindex left
1822 set curdifftag "f:$fname"
1823 $ctext tag delete $curdifftag
1824 set l [expr {(78 - [string length $header]) / 2}]
1825 set pad [string range "----------------------------------------" 1 $l]
1826 $ctext insert end "$pad $header $pad\n" filesep
1828 } elseif {[regexp {^(---|\+\+\+)} $line]} {
1830 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1831 $line match f1l f1c f2l f2c rest]} {
1832 $ctext insert end "\t" hunksep
1833 $ctext insert end " $f1l " d0 " $f2l " d1
1834 $ctext insert end " $rest \n" hunksep
1837 set x [string range $line 0 0]
1838 if {$x == "-" || $x == "+"} {
1839 set tag [expr {$x == "+"}]
1840 set line [string range $line 1 end]
1841 $ctext insert end "$line\n" d$tag
1842 } elseif {$x == " "} {
1843 set line [string range $line 1 end]
1844 $ctext insert end "$line\n"
1845 } elseif {$diffinhdr || $x == "\\"} {
1846 # e.g. "\ No newline at end of file"
1847 $ctext insert end "$line\n" filesep
1849 # Something else we don't recognize
1850 if {$curdifftag != "Comments"} {
1851 $ctext insert end "\n"
1852 $ctext tag add $curdifftag $curtagstart end
1853 set curtagstart [$ctext index "end - 1c"]
1854 set curdifftag Comments
1856 $ctext insert end "$line\n" filesep
1859 $ctext conf -state disabled
1860 if {[clock clicks -milliseconds] >= $nextupdate} {
1862 fileevent $bdf readable {}
1864 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1869 global difffilestart ctext
1870 set here [$ctext index @0,0]
1871 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1872 if {[$ctext compare $difffilestart($i) > $here]} {
1873 $ctext yview $difffilestart($i)
1879 proc listboxsel {} {
1880 global ctext cflist currentid treediffs
1881 if {![info exists currentid]} return
1882 set sel [lsort [$cflist curselection]]
1883 if {$sel eq {}} return
1884 set first [lindex $sel 0]
1885 catch {$ctext yview fmark.$first}
1889 global linespc charspc canvx0 canvy0 mainfont
1890 set linespc [font metrics $mainfont -linespace]
1891 set charspc [font measure $mainfont "m"]
1892 set canvy0 [expr 3 + 0.5 * $linespc]
1893 set canvx0 [expr 3 + 0.5 * $linespc]
1897 global selectedline stopped redisplaying phase
1898 if {$stopped > 1} return
1899 if {$phase == "getcommits"} return
1901 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1908 proc incrfont {inc} {
1909 global mainfont namefont textfont selectedline ctext canv phase
1910 global stopped entries
1912 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1913 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1914 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1916 $ctext conf -font $textfont
1917 $ctext tag conf filesep -font [concat $textfont bold]
1918 foreach e $entries {
1919 $e conf -font $mainfont
1921 if {$phase == "getcommits"} {
1922 $canv itemconf textitems -font $mainfont
1928 global sha1entry sha1string
1929 if {[string length $sha1string] == 40} {
1930 $sha1entry delete 0 end
1934 proc sha1change {n1 n2 op} {
1935 global sha1string currentid sha1but
1936 if {$sha1string == {}
1937 || ([info exists currentid] && $sha1string == $currentid)} {
1942 if {[$sha1but cget -state] == $state} return
1943 if {$state == "normal"} {
1944 $sha1but conf -state normal -relief raised -text "Goto: "
1946 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1950 proc gotocommit {} {
1951 global sha1string currentid idline tagids
1952 global lineid numcommits
1954 if {$sha1string == {}
1955 || ([info exists currentid] && $sha1string == $currentid)} return
1956 if {[info exists tagids($sha1string)]} {
1957 set id $tagids($sha1string)
1959 set id [string tolower $sha1string]
1960 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
1962 for {set l 0} {$l < $numcommits} {incr l} {
1963 if {[string match $id* $lineid($l)]} {
1964 lappend matches $lineid($l)
1967 if {$matches ne {}} {
1968 if {[llength $matches] > 1} {
1969 error_popup "Short SHA1 id $id is ambiguous"
1972 set id [lindex $matches 0]
1976 if {[info exists idline($id)]} {
1977 selectline $idline($id)
1980 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
1985 error_popup "$type $sha1string is not known"
1988 proc lineenter {x y id} {
1989 global hoverx hovery hoverid hovertimer
1990 global commitinfo canv
1992 if {![info exists commitinfo($id)]} return
1996 if {[info exists hovertimer]} {
1997 after cancel $hovertimer
1999 set hovertimer [after 500 linehover]
2003 proc linemotion {x y id} {
2004 global hoverx hovery hoverid hovertimer
2006 if {[info exists hoverid] && $id == $hoverid} {
2009 if {[info exists hovertimer]} {
2010 after cancel $hovertimer
2012 set hovertimer [after 500 linehover]
2016 proc lineleave {id} {
2017 global hoverid hovertimer canv
2019 if {[info exists hoverid] && $id == $hoverid} {
2021 if {[info exists hovertimer]} {
2022 after cancel $hovertimer
2030 global hoverx hovery hoverid hovertimer
2031 global canv linespc lthickness
2032 global commitinfo mainfont
2034 set text [lindex $commitinfo($hoverid) 0]
2035 set ymax [lindex [$canv cget -scrollregion] 3]
2036 if {$ymax == {}} return
2037 set yfrac [lindex [$canv yview] 0]
2038 set x [expr {$hoverx + 2 * $linespc}]
2039 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2040 set x0 [expr {$x - 2 * $lthickness}]
2041 set y0 [expr {$y - 2 * $lthickness}]
2042 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2043 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2044 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2045 -fill \#ffff80 -outline black -width 1 -tags hover]
2047 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2051 proc lineclick {x y id} {
2052 global ctext commitinfo children cflist canv
2056 # fill the details pane with info about this line
2057 $ctext conf -state normal
2058 $ctext delete 0.0 end
2059 $ctext insert end "Parent:\n "
2060 catch {destroy $ctext.$id}
2061 button $ctext.$id -text "Go:" -command "selbyid $id" \
2063 $ctext window create end -window $ctext.$id -align center
2064 set info $commitinfo($id)
2065 $ctext insert end "\t[lindex $info 0]\n"
2066 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2067 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2068 $ctext insert end "\tID:\t$id\n"
2069 if {[info exists children($id)]} {
2070 $ctext insert end "\nChildren:"
2071 foreach child $children($id) {
2072 $ctext insert end "\n "
2073 catch {destroy $ctext.$child}
2074 button $ctext.$child -text "Go:" -command "selbyid $child" \
2076 $ctext window create end -window $ctext.$child -align center
2077 set info $commitinfo($child)
2078 $ctext insert end "\t[lindex $info 0]"
2081 $ctext conf -state disabled
2083 $cflist delete 0 end
2088 if {[info exists idline($id)]} {
2089 selectline $idline($id)
2095 if {![info exists startmstime]} {
2096 set startmstime [clock clicks -milliseconds]
2098 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2101 proc rowmenu {x y id} {
2102 global rowctxmenu idline selectedline rowmenuid
2104 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2109 $rowctxmenu entryconfigure 0 -state $state
2110 $rowctxmenu entryconfigure 1 -state $state
2111 $rowctxmenu entryconfigure 2 -state $state
2113 tk_popup $rowctxmenu $x $y
2116 proc diffvssel {dirn} {
2117 global rowmenuid selectedline lineid
2121 if {![info exists selectedline]} return
2123 set oldid $lineid($selectedline)
2124 set newid $rowmenuid
2126 set oldid $rowmenuid
2127 set newid $lineid($selectedline)
2129 $ctext conf -state normal
2130 $ctext delete 0.0 end
2131 $ctext mark set fmark.0 0.0
2132 $ctext mark gravity fmark.0 left
2133 $cflist delete 0 end
2134 $cflist insert end "Top"
2135 $ctext insert end "From $oldid\n "
2136 $ctext insert end [lindex $commitinfo($oldid) 0]
2137 $ctext insert end "\n\nTo $newid\n "
2138 $ctext insert end [lindex $commitinfo($newid) 0]
2139 $ctext insert end "\n"
2140 $ctext conf -state disabled
2141 $ctext tag delete Comments
2142 $ctext tag remove found 1.0 end
2143 startdiff [list $newid $oldid]
2147 global rowmenuid currentid commitinfo patchtop patchnum
2149 if {![info exists currentid]} return
2150 set oldid $currentid
2151 set oldhead [lindex $commitinfo($oldid) 0]
2152 set newid $rowmenuid
2153 set newhead [lindex $commitinfo($newid) 0]
2156 catch {destroy $top}
2158 label $top.title -text "Generate patch"
2159 grid $top.title - -pady 10
2160 label $top.from -text "From:"
2161 entry $top.fromsha1 -width 40 -relief flat
2162 $top.fromsha1 insert 0 $oldid
2163 $top.fromsha1 conf -state readonly
2164 grid $top.from $top.fromsha1 -sticky w
2165 entry $top.fromhead -width 60 -relief flat
2166 $top.fromhead insert 0 $oldhead
2167 $top.fromhead conf -state readonly
2168 grid x $top.fromhead -sticky w
2169 label $top.to -text "To:"
2170 entry $top.tosha1 -width 40 -relief flat
2171 $top.tosha1 insert 0 $newid
2172 $top.tosha1 conf -state readonly
2173 grid $top.to $top.tosha1 -sticky w
2174 entry $top.tohead -width 60 -relief flat
2175 $top.tohead insert 0 $newhead
2176 $top.tohead conf -state readonly
2177 grid x $top.tohead -sticky w
2178 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2179 grid $top.rev x -pady 10
2180 label $top.flab -text "Output file:"
2181 entry $top.fname -width 60
2182 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2184 grid $top.flab $top.fname -sticky w
2186 button $top.buts.gen -text "Generate" -command mkpatchgo
2187 button $top.buts.can -text "Cancel" -command mkpatchcan
2188 grid $top.buts.gen $top.buts.can
2189 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2190 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2191 grid $top.buts - -pady 10 -sticky ew
2195 proc mkpatchrev {} {
2198 set oldid [$patchtop.fromsha1 get]
2199 set oldhead [$patchtop.fromhead get]
2200 set newid [$patchtop.tosha1 get]
2201 set newhead [$patchtop.tohead get]
2202 foreach e [list fromsha1 fromhead tosha1 tohead] \
2203 v [list $newid $newhead $oldid $oldhead] {
2204 $patchtop.$e conf -state normal
2205 $patchtop.$e delete 0 end
2206 $patchtop.$e insert 0 $v
2207 $patchtop.$e conf -state readonly
2214 set oldid [$patchtop.fromsha1 get]
2215 set newid [$patchtop.tosha1 get]
2216 set fname [$patchtop.fname get]
2217 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2218 error_popup "Error creating patch: $err"
2220 catch {destroy $patchtop}
2224 proc mkpatchcan {} {
2227 catch {destroy $patchtop}
2232 global rowmenuid mktagtop commitinfo
2236 catch {destroy $top}
2238 label $top.title -text "Create tag"
2239 grid $top.title - -pady 10
2240 label $top.id -text "ID:"
2241 entry $top.sha1 -width 40 -relief flat
2242 $top.sha1 insert 0 $rowmenuid
2243 $top.sha1 conf -state readonly
2244 grid $top.id $top.sha1 -sticky w
2245 entry $top.head -width 60 -relief flat
2246 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2247 $top.head conf -state readonly
2248 grid x $top.head -sticky w
2249 label $top.tlab -text "Tag name:"
2250 entry $top.tag -width 60
2251 grid $top.tlab $top.tag -sticky w
2253 button $top.buts.gen -text "Create" -command mktaggo
2254 button $top.buts.can -text "Cancel" -command mktagcan
2255 grid $top.buts.gen $top.buts.can
2256 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2257 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2258 grid $top.buts - -pady 10 -sticky ew
2263 global mktagtop env tagids idtags
2264 global idpos idline linehtag canv selectedline
2266 set id [$mktagtop.sha1 get]
2267 set tag [$mktagtop.tag get]
2269 error_popup "No tag name specified"
2272 if {[info exists tagids($tag)]} {
2273 error_popup "Tag \"$tag\" already exists"
2278 if {[info exists env(GIT_DIR)]} {
2279 set dir $env(GIT_DIR)
2281 set fname [file join $dir "refs/tags" $tag]
2282 set f [open $fname w]
2286 error_popup "Error creating tag: $err"
2290 set tagids($tag) $id
2291 lappend idtags($id) $tag
2292 $canv delete tag.$id
2293 set xt [eval drawtags $id $idpos($id)]
2294 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2295 if {[info exists selectedline] && $selectedline == $idline($id)} {
2296 selectline $selectedline
2303 catch {destroy $mktagtop}
2312 proc writecommit {} {
2313 global rowmenuid wrcomtop commitinfo wrcomcmd
2315 set top .writecommit
2317 catch {destroy $top}
2319 label $top.title -text "Write commit to file"
2320 grid $top.title - -pady 10
2321 label $top.id -text "ID:"
2322 entry $top.sha1 -width 40 -relief flat
2323 $top.sha1 insert 0 $rowmenuid
2324 $top.sha1 conf -state readonly
2325 grid $top.id $top.sha1 -sticky w
2326 entry $top.head -width 60 -relief flat
2327 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2328 $top.head conf -state readonly
2329 grid x $top.head -sticky w
2330 label $top.clab -text "Command:"
2331 entry $top.cmd -width 60 -textvariable wrcomcmd
2332 grid $top.clab $top.cmd -sticky w -pady 10
2333 label $top.flab -text "Output file:"
2334 entry $top.fname -width 60
2335 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2336 grid $top.flab $top.fname -sticky w
2338 button $top.buts.gen -text "Write" -command wrcomgo
2339 button $top.buts.can -text "Cancel" -command wrcomcan
2340 grid $top.buts.gen $top.buts.can
2341 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2342 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2343 grid $top.buts - -pady 10 -sticky ew
2350 set id [$wrcomtop.sha1 get]
2351 set cmd "echo $id | [$wrcomtop.cmd get]"
2352 set fname [$wrcomtop.fname get]
2353 if {[catch {exec sh -c $cmd >$fname &} err]} {
2354 error_popup "Error writing commit: $err"
2356 catch {destroy $wrcomtop}
2363 catch {destroy $wrcomtop}
2376 set diffopts "-U 5 -p"
2377 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2379 set mainfont {Helvetica 9}
2380 set textfont {Courier 9}
2381 set findmergefiles 0
2383 set colors {green red blue magenta darkgrey brown orange}
2385 catch {source ~/.gitk}
2387 set namefont $mainfont
2389 lappend namefont bold
2394 switch -regexp -- $arg {
2396 "^-b" { set boldnames 1 }
2397 "^-d" { set datemode 1 }
2399 lappend revtreeargs $arg
2411 getcommits $revtreeargs