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
1295 if {$numcommits == 0} return
1297 # make a list of all the ids to search, starting at the one
1298 # after the selected line (if any)
1299 if {[info exists selectedline]} {
1305 for {set i 0} {$i < $numcommits} {incr i} {
1306 if {[incr l] >= $numcommits} {
1309 append inputids $lineid($l) "\n"
1313 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1316 error_popup "Error starting search process: $err"
1321 set findprocpid [pid $f]
1322 fconfigure $f -blocking 0
1323 fileevent $f readable readfindproc
1325 . config -cursor watch
1326 $ctext config -cursor watch
1327 set findinprogress 1
1330 proc readfindproc {} {
1331 global findprocfile finddidsel
1332 global idline matchinglines
1334 set n [gets $findprocfile line]
1336 if {[eof $findprocfile]} {
1344 if {![regexp {^[0-9a-f]{40}} $line id]} {
1345 error_popup "Can't parse git-diff-tree output: $line"
1349 if {![info exists idline($id)]} {
1350 puts stderr "spurious id: $id"
1354 lappend matchinglines $l
1362 global selectedline numcommits lineid
1363 global ffileline finddidsel parents findstartline
1364 global findinprogress ctext
1366 if {$numcommits == 0} return
1368 if {[info exists selectedline]} {
1369 set l [expr {$selectedline + 1}]
1375 set findstartline $l
1377 set p [lindex $parents($id) 0]
1378 . config -cursor watch
1379 $ctext config -cursor watch
1380 set findinprogress 1
1382 findcont [list $id $p]
1385 proc findcont {ids} {
1386 global findids treediffs parents nparents treepending
1387 global ffileline findstartline finddidsel
1388 global lineid numcommits matchinglines findinprogress
1389 global findmergefiles
1391 set id [lindex $ids 0]
1392 set p [lindex $ids 1]
1393 set pi [lsearch -exact $parents($id) $p]
1396 if {$findmergefiles || $nparents($id) == 1} {
1397 if {![info exists treediffs($ids)]} {
1400 if {![info exists treepending]} {
1406 foreach f $treediffs($ids) {
1407 set x [findmatches $f]
1414 lappend matchinglines $l
1420 set pi $nparents($id)
1423 set pi $nparents($id)
1425 if {[incr pi] >= $nparents($id)} {
1427 if {[incr l] >= $numcommits} {
1430 if {$l == $findstartline} break
1433 set p [lindex $parents($id) $pi]
1434 set ids [list $id $p]
1442 # mark a commit as matching by putting a yellow background
1443 # behind the headline
1444 proc markheadline {l id} {
1445 global canv mainfont linehtag commitinfo
1447 set bbox [$canv bbox $linehtag($l)]
1448 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1452 # mark the bits of a headline, author or date that match a find string
1453 proc markmatches {canv l str tag matches font} {
1454 set bbox [$canv bbox $tag]
1455 set x0 [lindex $bbox 0]
1456 set y0 [lindex $bbox 1]
1457 set y1 [lindex $bbox 3]
1458 foreach match $matches {
1459 set start [lindex $match 0]
1460 set end [lindex $match 1]
1461 if {$start > $end} continue
1462 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1463 set xlen [font measure $font [string range $str 0 [expr $end]]]
1464 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1465 -outline {} -tags matches -fill yellow]
1470 proc unmarkmatches {} {
1471 global matchinglines findids
1472 allcanvs delete matches
1473 catch {unset matchinglines}
1474 catch {unset findids}
1477 proc selcanvline {w x y} {
1478 global canv canvy0 ctext linespc selectedline
1479 global lineid linehtag linentag linedtag rowtextx
1480 set ymax [lindex [$canv cget -scrollregion] 3]
1481 if {$ymax == {}} return
1482 set yfrac [lindex [$canv yview] 0]
1483 set y [expr {$y + $yfrac * $ymax}]
1484 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1489 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1495 proc selectline {l} {
1496 global canv canv2 canv3 ctext commitinfo selectedline
1497 global lineid linehtag linentag linedtag
1498 global canvy0 linespc parents nparents
1499 global cflist currentid sha1entry diffids
1500 global commentend seenfile idtags
1502 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1504 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1505 -tags secsel -fill [$canv cget -selectbackground]]
1507 $canv2 delete secsel
1508 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1509 -tags secsel -fill [$canv2 cget -selectbackground]]
1511 $canv3 delete secsel
1512 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1513 -tags secsel -fill [$canv3 cget -selectbackground]]
1515 set y [expr {$canvy0 + $l * $linespc}]
1516 set ymax [lindex [$canv cget -scrollregion] 3]
1517 set ytop [expr {$y - $linespc - 1}]
1518 set ybot [expr {$y + $linespc + 1}]
1519 set wnow [$canv yview]
1520 set wtop [expr [lindex $wnow 0] * $ymax]
1521 set wbot [expr [lindex $wnow 1] * $ymax]
1522 set wh [expr {$wbot - $wtop}]
1524 if {$ytop < $wtop} {
1525 if {$ybot < $wtop} {
1526 set newtop [expr {$y - $wh / 2.0}]
1529 if {$newtop > $wtop - $linespc} {
1530 set newtop [expr {$wtop - $linespc}]
1533 } elseif {$ybot > $wbot} {
1534 if {$ytop > $wbot} {
1535 set newtop [expr {$y - $wh / 2.0}]
1537 set newtop [expr {$ybot - $wh}]
1538 if {$newtop < $wtop + $linespc} {
1539 set newtop [expr {$wtop + $linespc}]
1543 if {$newtop != $wtop} {
1547 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1553 set diffids [concat $id $parents($id)]
1554 $sha1entry delete 0 end
1555 $sha1entry insert 0 $id
1556 $sha1entry selection from 0
1557 $sha1entry selection to end
1559 $ctext conf -state normal
1560 $ctext delete 0.0 end
1561 $ctext mark set fmark.0 0.0
1562 $ctext mark gravity fmark.0 left
1563 set info $commitinfo($id)
1564 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1565 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1566 if {[info exists idtags($id)]} {
1567 $ctext insert end "Tags:"
1568 foreach tag $idtags($id) {
1569 $ctext insert end " $tag"
1571 $ctext insert end "\n"
1573 $ctext insert end "\n"
1574 $ctext insert end [lindex $info 5]
1575 $ctext insert end "\n"
1576 $ctext tag delete Comments
1577 $ctext tag remove found 1.0 end
1578 $ctext conf -state disabled
1579 set commentend [$ctext index "end - 1c"]
1581 $cflist delete 0 end
1582 $cflist insert end "Comments"
1583 if {$nparents($id) == 1} {
1586 catch {unset seenfile}
1590 global treediffs diffids treepending
1592 if {![info exists treediffs($diffids)]} {
1593 if {![info exists treepending]} {
1594 gettreediffs $diffids
1597 addtocflist $diffids
1601 proc selnextline {dir} {
1603 if {![info exists selectedline]} return
1604 set l [expr $selectedline + $dir]
1609 proc addtocflist {ids} {
1610 global treediffs cflist
1611 foreach f $treediffs($ids) {
1612 $cflist insert end $f
1617 proc gettreediffs {ids} {
1618 global treediffs parents treepending
1619 set treepending $ids
1620 set treediffs($ids) {}
1621 set id [lindex $ids 0]
1622 set p [lindex $ids 1]
1623 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1624 fconfigure $gdtf -blocking 0
1625 fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1628 proc gettreediffline {gdtf ids} {
1629 global treediffs treepending diffids findids
1630 set n [gets $gdtf line]
1632 if {![eof $gdtf]} return
1635 if {[info exists diffids]} {
1636 if {$ids != $diffids} {
1637 gettreediffs $diffids
1642 if {[info exists findids]} {
1643 if {$ids != $findids} {
1644 if {![info exists treepending]} {
1645 gettreediffs $findids
1653 set file [lindex $line 5]
1654 lappend treediffs($ids) $file
1657 proc getblobdiffs {ids} {
1658 global diffopts blobdifffd env curdifftag curtagstart
1659 global diffindex difffilestart nextupdate
1661 set id [lindex $ids 0]
1662 set p [lindex $ids 1]
1663 set env(GIT_DIFF_OPTS) $diffopts
1664 if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1665 puts "error getting diffs: $err"
1668 fconfigure $bdf -blocking 0
1669 set blobdifffd($ids) $bdf
1670 set curdifftag Comments
1673 catch {unset difffilestart}
1674 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1675 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1678 proc getblobdiffline {bdf ids} {
1679 global diffids blobdifffd ctext curdifftag curtagstart seenfile
1680 global diffnexthead diffnextnote diffindex difffilestart
1683 set n [gets $bdf line]
1687 if {[info exists diffids] && $ids == $diffids
1688 && $bdf == $blobdifffd($ids)} {
1689 $ctext tag add $curdifftag $curtagstart end
1690 set seenfile($curdifftag) 1
1696 if {![info exists diffids] || $ids != $diffids
1697 || $bdf != $blobdifffd($ids)} {
1700 $ctext conf -state normal
1701 if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1702 # start of a new file
1703 $ctext insert end "\n"
1704 $ctext tag add $curdifftag $curtagstart end
1705 set seenfile($curdifftag) 1
1706 set curtagstart [$ctext index "end - 1c"]
1708 if {[info exists diffnexthead]} {
1709 set fname $diffnexthead
1710 set header "$diffnexthead ($diffnextnote)"
1713 set here [$ctext index "end - 1c"]
1714 set difffilestart($diffindex) $here
1716 # start mark names at fmark.1 for first file
1717 $ctext mark set fmark.$diffindex $here
1718 $ctext mark gravity fmark.$diffindex left
1719 set curdifftag "f:$fname"
1720 $ctext tag delete $curdifftag
1721 set l [expr {(78 - [string length $header]) / 2}]
1722 set pad [string range "----------------------------------------" 1 $l]
1723 $ctext insert end "$pad $header $pad\n" filesep
1724 } elseif {[string range $line 0 2] == "+++"} {
1725 # no need to do anything with this
1726 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1727 set diffnexthead $fn
1728 set diffnextnote "created, mode $m"
1729 } elseif {[string range $line 0 8] == "Deleted: "} {
1730 set diffnexthead [string range $line 9 end]
1731 set diffnextnote "deleted"
1732 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1733 # save the filename in case the next thing is "new file mode ..."
1734 set diffnexthead $fn
1735 set diffnextnote "modified"
1736 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1737 set diffnextnote "new file, mode $m"
1738 } elseif {[string range $line 0 11] == "deleted file"} {
1739 set diffnextnote "deleted"
1740 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1741 $line match f1l f1c f2l f2c rest]} {
1742 $ctext insert end "\t" hunksep
1743 $ctext insert end " $f1l " d0 " $f2l " d1
1744 $ctext insert end " $rest \n" hunksep
1746 set x [string range $line 0 0]
1747 if {$x == "-" || $x == "+"} {
1748 set tag [expr {$x == "+"}]
1749 set line [string range $line 1 end]
1750 $ctext insert end "$line\n" d$tag
1751 } elseif {$x == " "} {
1752 set line [string range $line 1 end]
1753 $ctext insert end "$line\n"
1754 } elseif {$x == "\\"} {
1755 # e.g. "\ No newline at end of file"
1756 $ctext insert end "$line\n" filesep
1758 # Something else we don't recognize
1759 if {$curdifftag != "Comments"} {
1760 $ctext insert end "\n"
1761 $ctext tag add $curdifftag $curtagstart end
1762 set seenfile($curdifftag) 1
1763 set curtagstart [$ctext index "end - 1c"]
1764 set curdifftag Comments
1766 $ctext insert end "$line\n" filesep
1769 $ctext conf -state disabled
1770 if {[clock clicks -milliseconds] >= $nextupdate} {
1772 fileevent $bdf readable {}
1774 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1779 global difffilestart ctext
1780 set here [$ctext index @0,0]
1781 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1782 if {[$ctext compare $difffilestart($i) > $here]} {
1783 $ctext yview $difffilestart($i)
1789 proc listboxsel {} {
1790 global ctext cflist currentid treediffs seenfile
1791 if {![info exists currentid]} return
1792 set sel [lsort [$cflist curselection]]
1793 if {$sel eq {}} return
1794 set first [lindex $sel 0]
1795 catch {$ctext yview fmark.$first}
1799 global linespc charspc canvx0 canvy0 mainfont
1800 set linespc [font metrics $mainfont -linespace]
1801 set charspc [font measure $mainfont "m"]
1802 set canvy0 [expr 3 + 0.5 * $linespc]
1803 set canvx0 [expr 3 + 0.5 * $linespc]
1807 global selectedline stopped redisplaying phase
1808 if {$stopped > 1} return
1809 if {$phase == "getcommits"} return
1811 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1818 proc incrfont {inc} {
1819 global mainfont namefont textfont selectedline ctext canv phase
1820 global stopped entries
1822 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1823 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1824 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1826 $ctext conf -font $textfont
1827 $ctext tag conf filesep -font [concat $textfont bold]
1828 foreach e $entries {
1829 $e conf -font $mainfont
1831 if {$phase == "getcommits"} {
1832 $canv itemconf textitems -font $mainfont
1838 global sha1entry sha1string
1839 if {[string length $sha1string] == 40} {
1840 $sha1entry delete 0 end
1844 proc sha1change {n1 n2 op} {
1845 global sha1string currentid sha1but
1846 if {$sha1string == {}
1847 || ([info exists currentid] && $sha1string == $currentid)} {
1852 if {[$sha1but cget -state] == $state} return
1853 if {$state == "normal"} {
1854 $sha1but conf -state normal -relief raised -text "Goto: "
1856 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1860 proc gotocommit {} {
1861 global sha1string currentid idline tagids
1862 if {$sha1string == {}
1863 || ([info exists currentid] && $sha1string == $currentid)} return
1864 if {[info exists tagids($sha1string)]} {
1865 set id $tagids($sha1string)
1867 set id [string tolower $sha1string]
1869 if {[info exists idline($id)]} {
1870 selectline $idline($id)
1873 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1878 error_popup "$type $sha1string is not known"
1881 proc lineenter {x y id} {
1882 global hoverx hovery hoverid hovertimer
1883 global commitinfo canv
1885 if {![info exists commitinfo($id)]} return
1889 if {[info exists hovertimer]} {
1890 after cancel $hovertimer
1892 set hovertimer [after 500 linehover]
1896 proc linemotion {x y id} {
1897 global hoverx hovery hoverid hovertimer
1899 if {[info exists hoverid] && $id == $hoverid} {
1902 if {[info exists hovertimer]} {
1903 after cancel $hovertimer
1905 set hovertimer [after 500 linehover]
1909 proc lineleave {id} {
1910 global hoverid hovertimer canv
1912 if {[info exists hoverid] && $id == $hoverid} {
1914 if {[info exists hovertimer]} {
1915 after cancel $hovertimer
1923 global hoverx hovery hoverid hovertimer
1924 global canv linespc lthickness
1925 global commitinfo mainfont
1927 set text [lindex $commitinfo($hoverid) 0]
1928 set ymax [lindex [$canv cget -scrollregion] 3]
1929 if {$ymax == {}} return
1930 set yfrac [lindex [$canv yview] 0]
1931 set x [expr {$hoverx + 2 * $linespc}]
1932 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1933 set x0 [expr {$x - 2 * $lthickness}]
1934 set y0 [expr {$y - 2 * $lthickness}]
1935 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1936 set y1 [expr {$y + $linespc + 2 * $lthickness}]
1937 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1938 -fill \#ffff80 -outline black -width 1 -tags hover]
1940 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1944 proc lineclick {x y id} {
1945 global ctext commitinfo children cflist canv
1949 # fill the details pane with info about this line
1950 $ctext conf -state normal
1951 $ctext delete 0.0 end
1952 $ctext insert end "Parent:\n "
1953 catch {destroy $ctext.$id}
1954 button $ctext.$id -text "Go:" -command "selbyid $id" \
1956 $ctext window create end -window $ctext.$id -align center
1957 set info $commitinfo($id)
1958 $ctext insert end "\t[lindex $info 0]\n"
1959 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1960 $ctext insert end "\tDate:\t[lindex $info 2]\n"
1961 $ctext insert end "\tID:\t$id\n"
1962 if {[info exists children($id)]} {
1963 $ctext insert end "\nChildren:"
1964 foreach child $children($id) {
1965 $ctext insert end "\n "
1966 catch {destroy $ctext.$child}
1967 button $ctext.$child -text "Go:" -command "selbyid $child" \
1969 $ctext window create end -window $ctext.$child -align center
1970 set info $commitinfo($child)
1971 $ctext insert end "\t[lindex $info 0]"
1974 $ctext conf -state disabled
1976 $cflist delete 0 end
1981 if {[info exists idline($id)]} {
1982 selectline $idline($id)
1988 if {![info exists startmstime]} {
1989 set startmstime [clock clicks -milliseconds]
1991 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1994 proc rowmenu {x y id} {
1995 global rowctxmenu idline selectedline rowmenuid
1997 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2002 $rowctxmenu entryconfigure 0 -state $state
2003 $rowctxmenu entryconfigure 1 -state $state
2004 $rowctxmenu entryconfigure 2 -state $state
2006 tk_popup $rowctxmenu $x $y
2009 proc diffvssel {dirn} {
2010 global rowmenuid selectedline lineid
2012 global diffids commitinfo
2014 if {![info exists selectedline]} return
2016 set oldid $lineid($selectedline)
2017 set newid $rowmenuid
2019 set oldid $rowmenuid
2020 set newid $lineid($selectedline)
2022 $ctext conf -state normal
2023 $ctext delete 0.0 end
2024 $ctext mark set fmark.0 0.0
2025 $ctext mark gravity fmark.0 left
2026 $cflist delete 0 end
2027 $cflist insert end "Top"
2028 $ctext insert end "From $oldid\n "
2029 $ctext insert end [lindex $commitinfo($oldid) 0]
2030 $ctext insert end "\n\nTo $newid\n "
2031 $ctext insert end [lindex $commitinfo($newid) 0]
2032 $ctext insert end "\n"
2033 $ctext conf -state disabled
2034 $ctext tag delete Comments
2035 $ctext tag remove found 1.0 end
2036 set diffids [list $newid $oldid]
2041 global rowmenuid currentid commitinfo patchtop patchnum
2043 if {![info exists currentid]} return
2044 set oldid $currentid
2045 set oldhead [lindex $commitinfo($oldid) 0]
2046 set newid $rowmenuid
2047 set newhead [lindex $commitinfo($newid) 0]
2050 catch {destroy $top}
2052 label $top.title -text "Generate patch"
2053 grid $top.title - -pady 10
2054 label $top.from -text "From:"
2055 entry $top.fromsha1 -width 40 -relief flat
2056 $top.fromsha1 insert 0 $oldid
2057 $top.fromsha1 conf -state readonly
2058 grid $top.from $top.fromsha1 -sticky w
2059 entry $top.fromhead -width 60 -relief flat
2060 $top.fromhead insert 0 $oldhead
2061 $top.fromhead conf -state readonly
2062 grid x $top.fromhead -sticky w
2063 label $top.to -text "To:"
2064 entry $top.tosha1 -width 40 -relief flat
2065 $top.tosha1 insert 0 $newid
2066 $top.tosha1 conf -state readonly
2067 grid $top.to $top.tosha1 -sticky w
2068 entry $top.tohead -width 60 -relief flat
2069 $top.tohead insert 0 $newhead
2070 $top.tohead conf -state readonly
2071 grid x $top.tohead -sticky w
2072 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2073 grid $top.rev x -pady 10
2074 label $top.flab -text "Output file:"
2075 entry $top.fname -width 60
2076 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2078 grid $top.flab $top.fname -sticky w
2080 button $top.buts.gen -text "Generate" -command mkpatchgo
2081 button $top.buts.can -text "Cancel" -command mkpatchcan
2082 grid $top.buts.gen $top.buts.can
2083 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2084 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2085 grid $top.buts - -pady 10 -sticky ew
2089 proc mkpatchrev {} {
2092 set oldid [$patchtop.fromsha1 get]
2093 set oldhead [$patchtop.fromhead get]
2094 set newid [$patchtop.tosha1 get]
2095 set newhead [$patchtop.tohead get]
2096 foreach e [list fromsha1 fromhead tosha1 tohead] \
2097 v [list $newid $newhead $oldid $oldhead] {
2098 $patchtop.$e conf -state normal
2099 $patchtop.$e delete 0 end
2100 $patchtop.$e insert 0 $v
2101 $patchtop.$e conf -state readonly
2108 set oldid [$patchtop.fromsha1 get]
2109 set newid [$patchtop.tosha1 get]
2110 set fname [$patchtop.fname get]
2111 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2112 error_popup "Error creating patch: $err"
2114 catch {destroy $patchtop}
2118 proc mkpatchcan {} {
2121 catch {destroy $patchtop}
2126 global rowmenuid mktagtop commitinfo
2130 catch {destroy $top}
2132 label $top.title -text "Create tag"
2133 grid $top.title - -pady 10
2134 label $top.id -text "ID:"
2135 entry $top.sha1 -width 40 -relief flat
2136 $top.sha1 insert 0 $rowmenuid
2137 $top.sha1 conf -state readonly
2138 grid $top.id $top.sha1 -sticky w
2139 entry $top.head -width 60 -relief flat
2140 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2141 $top.head conf -state readonly
2142 grid x $top.head -sticky w
2143 label $top.tlab -text "Tag name:"
2144 entry $top.tag -width 60
2145 grid $top.tlab $top.tag -sticky w
2147 button $top.buts.gen -text "Create" -command mktaggo
2148 button $top.buts.can -text "Cancel" -command mktagcan
2149 grid $top.buts.gen $top.buts.can
2150 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2151 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2152 grid $top.buts - -pady 10 -sticky ew
2157 global mktagtop env tagids idtags
2158 global idpos idline linehtag canv selectedline
2160 set id [$mktagtop.sha1 get]
2161 set tag [$mktagtop.tag get]
2163 error_popup "No tag name specified"
2166 if {[info exists tagids($tag)]} {
2167 error_popup "Tag \"$tag\" already exists"
2172 if {[info exists env(GIT_DIR)]} {
2173 set dir $env(GIT_DIR)
2175 set fname [file join $dir "refs/tags" $tag]
2176 set f [open $fname w]
2180 error_popup "Error creating tag: $err"
2184 set tagids($tag) $id
2185 lappend idtags($id) $tag
2186 $canv delete tag.$id
2187 set xt [eval drawtags $id $idpos($id)]
2188 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2189 if {[info exists selectedline] && $selectedline == $idline($id)} {
2190 selectline $selectedline
2197 catch {destroy $mktagtop}
2206 proc writecommit {} {
2207 global rowmenuid wrcomtop commitinfo wrcomcmd
2209 set top .writecommit
2211 catch {destroy $top}
2213 label $top.title -text "Write commit to file"
2214 grid $top.title - -pady 10
2215 label $top.id -text "ID:"
2216 entry $top.sha1 -width 40 -relief flat
2217 $top.sha1 insert 0 $rowmenuid
2218 $top.sha1 conf -state readonly
2219 grid $top.id $top.sha1 -sticky w
2220 entry $top.head -width 60 -relief flat
2221 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2222 $top.head conf -state readonly
2223 grid x $top.head -sticky w
2224 label $top.clab -text "Command:"
2225 entry $top.cmd -width 60 -textvariable wrcomcmd
2226 grid $top.clab $top.cmd -sticky w -pady 10
2227 label $top.flab -text "Output file:"
2228 entry $top.fname -width 60
2229 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2230 grid $top.flab $top.fname -sticky w
2232 button $top.buts.gen -text "Write" -command wrcomgo
2233 button $top.buts.can -text "Cancel" -command wrcomcan
2234 grid $top.buts.gen $top.buts.can
2235 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2236 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2237 grid $top.buts - -pady 10 -sticky ew
2244 set id [$wrcomtop.sha1 get]
2245 set cmd "echo $id | [$wrcomtop.cmd get]"
2246 set fname [$wrcomtop.fname get]
2247 if {[catch {exec sh -c $cmd >$fname &} err]} {
2248 error_popup "Error writing commit: $err"
2250 catch {destroy $wrcomtop}
2257 catch {destroy $wrcomtop}
2270 set diffopts "-U 5 -p"
2271 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2273 set mainfont {Helvetica 9}
2274 set textfont {Courier 9}
2275 set findmergefiles 0
2277 set colors {green red blue magenta darkgrey brown orange}
2279 catch {source ~/.gitk}
2281 set namefont $mainfont
2283 lappend namefont bold
2288 switch -regexp -- $arg {
2290 "^-b" { set boldnames 1 }
2291 "^-d" { set datemode 1 }
2293 lappend revtreeargs $arg
2305 getcommits $revtreeargs