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 seenfile 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 if {$nparents($id) == 1} {
1688 startdiff [concat $id $parents($id)]
1690 catch {unset seenfile}
1693 proc startdiff {ids} {
1694 global treediffs diffids treepending
1696 if {![info exists treediffs($ids)]} {
1698 if {![info exists treepending]} {
1706 proc selnextline {dir} {
1708 if {![info exists selectedline]} return
1709 set l [expr $selectedline + $dir]
1714 proc addtocflist {ids} {
1715 global treediffs cflist
1716 foreach f $treediffs($ids) {
1717 $cflist insert end $f
1722 proc gettreediffs {ids} {
1723 global treediffs parents treepending
1724 set treepending $ids
1725 set treediffs($ids) {}
1726 set id [lindex $ids 0]
1727 set p [lindex $ids 1]
1728 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1729 fconfigure $gdtf -blocking 0
1730 fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1733 proc gettreediffline {gdtf ids} {
1734 global treediffs treepending diffids
1735 set n [gets $gdtf line]
1737 if {![eof $gdtf]} return
1740 if {[info exists diffids]} {
1741 if {$ids != $diffids} {
1742 gettreediffs $diffids
1750 set file [lindex $line 5]
1751 lappend treediffs($ids) $file
1754 proc getblobdiffs {ids} {
1755 global diffopts blobdifffd blobdiffids env curdifftag curtagstart
1756 global diffindex difffilestart nextupdate
1758 set id [lindex $ids 0]
1759 set p [lindex $ids 1]
1760 set env(GIT_DIFF_OPTS) $diffopts
1761 if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1762 puts "error getting diffs: $err"
1765 fconfigure $bdf -blocking 0
1766 set blobdiffids $ids
1767 set blobdifffd($ids) $bdf
1768 set curdifftag Comments
1771 catch {unset difffilestart}
1772 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1773 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1776 proc getblobdiffline {bdf ids} {
1777 global blobdiffids blobdifffd ctext curdifftag curtagstart seenfile
1778 global diffnexthead diffnextnote diffindex difffilestart
1781 set n [gets $bdf line]
1785 if {$ids == $blobdiffids && $bdf == $blobdifffd($ids)} {
1786 $ctext tag add $curdifftag $curtagstart end
1787 set seenfile($curdifftag) 1
1792 if {$ids != $blobdiffids || $bdf != $blobdifffd($ids)} {
1795 $ctext conf -state normal
1796 if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1797 # start of a new file
1798 $ctext insert end "\n"
1799 $ctext tag add $curdifftag $curtagstart end
1800 set seenfile($curdifftag) 1
1801 set curtagstart [$ctext index "end - 1c"]
1803 if {[info exists diffnexthead]} {
1804 set fname $diffnexthead
1805 set header "$diffnexthead ($diffnextnote)"
1808 set here [$ctext index "end - 1c"]
1809 set difffilestart($diffindex) $here
1811 # start mark names at fmark.1 for first file
1812 $ctext mark set fmark.$diffindex $here
1813 $ctext mark gravity fmark.$diffindex left
1814 set curdifftag "f:$fname"
1815 $ctext tag delete $curdifftag
1816 set l [expr {(78 - [string length $header]) / 2}]
1817 set pad [string range "----------------------------------------" 1 $l]
1818 $ctext insert end "$pad $header $pad\n" filesep
1819 } elseif {[string range $line 0 2] == "+++"} {
1820 # no need to do anything with this
1821 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1822 set diffnexthead $fn
1823 set diffnextnote "created, mode $m"
1824 } elseif {[string range $line 0 8] == "Deleted: "} {
1825 set diffnexthead [string range $line 9 end]
1826 set diffnextnote "deleted"
1827 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1828 # save the filename in case the next thing is "new file mode ..."
1829 set diffnexthead $fn
1830 set diffnextnote "modified"
1831 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1832 set diffnextnote "new file, mode $m"
1833 } elseif {[string range $line 0 11] == "deleted file"} {
1834 set diffnextnote "deleted"
1835 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1836 $line match f1l f1c f2l f2c rest]} {
1837 $ctext insert end "\t" hunksep
1838 $ctext insert end " $f1l " d0 " $f2l " d1
1839 $ctext insert end " $rest \n" hunksep
1841 set x [string range $line 0 0]
1842 if {$x == "-" || $x == "+"} {
1843 set tag [expr {$x == "+"}]
1844 set line [string range $line 1 end]
1845 $ctext insert end "$line\n" d$tag
1846 } elseif {$x == " "} {
1847 set line [string range $line 1 end]
1848 $ctext insert end "$line\n"
1849 } elseif {$x == "\\"} {
1850 # e.g. "\ No newline at end of file"
1851 $ctext insert end "$line\n" filesep
1853 # Something else we don't recognize
1854 if {$curdifftag != "Comments"} {
1855 $ctext insert end "\n"
1856 $ctext tag add $curdifftag $curtagstart end
1857 set seenfile($curdifftag) 1
1858 set curtagstart [$ctext index "end - 1c"]
1859 set curdifftag Comments
1861 $ctext insert end "$line\n" filesep
1864 $ctext conf -state disabled
1865 if {[clock clicks -milliseconds] >= $nextupdate} {
1867 fileevent $bdf readable {}
1869 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1874 global difffilestart ctext
1875 set here [$ctext index @0,0]
1876 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1877 if {[$ctext compare $difffilestart($i) > $here]} {
1878 $ctext yview $difffilestart($i)
1884 proc listboxsel {} {
1885 global ctext cflist currentid treediffs seenfile
1886 if {![info exists currentid]} return
1887 set sel [lsort [$cflist curselection]]
1888 if {$sel eq {}} return
1889 set first [lindex $sel 0]
1890 catch {$ctext yview fmark.$first}
1894 global linespc charspc canvx0 canvy0 mainfont
1895 set linespc [font metrics $mainfont -linespace]
1896 set charspc [font measure $mainfont "m"]
1897 set canvy0 [expr 3 + 0.5 * $linespc]
1898 set canvx0 [expr 3 + 0.5 * $linespc]
1902 global selectedline stopped redisplaying phase
1903 if {$stopped > 1} return
1904 if {$phase == "getcommits"} return
1906 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1913 proc incrfont {inc} {
1914 global mainfont namefont textfont selectedline ctext canv phase
1915 global stopped entries
1917 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1918 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1919 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1921 $ctext conf -font $textfont
1922 $ctext tag conf filesep -font [concat $textfont bold]
1923 foreach e $entries {
1924 $e conf -font $mainfont
1926 if {$phase == "getcommits"} {
1927 $canv itemconf textitems -font $mainfont
1933 global sha1entry sha1string
1934 if {[string length $sha1string] == 40} {
1935 $sha1entry delete 0 end
1939 proc sha1change {n1 n2 op} {
1940 global sha1string currentid sha1but
1941 if {$sha1string == {}
1942 || ([info exists currentid] && $sha1string == $currentid)} {
1947 if {[$sha1but cget -state] == $state} return
1948 if {$state == "normal"} {
1949 $sha1but conf -state normal -relief raised -text "Goto: "
1951 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1955 proc gotocommit {} {
1956 global sha1string currentid idline tagids
1957 if {$sha1string == {}
1958 || ([info exists currentid] && $sha1string == $currentid)} return
1959 if {[info exists tagids($sha1string)]} {
1960 set id $tagids($sha1string)
1962 set id [string tolower $sha1string]
1964 if {[info exists idline($id)]} {
1965 selectline $idline($id)
1968 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1973 error_popup "$type $sha1string is not known"
1976 proc lineenter {x y id} {
1977 global hoverx hovery hoverid hovertimer
1978 global commitinfo canv
1980 if {![info exists commitinfo($id)]} return
1984 if {[info exists hovertimer]} {
1985 after cancel $hovertimer
1987 set hovertimer [after 500 linehover]
1991 proc linemotion {x y id} {
1992 global hoverx hovery hoverid hovertimer
1994 if {[info exists hoverid] && $id == $hoverid} {
1997 if {[info exists hovertimer]} {
1998 after cancel $hovertimer
2000 set hovertimer [after 500 linehover]
2004 proc lineleave {id} {
2005 global hoverid hovertimer canv
2007 if {[info exists hoverid] && $id == $hoverid} {
2009 if {[info exists hovertimer]} {
2010 after cancel $hovertimer
2018 global hoverx hovery hoverid hovertimer
2019 global canv linespc lthickness
2020 global commitinfo mainfont
2022 set text [lindex $commitinfo($hoverid) 0]
2023 set ymax [lindex [$canv cget -scrollregion] 3]
2024 if {$ymax == {}} return
2025 set yfrac [lindex [$canv yview] 0]
2026 set x [expr {$hoverx + 2 * $linespc}]
2027 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2028 set x0 [expr {$x - 2 * $lthickness}]
2029 set y0 [expr {$y - 2 * $lthickness}]
2030 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2031 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2032 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2033 -fill \#ffff80 -outline black -width 1 -tags hover]
2035 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2039 proc lineclick {x y id} {
2040 global ctext commitinfo children cflist canv
2044 # fill the details pane with info about this line
2045 $ctext conf -state normal
2046 $ctext delete 0.0 end
2047 $ctext insert end "Parent:\n "
2048 catch {destroy $ctext.$id}
2049 button $ctext.$id -text "Go:" -command "selbyid $id" \
2051 $ctext window create end -window $ctext.$id -align center
2052 set info $commitinfo($id)
2053 $ctext insert end "\t[lindex $info 0]\n"
2054 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2055 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2056 $ctext insert end "\tID:\t$id\n"
2057 if {[info exists children($id)]} {
2058 $ctext insert end "\nChildren:"
2059 foreach child $children($id) {
2060 $ctext insert end "\n "
2061 catch {destroy $ctext.$child}
2062 button $ctext.$child -text "Go:" -command "selbyid $child" \
2064 $ctext window create end -window $ctext.$child -align center
2065 set info $commitinfo($child)
2066 $ctext insert end "\t[lindex $info 0]"
2069 $ctext conf -state disabled
2071 $cflist delete 0 end
2076 if {[info exists idline($id)]} {
2077 selectline $idline($id)
2083 if {![info exists startmstime]} {
2084 set startmstime [clock clicks -milliseconds]
2086 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2089 proc rowmenu {x y id} {
2090 global rowctxmenu idline selectedline rowmenuid
2092 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2097 $rowctxmenu entryconfigure 0 -state $state
2098 $rowctxmenu entryconfigure 1 -state $state
2099 $rowctxmenu entryconfigure 2 -state $state
2101 tk_popup $rowctxmenu $x $y
2104 proc diffvssel {dirn} {
2105 global rowmenuid selectedline lineid
2109 if {![info exists selectedline]} return
2111 set oldid $lineid($selectedline)
2112 set newid $rowmenuid
2114 set oldid $rowmenuid
2115 set newid $lineid($selectedline)
2117 $ctext conf -state normal
2118 $ctext delete 0.0 end
2119 $ctext mark set fmark.0 0.0
2120 $ctext mark gravity fmark.0 left
2121 $cflist delete 0 end
2122 $cflist insert end "Top"
2123 $ctext insert end "From $oldid\n "
2124 $ctext insert end [lindex $commitinfo($oldid) 0]
2125 $ctext insert end "\n\nTo $newid\n "
2126 $ctext insert end [lindex $commitinfo($newid) 0]
2127 $ctext insert end "\n"
2128 $ctext conf -state disabled
2129 $ctext tag delete Comments
2130 $ctext tag remove found 1.0 end
2131 startdiff [list $newid $oldid]
2135 global rowmenuid currentid commitinfo patchtop patchnum
2137 if {![info exists currentid]} return
2138 set oldid $currentid
2139 set oldhead [lindex $commitinfo($oldid) 0]
2140 set newid $rowmenuid
2141 set newhead [lindex $commitinfo($newid) 0]
2144 catch {destroy $top}
2146 label $top.title -text "Generate patch"
2147 grid $top.title - -pady 10
2148 label $top.from -text "From:"
2149 entry $top.fromsha1 -width 40 -relief flat
2150 $top.fromsha1 insert 0 $oldid
2151 $top.fromsha1 conf -state readonly
2152 grid $top.from $top.fromsha1 -sticky w
2153 entry $top.fromhead -width 60 -relief flat
2154 $top.fromhead insert 0 $oldhead
2155 $top.fromhead conf -state readonly
2156 grid x $top.fromhead -sticky w
2157 label $top.to -text "To:"
2158 entry $top.tosha1 -width 40 -relief flat
2159 $top.tosha1 insert 0 $newid
2160 $top.tosha1 conf -state readonly
2161 grid $top.to $top.tosha1 -sticky w
2162 entry $top.tohead -width 60 -relief flat
2163 $top.tohead insert 0 $newhead
2164 $top.tohead conf -state readonly
2165 grid x $top.tohead -sticky w
2166 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2167 grid $top.rev x -pady 10
2168 label $top.flab -text "Output file:"
2169 entry $top.fname -width 60
2170 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2172 grid $top.flab $top.fname -sticky w
2174 button $top.buts.gen -text "Generate" -command mkpatchgo
2175 button $top.buts.can -text "Cancel" -command mkpatchcan
2176 grid $top.buts.gen $top.buts.can
2177 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2178 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2179 grid $top.buts - -pady 10 -sticky ew
2183 proc mkpatchrev {} {
2186 set oldid [$patchtop.fromsha1 get]
2187 set oldhead [$patchtop.fromhead get]
2188 set newid [$patchtop.tosha1 get]
2189 set newhead [$patchtop.tohead get]
2190 foreach e [list fromsha1 fromhead tosha1 tohead] \
2191 v [list $newid $newhead $oldid $oldhead] {
2192 $patchtop.$e conf -state normal
2193 $patchtop.$e delete 0 end
2194 $patchtop.$e insert 0 $v
2195 $patchtop.$e conf -state readonly
2202 set oldid [$patchtop.fromsha1 get]
2203 set newid [$patchtop.tosha1 get]
2204 set fname [$patchtop.fname get]
2205 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2206 error_popup "Error creating patch: $err"
2208 catch {destroy $patchtop}
2212 proc mkpatchcan {} {
2215 catch {destroy $patchtop}
2220 global rowmenuid mktagtop commitinfo
2224 catch {destroy $top}
2226 label $top.title -text "Create tag"
2227 grid $top.title - -pady 10
2228 label $top.id -text "ID:"
2229 entry $top.sha1 -width 40 -relief flat
2230 $top.sha1 insert 0 $rowmenuid
2231 $top.sha1 conf -state readonly
2232 grid $top.id $top.sha1 -sticky w
2233 entry $top.head -width 60 -relief flat
2234 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2235 $top.head conf -state readonly
2236 grid x $top.head -sticky w
2237 label $top.tlab -text "Tag name:"
2238 entry $top.tag -width 60
2239 grid $top.tlab $top.tag -sticky w
2241 button $top.buts.gen -text "Create" -command mktaggo
2242 button $top.buts.can -text "Cancel" -command mktagcan
2243 grid $top.buts.gen $top.buts.can
2244 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2245 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2246 grid $top.buts - -pady 10 -sticky ew
2251 global mktagtop env tagids idtags
2252 global idpos idline linehtag canv selectedline
2254 set id [$mktagtop.sha1 get]
2255 set tag [$mktagtop.tag get]
2257 error_popup "No tag name specified"
2260 if {[info exists tagids($tag)]} {
2261 error_popup "Tag \"$tag\" already exists"
2266 if {[info exists env(GIT_DIR)]} {
2267 set dir $env(GIT_DIR)
2269 set fname [file join $dir "refs/tags" $tag]
2270 set f [open $fname w]
2274 error_popup "Error creating tag: $err"
2278 set tagids($tag) $id
2279 lappend idtags($id) $tag
2280 $canv delete tag.$id
2281 set xt [eval drawtags $id $idpos($id)]
2282 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2283 if {[info exists selectedline] && $selectedline == $idline($id)} {
2284 selectline $selectedline
2291 catch {destroy $mktagtop}
2300 proc writecommit {} {
2301 global rowmenuid wrcomtop commitinfo wrcomcmd
2303 set top .writecommit
2305 catch {destroy $top}
2307 label $top.title -text "Write commit to file"
2308 grid $top.title - -pady 10
2309 label $top.id -text "ID:"
2310 entry $top.sha1 -width 40 -relief flat
2311 $top.sha1 insert 0 $rowmenuid
2312 $top.sha1 conf -state readonly
2313 grid $top.id $top.sha1 -sticky w
2314 entry $top.head -width 60 -relief flat
2315 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2316 $top.head conf -state readonly
2317 grid x $top.head -sticky w
2318 label $top.clab -text "Command:"
2319 entry $top.cmd -width 60 -textvariable wrcomcmd
2320 grid $top.clab $top.cmd -sticky w -pady 10
2321 label $top.flab -text "Output file:"
2322 entry $top.fname -width 60
2323 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2324 grid $top.flab $top.fname -sticky w
2326 button $top.buts.gen -text "Write" -command wrcomgo
2327 button $top.buts.can -text "Cancel" -command wrcomcan
2328 grid $top.buts.gen $top.buts.can
2329 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2330 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2331 grid $top.buts - -pady 10 -sticky ew
2338 set id [$wrcomtop.sha1 get]
2339 set cmd "echo $id | [$wrcomtop.cmd get]"
2340 set fname [$wrcomtop.fname get]
2341 if {[catch {exec sh -c $cmd >$fname &} err]} {
2342 error_popup "Error writing commit: $err"
2344 catch {destroy $wrcomtop}
2351 catch {destroy $wrcomtop}
2364 set diffopts "-U 5 -p"
2365 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2367 set mainfont {Helvetica 9}
2368 set textfont {Courier 9}
2369 set findmergefiles 0
2371 set colors {green red blue magenta darkgrey brown orange}
2373 catch {source ~/.gitk}
2375 set namefont $mainfont
2377 lappend namefont bold
2382 switch -regexp -- $arg {
2384 "^-b" { set boldnames 1 }
2385 "^-d" { set datemode 1 }
2387 lappend revtreeargs $arg
2399 getcommits $revtreeargs