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.
12 if {[info exists env
(GIT_DIR
)]} {
19 proc getcommits
{rargs
} {
20 global commits commfd phase canv mainfont env
21 global startmsecs nextupdate ncmupdate
22 global ctext maincursor textcursor leftover
24 # check that we can find a .git directory somewhere...
26 if {![file isdirectory
$gitdir]} {
27 error_popup
"Cannot find the git directory \"$gitdir\"."
32 set startmsecs
[clock clicks
-milliseconds]
33 set nextupdate
[expr $startmsecs + 100]
36 set parse_args
[concat
--default HEAD
$rargs]
37 set parsed_args
[split [eval exec git-rev-parse
$parse_args] "\n"]
39 # if git-rev-parse failed for some reason...
43 set parsed_args
$rargs
46 set commfd
[open
"|git-rev-list --header --topo-order $parsed_args" r
]
48 puts stderr
"Error executing git-rev-list: $err"
52 fconfigure
$commfd -blocking 0 -translation lf
53 fileevent
$commfd readable
[list getcommitlines
$commfd]
55 $canv create text
3 3 -anchor nw
-text "Reading commits..." \
56 -font $mainfont -tags textitems
57 . config
-cursor watch
61 proc getcommitlines
{commfd
} {
62 global commits parents cdate children nchildren
63 global commitlisted phase commitinfo nextupdate
64 global stopped redisplaying leftover
65 global numcommits ncmupdate
67 set stuff
[read $commfd]
69 if {![eof
$commfd]} return
70 # set it blocking so we wait for the process to terminate
71 fconfigure
$commfd -blocking 1
72 if {![catch
{close
$commfd} err
]} {
73 after idle finishcommits
76 if {[string range
$err 0 4] == "usage"} {
78 {Gitk
: error reading commits
: bad arguments to git-rev-list.
79 (Note
: arguments to gitk are passed to git-rev-list
80 to allow selection of commits to be displayed.
)}
82 set err
"Error reading commits: $err"
89 set i
[string first
"\0" $stuff $start]
91 append leftover
[string range
$stuff $start end
]
94 set cmit
[string range
$stuff $start [expr {$i - 1}]]
96 set cmit
"$leftover$cmit"
99 set start
[expr {$i + 1}]
100 if {![regexp
{^
([0-9a-f]{40})\n} $cmit match id
]} {
102 if {[string length
$shortcmit] > 80} {
103 set shortcmit
"[string range $shortcmit 0 80]..."
105 error_popup
"Can't parse git-rev-list output: {$shortcmit}"
108 set cmit
[string range
$cmit 41 end
]
110 set commitlisted
($id) 1
111 parsecommit
$id $cmit 1
113 if {[clock clicks
-milliseconds] >= $nextupdate
114 && $numcommits >= $ncmupdate + 100} {
116 set ncmupdate
$numcommits
118 while {$redisplaying} {
122 set phase
"getcommits"
123 foreach id
$commits {
126 if {[clock clicks
-milliseconds] >= $nextupdate
127 && $numcommits >= $ncmupdate + 100} {
129 set ncmupdate
$numcommits
138 global commfd nextupdate
141 fileevent
$commfd readable
{}
143 fileevent
$commfd readable
[list getcommitlines
$commfd]
146 proc readcommit
{id
} {
147 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
148 parsecommit
$id $contents 0
151 proc parsecommit
{id contents listed
} {
152 global commitinfo children nchildren parents nparents cdate ncleft
161 if {![info exists nchildren
($id)]} {
168 foreach line
[split $contents "\n"] {
173 set tag
[lindex
$line 0]
174 if {$tag == "parent"} {
175 set p
[lindex
$line 1]
176 if {![info exists nchildren
($p)]} {
181 lappend parents
($id) $p
183 # sometimes we get a commit that lists a parent twice...
184 if {$listed && [lsearch
-exact $children($p) $id] < 0} {
185 lappend children
($p) $id
189 } elseif
{$tag == "author"} {
190 set x
[expr {[llength
$line] - 2}]
191 set audate
[lindex
$line $x]
192 set auname
[lrange
$line 1 [expr {$x - 1}]]
193 } elseif
{$tag == "committer"} {
194 set x
[expr {[llength
$line] - 2}]
195 set comdate
[lindex
$line $x]
196 set comname
[lrange
$line 1 [expr {$x - 1}]]
200 if {$comment == {}} {
201 set headline
[string trim
$line]
206 # git-rev-list indents the comment by 4 spaces;
207 # if we got this via git-cat-file, add the indentation
214 set audate
[clock format
$audate -format "%Y-%m-%d %H:%M:%S"]
216 if {$comdate != {}} {
217 set cdate
($id) $comdate
218 set comdate
[clock format
$comdate -format "%Y-%m-%d %H:%M:%S"]
220 set commitinfo
($id) [list
$headline $auname $audate \
221 $comname $comdate $comment]
225 global tagids idtags headids idheads
226 set tags
[glob
-nocomplain -types f
[gitdir
]/refs
/tags
/*]
231 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
232 set direct
[file tail $f]
233 set tagids
($direct) $id
234 lappend idtags
($id) $direct
235 set contents
[split [exec git-cat-file tag
$id] "\n"]
239 foreach l
$contents {
241 switch
-- [lindex
$l 0] {
242 "object" {set obj
[lindex
$l 1]}
243 "type" {set type [lindex
$l 1]}
244 "tag" {set tag
[string range
$l 4 end
]}
247 if {$obj != {} && $type == "commit" && $tag != {}} {
248 set tagids
($tag) $obj
249 lappend idtags
($obj) $tag
255 set heads
[glob
-nocomplain -types f
[gitdir
]/refs
/heads
/*]
259 set line
[read $fd 40]
260 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
261 set head [file tail $f]
262 set headids
($head) $line
263 lappend idheads
($line) $head
270 proc error_popup msg
{
274 message
$w.m
-text $msg -justify center
-aspect 400
275 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
276 button
$w.ok
-text OK
-command "destroy $w"
277 pack
$w.ok
-side bottom
-fill x
278 bind $w <Visibility
> "grab $w; focus $w"
283 global canv canv2 canv3 linespc charspc ctext cflist textfont
284 global findtype findtypemenu findloc findstring fstring geometry
285 global entries sha1entry sha1string sha1but
286 global maincursor textcursor curtextcursor
287 global rowctxmenu gaudydiff mergemax
290 .bar add cascade
-label "File" -menu .bar.
file
292 .bar.
file add
command -label "Quit" -command doquit
294 .bar add cascade
-label "Help" -menu .bar.
help
295 .bar.
help add
command -label "About gitk" -command about
296 . configure
-menu .bar
298 if {![info exists geometry
(canv1
)]} {
299 set geometry
(canv1
) [expr 45 * $charspc]
300 set geometry
(canv2
) [expr 30 * $charspc]
301 set geometry
(canv3
) [expr 15 * $charspc]
302 set geometry
(canvh
) [expr 25 * $linespc + 4]
303 set geometry
(ctextw
) 80
304 set geometry
(ctexth
) 30
305 set geometry
(cflistw
) 30
307 panedwindow .ctop
-orient vertical
308 if {[info exists geometry
(width
)]} {
309 .ctop conf
-width $geometry(width
) -height $geometry(height
)
310 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
311 set geometry
(ctexth
) [expr {($texth - 8) /
312 [font metrics
$textfont -linespace]}]
316 pack .ctop.top.bar
-side bottom
-fill x
317 set cscroll .ctop.top.csb
318 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
319 pack
$cscroll -side right
-fill y
320 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
321 pack .ctop.top.clist
-side top
-fill both
-expand 1
323 set canv .ctop.top.clist.canv
324 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
326 -yscrollincr $linespc -yscrollcommand "$cscroll set"
327 .ctop.top.clist add
$canv
328 set canv2 .ctop.top.clist.canv2
329 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
330 -bg white
-bd 0 -yscrollincr $linespc
331 .ctop.top.clist add
$canv2
332 set canv3 .ctop.top.clist.canv3
333 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
334 -bg white
-bd 0 -yscrollincr $linespc
335 .ctop.top.clist add
$canv3
336 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
338 set sha1entry .ctop.top.bar.sha1
339 set entries
$sha1entry
340 set sha1but .ctop.top.bar.sha1label
341 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
342 -command gotocommit
-width 8
343 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
344 pack .ctop.top.bar.sha1label
-side left
345 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
346 trace add variable sha1string
write sha1change
347 pack
$sha1entry -side left
-pady 2
349 image create bitmap bm-left
-data {
350 #define left_width 16
351 #define left_height 16
352 static unsigned char left_bits
[] = {
353 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
354 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
355 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
357 image create bitmap bm-right
-data {
358 #define right_width 16
359 #define right_height 16
360 static unsigned char right_bits
[] = {
361 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
362 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
363 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
365 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
366 -state disabled
-width 26
367 pack .ctop.top.bar.leftbut
-side left
-fill y
368 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
369 -state disabled
-width 26
370 pack .ctop.top.bar.rightbut
-side left
-fill y
372 button .ctop.top.bar.findbut
-text "Find" -command dofind
373 pack .ctop.top.bar.findbut
-side left
375 set fstring .ctop.top.bar.findstring
376 lappend entries
$fstring
377 entry
$fstring -width 30 -font $textfont -textvariable findstring
378 pack
$fstring -side left
-expand 1 -fill x
380 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
381 findtype Exact IgnCase Regexp
]
382 set findloc
"All fields"
383 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
384 Comments Author Committer Files Pickaxe
385 pack .ctop.top.bar.findloc
-side right
386 pack .ctop.top.bar.findtype
-side right
387 # for making sure type==Exact whenever loc==Pickaxe
388 trace add variable findloc
write findlocchange
390 panedwindow .ctop.cdet
-orient horizontal
392 frame .ctop.cdet.left
393 set ctext .ctop.cdet.left.ctext
394 text
$ctext -bg white
-state disabled
-font $textfont \
395 -width $geometry(ctextw
) -height $geometry(ctexth
) \
396 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
397 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
398 pack .ctop.cdet.left.sb
-side right
-fill y
399 pack
$ctext -side left
-fill both
-expand 1
400 .ctop.cdet add .ctop.cdet.left
402 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
404 $ctext tag conf hunksep
-back blue
-fore white
405 $ctext tag conf d0
-back "#ff8080"
406 $ctext tag conf d1
-back green
408 $ctext tag conf hunksep
-fore blue
409 $ctext tag conf d0
-fore red
410 $ctext tag conf d1
-fore "#00a000"
411 $ctext tag conf m0
-fore red
412 $ctext tag conf m1
-fore blue
413 $ctext tag conf m2
-fore green
414 $ctext tag conf m3
-fore purple
415 $ctext tag conf
m4 -fore brown
416 $ctext tag conf mmax
-fore darkgrey
418 $ctext tag conf mresult
-font [concat
$textfont bold
]
419 $ctext tag conf msep
-font [concat
$textfont bold
]
420 $ctext tag conf found
-back yellow
423 frame .ctop.cdet.right
424 set cflist .ctop.cdet.right.cfiles
425 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
426 -yscrollcommand ".ctop.cdet.right.sb set"
427 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
428 pack .ctop.cdet.right.sb
-side right
-fill y
429 pack
$cflist -side left
-fill both
-expand 1
430 .ctop.cdet add .ctop.cdet.right
431 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
433 pack .ctop
-side top
-fill both
-expand 1
435 bindall
<1> {selcanvline
%W
%x
%y
}
436 #bindall <B1-Motion> {selcanvline %W %x %y}
437 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
438 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
439 bindall
<2> "allcanvs scan mark 0 %y"
440 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
441 bind .
<Key-Up
> "selnextline -1"
442 bind .
<Key-Down
> "selnextline 1"
443 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
444 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
445 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
446 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
447 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
448 bindkey p
"selnextline -1"
449 bindkey n
"selnextline 1"
450 bindkey b
"$ctext yview scroll -1 pages"
451 bindkey d
"$ctext yview scroll 18 units"
452 bindkey u
"$ctext yview scroll -18 units"
453 bindkey
/ {findnext
1}
454 bindkey
<Key-Return
> {findnext
0}
457 bind .
<Control-q
> doquit
458 bind .
<Control-f
> dofind
459 bind .
<Control-g
> {findnext
0}
460 bind .
<Control-r
> findprev
461 bind .
<Control-equal
> {incrfont
1}
462 bind .
<Control-KP_Add
> {incrfont
1}
463 bind .
<Control-minus
> {incrfont
-1}
464 bind .
<Control-KP_Subtract
> {incrfont
-1}
465 bind $cflist <<ListboxSelect>> listboxsel
466 bind . <Destroy> {savestuff %W}
467 bind . <Button-1> "click %W"
468 bind $fstring <Key-Return> dofind
469 bind $sha1entry <Key-Return> gotocommit
470 bind $sha1entry <<PasteSelection>> clearsha1
472 set maincursor [. cget -cursor]
473 set textcursor [$ctext cget -cursor]
474 set curtextcursor $textcursor
476 set rowctxmenu .rowctxmenu
477 menu $rowctxmenu -tearoff 0
478 $rowctxmenu add command -label "Diff this -> selected" \
479 -command {diffvssel 0}
480 $rowctxmenu add command -label "Diff selected -> this" \
481 -command {diffvssel 1}
482 $rowctxmenu add command -label "Make patch" -command mkpatch
483 $rowctxmenu add command -label "Create tag" -command mktag
484 $rowctxmenu add command -label "Write commit to file" -command writecommit
487 # when we make a key binding for the toplevel, make sure
488 # it doesn't get triggered when that key is pressed in the
489 # find string entry widget.
490 proc bindkey {ev script} {
493 set escript [bind Entry $ev]
494 if {$escript == {}} {
495 set escript [bind Entry <Key>]
498 bind $e $ev "$escript; break"
502 # set the focus back to the toplevel for any click outside
513 global canv canv2 canv3 ctext cflist mainfont textfont
514 global stuffsaved findmergefiles gaudydiff maxgraphpct
516 if {$stuffsaved} return
517 if {![winfo viewable .]} return
519 set f [open "~/.gitk-new" w]
520 puts $f [list set mainfont $mainfont]
521 puts $f [list set textfont $textfont]
522 puts $f [list set findmergefiles $findmergefiles]
523 puts $f [list set gaudydiff $gaudydiff]
524 puts $f [list set maxgraphpct $maxgraphpct]
525 puts $f "set geometry(width) [winfo width .ctop]"
526 puts $f "set geometry(height) [winfo height .ctop]"
527 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
528 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
529 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
530 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
531 set wid [expr {([winfo width $ctext] - 8) \
532 / [font measure $textfont "0"]}]
533 puts $f "set geometry(ctextw) $wid"
534 set wid [expr {([winfo width $cflist] - 11) \
535 / [font measure [$cflist cget -font] "0"]}]
536 puts $f "set geometry(cflistw) $wid"
538 file rename -force "~/.gitk-new" "~/.gitk"
543 proc resizeclistpanes {win w} {
545 if [info exists oldwidth($win)] {
546 set s0 [$win sash coord 0]
547 set s1 [$win sash coord 1]
549 set sash0 [expr {int($w/2 - 2)}]
550 set sash1 [expr {int($w*5/6 - 2)}]
552 set factor [expr {1.0 * $w / $oldwidth($win)}]
553 set sash0 [expr {int($factor * [lindex $s0 0])}]
554 set sash1 [expr {int($factor * [lindex $s1 0])}]
558 if {$sash1 < $sash0 + 20} {
559 set sash1 [expr $sash0 + 20]
561 if {$sash1 > $w - 10} {
562 set sash1 [expr $w - 10]
563 if {$sash0 > $sash1 - 20} {
564 set sash0 [expr $sash1 - 20]
568 $win sash place 0 $sash0 [lindex $s0 1]
569 $win sash place 1 $sash1 [lindex $s1 1]
571 set oldwidth($win) $w
574 proc resizecdetpanes {win w} {
576 if [info exists oldwidth($win)] {
577 set s0 [$win sash coord 0]
579 set sash0 [expr {int($w*3/4 - 2)}]
581 set factor [expr {1.0 * $w / $oldwidth($win)}]
582 set sash0 [expr {int($factor * [lindex $s0 0])}]
586 if {$sash0 > $w - 15} {
587 set sash0 [expr $w - 15]
590 $win sash place 0 $sash0 [lindex $s0 1]
592 set oldwidth($win) $w
596 global canv canv2 canv3
602 proc bindall {event action} {
603 global canv canv2 canv3
604 bind $canv $event $action
605 bind $canv2 $event $action
606 bind $canv3 $event $action
611 if {[winfo exists $w]} {
616 wm title $w "About gitk"
620 Copyright © 2005 Paul Mackerras
622 Use and redistribute under the terms of the GNU General Public License} \
623 -justify center -aspect 400
624 pack $w.m -side top -fill x -padx 20 -pady 20
625 button $w.ok -text Close -command "destroy $w"
626 pack $w.ok -side bottom
629 proc assigncolor {id} {
630 global commitinfo colormap commcolors colors nextcolor
631 global parents nparents children nchildren
632 global cornercrossings crossings
634 if [info exists colormap($id)] return
635 set ncolors [llength $colors]
636 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
637 set child [lindex $children($id) 0]
638 if {[info exists colormap($child)]
639 && $nparents($child) == 1} {
640 set colormap($id) $colormap($child)
645 if {[info exists cornercrossings($id)]} {
646 foreach x $cornercrossings($id) {
647 if {[info exists colormap($x)]
648 && [lsearch -exact $badcolors $colormap($x)] < 0} {
649 lappend badcolors $colormap($x)
652 if {[llength $badcolors] >= $ncolors} {
656 set origbad $badcolors
657 if {[llength $badcolors] < $ncolors - 1} {
658 if {[info exists crossings($id)]} {
659 foreach x $crossings($id) {
660 if {[info exists colormap($x)]
661 && [lsearch -exact $badcolors $colormap($x)] < 0} {
662 lappend badcolors $colormap($x)
665 if {[llength $badcolors] >= $ncolors} {
666 set badcolors $origbad
669 set origbad $badcolors
671 if {[llength $badcolors] < $ncolors - 1} {
672 foreach child $children($id) {
673 if {[info exists colormap($child)]
674 && [lsearch -exact $badcolors $colormap($child)] < 0} {
675 lappend badcolors $colormap($child)
677 if {[info exists parents($child)]} {
678 foreach p $parents($child) {
679 if {[info exists colormap($p)]
680 && [lsearch -exact $badcolors $colormap($p)] < 0} {
681 lappend badcolors $colormap($p)
686 if {[llength $badcolors] >= $ncolors} {
687 set badcolors $origbad
690 for {set i 0} {$i <= $ncolors} {incr i} {
691 set c [lindex $colors $nextcolor]
692 if {[incr nextcolor] >= $ncolors} {
695 if {[lsearch -exact $badcolors $c]} break
701 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
702 global mainline sidelines
703 global nchildren ncleft
710 set lthickness [expr {int($linespc / 9) + 1}]
711 catch {unset mainline}
712 catch {unset sidelines}
713 foreach id [array names nchildren] {
714 set ncleft($id) $nchildren($id)
718 proc bindline {t id} {
721 $canv bind $t <Enter> "lineenter %x %y $id"
722 $canv bind $t <Motion> "linemotion %x %y $id"
723 $canv bind $t <Leave> "lineleave $id"
724 $canv bind $t <Button-1> "lineclick %x %y $id 1"
727 proc drawcommitline {level} {
728 global parents children nparents nchildren todo
729 global canv canv2 canv3 mainfont namefont canvy linespc
730 global lineid linehtag linentag linedtag commitinfo
731 global colormap numcommits currentparents dupparents
732 global oldlevel oldnlines oldtodo
733 global idtags idline idheads
734 global lineno lthickness mainline sidelines
735 global commitlisted rowtextx idpos
739 set id [lindex $todo $level]
740 set lineid($lineno) $id
741 set idline($id) $lineno
742 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
743 if {![info exists commitinfo($id)]} {
745 if {![info exists commitinfo($id)]} {
746 set commitinfo($id) {"No commit information available"}
751 set currentparents {}
753 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
754 foreach p $parents($id) {
755 if {[lsearch -exact $currentparents $p] < 0} {
756 lappend currentparents $p
758 # remember that this parent was listed twice
759 lappend dupparents $p
763 set x [xcoord $level $level $lineno]
765 set canvy [expr $canvy + $linespc]
766 allcanvs conf -scrollregion \
767 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
768 if {[info exists mainline($id)]} {
769 lappend mainline($id) $x $y1
770 set t [$canv create line $mainline($id) \
771 -width $lthickness -fill $colormap($id)]
775 if {[info exists sidelines($id)]} {
776 foreach ls $sidelines($id) {
777 set coords [lindex $ls 0]
778 set thick [lindex $ls 1]
779 set t [$canv create line $coords -fill $colormap($id) \
780 -width [expr {$thick * $lthickness}]]
785 set orad [expr {$linespc / 3}]
786 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
787 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
788 -fill $ofill -outline black -width 1]
790 $canv bind $t <1> {selcanvline {} %x %y}
791 set xt [xcoord [llength $todo] $level $lineno]
792 if {[llength $currentparents] > 2} {
793 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
795 set rowtextx($lineno) $xt
796 set idpos($id) [list $x $xt $y1]
797 if {[info exists idtags($id)] || [info exists idheads($id)]} {
798 set xt [drawtags $id $x $xt $y1]
800 set headline [lindex $commitinfo($id) 0]
801 set name [lindex $commitinfo($id) 1]
802 set date [lindex $commitinfo($id) 2]
803 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
804 -text $headline -font $mainfont ]
805 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
806 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
807 -text $name -font $namefont]
808 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
809 -text $date -font $mainfont]
812 proc drawtags {id x xt y1} {
813 global idtags idheads
814 global linespc lthickness
819 if {[info exists idtags($id)]} {
820 set marks $idtags($id)
821 set ntags [llength $marks]
823 if {[info exists idheads($id)]} {
824 set marks [concat $marks $idheads($id)]
830 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
831 set yt [expr $y1 - 0.5 * $linespc]
832 set yb [expr $yt + $linespc - 1]
836 set wid [font measure $mainfont $tag]
839 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
841 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
842 -width $lthickness -fill black -tags tag.$id]
844 foreach tag $marks x $xvals wid $wvals {
845 set xl [expr $x + $delta]
846 set xr [expr $x + $delta + $wid + $lthickness]
847 if {[incr ntags -1] >= 0} {
849 $canv create polygon $x [expr $yt + $delta] $xl $yt\
850 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
851 -width 1 -outline black -fill yellow -tags tag.$id
854 set xl [expr $xl - $delta/2]
855 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
856 -width 1 -outline black -fill green -tags tag.$id
858 $canv create text $xl $y1 -anchor w -text $tag \
859 -font $mainfont -tags tag.$id
864 proc updatetodo {level noshortcut} {
865 global currentparents ncleft todo
866 global mainline oldlevel oldtodo oldnlines
867 global canvy linespc mainline
868 global commitinfo lineno xspc1
872 set oldnlines [llength $todo]
873 if {!$noshortcut && [llength $currentparents] == 1} {
874 set p [lindex $currentparents 0]
875 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
877 set x [xcoord $level $level $lineno]
878 set y [expr $canvy - $linespc]
879 set mainline($p) [list $x $y]
880 set todo [lreplace $todo $level $level $p]
881 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
886 set todo [lreplace $todo $level $level]
888 foreach p $currentparents {
890 set k [lsearch -exact $todo $p]
892 set todo [linsert $todo $i $p]
899 proc notecrossings {id lo hi corner} {
900 global oldtodo crossings cornercrossings
902 for {set i $lo} {[incr i] < $hi} {} {
903 set p [lindex $oldtodo $i]
904 if {$p == {}} continue
906 if {![info exists cornercrossings($id)]
907 || [lsearch -exact $cornercrossings($id) $p] < 0} {
908 lappend cornercrossings($id) $p
910 if {![info exists cornercrossings($p)]
911 || [lsearch -exact $cornercrossings($p) $id] < 0} {
912 lappend cornercrossings($p) $id
915 if {![info exists crossings($id)]
916 || [lsearch -exact $crossings($id) $p] < 0} {
917 lappend crossings($id) $p
919 if {![info exists crossings($p)]
920 || [lsearch -exact $crossings($p) $id] < 0} {
921 lappend crossings($p) $id
927 proc xcoord {i level ln} {
928 global canvx0 xspc1 xspc2
930 set x [expr {$canvx0 + $i * $xspc1($ln)}]
931 if {$i > 0 && $i == $level} {
932 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
933 } elseif {$i > $level} {
934 set x [expr {$x + $xspc2 - $xspc1($ln)}]
939 proc drawslants {level} {
940 global canv mainline sidelines canvx0 canvy xspc1 xspc2 lthickness
941 global oldlevel oldtodo todo currentparents dupparents
942 global lthickness linespc canvy colormap lineno geometry
945 # decide on the line spacing for the next line
946 set lj [expr {$lineno + 1}]
947 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
948 set n [llength $todo]
949 if {$n <= 1 || $canvx0 + $n * $xspc2 <= $maxw} {
950 set xspc1($lj) $xspc2
952 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($n - 1)}]
953 if {$xspc1($lj) < $lthickness} {
954 set xspc1($lj) $lthickness
958 set y1 [expr $canvy - $linespc]
961 foreach id $oldtodo {
963 if {$id == {}} continue
964 set xi [xcoord $i $oldlevel $lineno]
965 if {$i == $oldlevel} {
966 foreach p $currentparents {
967 set j [lsearch -exact $todo $p]
968 set coords [list $xi $y1]
969 set xj [xcoord $j $level $lj]
970 if {$xj < $xi - $linespc} {
971 lappend coords [expr {$xj + $linespc}] $y1
972 notecrossings $p $j $i [expr {$j + 1}]
973 } elseif {$xj > $xi + $linespc} {
974 lappend coords [expr {$xj - $linespc}] $y1
975 notecrossings $p $i $j [expr {$j - 1}]
977 if {[lsearch -exact $dupparents $p] >= 0} {
978 # draw a double-width line to indicate the doubled parent
979 lappend coords $xj $y2
980 lappend sidelines($p) [list $coords 2]
981 if {![info exists mainline($p)]} {
982 set mainline($p) [list $xj $y2]
985 # normal case, no parent duplicated
987 set dx [expr {abs($xi - $xj)}]
988 if {0 && $dx < $linespc} {
989 set yb [expr {$y1 + $dx}]
991 if {![info exists mainline($p)]} {
993 lappend coords $xj $yb
995 set mainline($p) $coords
997 lappend coords $xj $yb
999 lappend coords $xj $y2
1001 lappend sidelines($p) [list $coords 1]
1007 if {[lindex $todo $i] != $id} {
1008 set j [lsearch -exact $todo $id]
1010 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1011 || ($oldlevel <= $i && $i <= $level)
1012 || ($level <= $i && $i <= $oldlevel)} {
1013 set xj [xcoord $j $level $lj]
1014 set dx [expr {abs($xi - $xj)}]
1016 if {0 && $dx < $linespc} {
1017 set yb [expr {$y1 + $dx}]
1019 lappend mainline($id) $xi $y1 $xj $yb
1025 proc decidenext {{noread 0}} {
1026 global parents children nchildren ncleft todo
1027 global canv canv2 canv3 mainfont namefont canvy linespc
1028 global datemode cdate
1030 global currentparents oldlevel oldnlines oldtodo
1031 global lineno lthickness
1033 # remove the null entry if present
1034 set nullentry [lsearch -exact $todo {}]
1035 if {$nullentry >= 0} {
1036 set todo [lreplace $todo $nullentry $nullentry]
1039 # choose which one to do next time around
1040 set todol [llength $todo]
1043 for {set k $todol} {[incr k -1] >= 0} {} {
1044 set p [lindex $todo $k]
1045 if {$ncleft($p) == 0} {
1047 if {![info exists commitinfo($p)]} {
1053 if {$latest == {} || $cdate($p) > $latest} {
1055 set latest $cdate($p)
1065 puts "ERROR: none of the pending commits can be done yet:"
1067 puts " $p ($ncleft($p))"
1073 # If we are reducing, put in a null entry
1074 if {$todol < $oldnlines} {
1075 if {$nullentry >= 0} {
1078 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1088 set todo [linsert $todo $i {}]
1097 proc drawcommit {id} {
1098 global phase todo nchildren datemode nextupdate
1099 global startcommits numcommits ncmupdate
1101 if {$phase != "incrdraw"} {
1104 set startcommits $id
1107 updatetodo 0 $datemode
1109 if {$nchildren($id) == 0} {
1111 lappend startcommits $id
1113 set level [decidenext 1]
1114 if {$level == {} || $id != [lindex $todo $level]} {
1119 drawcommitline $level
1120 if {[updatetodo $level $datemode]} {
1121 set level [decidenext 1]
1122 if {$level == {}} break
1124 set id [lindex $todo $level]
1125 if {![info exists commitlisted($id)]} {
1128 if {[clock clicks -milliseconds] >= $nextupdate
1129 && $numcommits >= $ncmupdate} {
1131 set ncmupdate $numcommits
1138 proc finishcommits {} {
1141 global canv mainfont ctext maincursor textcursor
1143 if {$phase != "incrdraw"} {
1145 $canv create text 3 3 -anchor nw -text "No commits selected" \
1146 -font $mainfont -tags textitems
1149 set level [decidenext]
1151 drawrest $level [llength $startcommits]
1153 . config -cursor $maincursor
1154 settextcursor $textcursor
1157 # Don't change the text pane cursor if it is currently the hand cursor,
1158 # showing that we are over a sha1 ID link.
1159 proc settextcursor {c} {
1160 global ctext curtextcursor
1162 if {[$ctext cget -cursor] == $curtextcursor} {
1163 $ctext config -cursor $c
1165 set curtextcursor $c
1169 global nextupdate startmsecs startcommits todo ncmupdate
1171 if {$startcommits == {}} return
1172 set startmsecs [clock clicks -milliseconds]
1173 set nextupdate [expr $startmsecs + 100]
1176 set todo [lindex $startcommits 0]
1180 proc drawrest {level startix} {
1181 global phase stopped redisplaying selectedline
1182 global datemode currentparents todo
1183 global numcommits ncmupdate
1184 global nextupdate startmsecs startcommits idline
1188 set startid [lindex $startcommits $startix]
1190 if {$startid != {}} {
1191 set startline $idline($startid)
1195 drawcommitline $level
1196 set hard [updatetodo $level $datemode]
1197 if {$numcommits == $startline} {
1198 lappend todo $startid
1201 set startid [lindex $startcommits $startix]
1203 if {$startid != {}} {
1204 set startline $idline($startid)
1208 set level [decidenext]
1209 if {$level < 0} break
1212 if {[clock clicks -milliseconds] >= $nextupdate
1213 && $numcommits >= $ncmupdate + 100} {
1216 set ncmupdate $numcommits
1221 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1222 #puts "overall $drawmsecs ms for $numcommits commits"
1223 if {$redisplaying} {
1224 if {$stopped == 0 && [info exists selectedline]} {
1225 selectline $selectedline 0
1227 if {$stopped == 1} {
1229 after idle drawgraph
1236 proc findmatches {f} {
1237 global findtype foundstring foundstrlen
1238 if {$findtype == "Regexp"} {
1239 set matches [regexp -indices -all -inline $foundstring $f]
1241 if {$findtype == "IgnCase"} {
1242 set str [string tolower $f]
1248 while {[set j [string first $foundstring $str $i]] >= 0} {
1249 lappend matches [list $j [expr $j+$foundstrlen-1]]
1250 set i [expr $j + $foundstrlen]
1257 global findtype findloc findstring markedmatches commitinfo
1258 global numcommits lineid linehtag linentag linedtag
1259 global mainfont namefont canv canv2 canv3 selectedline
1260 global matchinglines foundstring foundstrlen
1265 set matchinglines {}
1266 if {$findloc == "Pickaxe"} {
1270 if {$findtype == "IgnCase"} {
1271 set foundstring [string tolower $findstring]
1273 set foundstring $findstring
1275 set foundstrlen [string length $findstring]
1276 if {$foundstrlen == 0} return
1277 if {$findloc == "Files"} {
1281 if {![info exists selectedline]} {
1284 set oldsel $selectedline
1287 set fldtypes {Headline Author Date Committer CDate Comment}
1288 for {set l 0} {$l < $numcommits} {incr l} {
1290 set info $commitinfo($id)
1292 foreach f $info ty $fldtypes {
1293 if {$findloc != "All fields" && $findloc != $ty} {
1296 set matches [findmatches $f]
1297 if {$matches == {}} continue
1299 if {$ty == "Headline"} {
1300 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1301 } elseif {$ty == "Author"} {
1302 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1303 } elseif {$ty == "Date"} {
1304 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1308 lappend matchinglines $l
1309 if {!$didsel && $l > $oldsel} {
1315 if {$matchinglines == {}} {
1317 } elseif {!$didsel} {
1318 findselectline [lindex $matchinglines 0]
1322 proc findselectline {l} {
1323 global findloc commentend ctext
1325 if {$findloc == "All fields" || $findloc == "Comments"} {
1326 # highlight the matches in the comments
1327 set f [$ctext get 1.0 $commentend]
1328 set matches [findmatches $f]
1329 foreach match $matches {
1330 set start [lindex $match 0]
1331 set end [expr [lindex $match 1] + 1]
1332 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1337 proc findnext {restart} {
1338 global matchinglines selectedline
1339 if {![info exists matchinglines]} {
1345 if {![info exists selectedline]} return
1346 foreach l $matchinglines {
1347 if {$l > $selectedline} {
1356 global matchinglines selectedline
1357 if {![info exists matchinglines]} {
1361 if {![info exists selectedline]} return
1363 foreach l $matchinglines {
1364 if {$l >= $selectedline} break
1368 findselectline $prev
1374 proc findlocchange {name ix op} {
1375 global findloc findtype findtypemenu
1376 if {$findloc == "Pickaxe"} {
1382 $findtypemenu entryconf 1 -state $state
1383 $findtypemenu entryconf 2 -state $state
1386 proc stopfindproc {{done 0}} {
1387 global findprocpid findprocfile findids
1388 global ctext findoldcursor phase maincursor textcursor
1389 global findinprogress
1391 catch {unset findids}
1392 if {[info exists findprocpid]} {
1394 catch {exec kill $findprocpid}
1396 catch {close $findprocfile}
1399 if {[info exists findinprogress]} {
1400 unset findinprogress
1401 if {$phase != "incrdraw"} {
1402 . config -cursor $maincursor
1403 settextcursor $textcursor
1408 proc findpatches {} {
1409 global findstring selectedline numcommits
1410 global findprocpid findprocfile
1411 global finddidsel ctext lineid findinprogress
1412 global findinsertpos
1414 if {$numcommits == 0} return
1416 # make a list of all the ids to search, starting at the one
1417 # after the selected line (if any)
1418 if {[info exists selectedline]} {
1424 for {set i 0} {$i < $numcommits} {incr i} {
1425 if {[incr l] >= $numcommits} {
1428 append inputids $lineid($l) "\n"
1432 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1435 error_popup "Error starting search process: $err"
1439 set findinsertpos end
1441 set findprocpid [pid $f]
1442 fconfigure $f -blocking 0
1443 fileevent $f readable readfindproc
1445 . config -cursor watch
1447 set findinprogress 1
1450 proc readfindproc {} {
1451 global findprocfile finddidsel
1452 global idline matchinglines findinsertpos
1454 set n [gets $findprocfile line]
1456 if {[eof $findprocfile]} {
1464 if {![regexp {^[0-9a-f]{40}} $line id]} {
1465 error_popup "Can't parse git-diff-tree output: $line"
1469 if {![info exists idline($id)]} {
1470 puts stderr "spurious id: $id"
1477 proc insertmatch {l id} {
1478 global matchinglines findinsertpos finddidsel
1480 if {$findinsertpos == "end"} {
1481 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1482 set matchinglines [linsert $matchinglines 0 $l]
1485 lappend matchinglines $l
1488 set matchinglines [linsert $matchinglines $findinsertpos $l]
1499 global selectedline numcommits lineid ctext
1500 global ffileline finddidsel parents nparents
1501 global findinprogress findstartline findinsertpos
1502 global treediffs fdiffids fdiffsneeded fdiffpos
1503 global findmergefiles
1505 if {$numcommits == 0} return
1507 if {[info exists selectedline]} {
1508 set l [expr {$selectedline + 1}]
1513 set findstartline $l
1518 if {$findmergefiles || $nparents($id) == 1} {
1519 foreach p $parents($id) {
1520 if {![info exists treediffs([list $id $p])]} {
1521 append diffsneeded "$id $p\n"
1522 lappend fdiffsneeded [list $id $p]
1526 if {[incr l] >= $numcommits} {
1529 if {$l == $findstartline} break
1532 # start off a git-diff-tree process if needed
1533 if {$diffsneeded ne {}} {
1535 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1537 error_popup "Error starting search process: $err"
1540 catch {unset fdiffids}
1542 fconfigure $df -blocking 0
1543 fileevent $df readable [list readfilediffs $df]
1547 set findinsertpos end
1549 set p [lindex $parents($id) 0]
1550 . config -cursor watch
1552 set findinprogress 1
1553 findcont [list $id $p]
1557 proc readfilediffs {df} {
1558 global findids fdiffids fdiffs
1560 set n [gets $df line]
1564 if {[catch {close $df} err]} {
1567 error_popup "Error in git-diff-tree: $err"
1568 } elseif {[info exists findids]} {
1572 error_popup "Couldn't find diffs for {$ids}"
1577 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1578 # start of a new string of diffs
1580 set fdiffids [list $id $p]
1582 } elseif {[string match ":*" $line]} {
1583 lappend fdiffs [lindex $line 5]
1587 proc donefilediff {} {
1588 global fdiffids fdiffs treediffs findids
1589 global fdiffsneeded fdiffpos
1591 if {[info exists fdiffids]} {
1592 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1593 && $fdiffpos < [llength $fdiffsneeded]} {
1594 # git-diff-tree doesn't output anything for a commit
1595 # which doesn't change anything
1596 set nullids [lindex $fdiffsneeded $fdiffpos]
1597 set treediffs($nullids) {}
1598 if {[info exists findids] && $nullids eq $findids} {
1606 if {![info exists treediffs($fdiffids)]} {
1607 set treediffs($fdiffids) $fdiffs
1609 if {[info exists findids] && $fdiffids eq $findids} {
1616 proc findcont {ids} {
1617 global findids treediffs parents nparents
1618 global ffileline findstartline finddidsel
1619 global lineid numcommits matchinglines findinprogress
1620 global findmergefiles
1622 set id [lindex $ids 0]
1623 set p [lindex $ids 1]
1624 set pi [lsearch -exact $parents($id) $p]
1627 if {$findmergefiles || $nparents($id) == 1} {
1628 if {![info exists treediffs($ids)]} {
1634 foreach f $treediffs($ids) {
1635 set x [findmatches $f]
1643 set pi $nparents($id)
1646 set pi $nparents($id)
1648 if {[incr pi] >= $nparents($id)} {
1650 if {[incr l] >= $numcommits} {
1653 if {$l == $findstartline} break
1656 set p [lindex $parents($id) $pi]
1657 set ids [list $id $p]
1665 # mark a commit as matching by putting a yellow background
1666 # behind the headline
1667 proc markheadline {l id} {
1668 global canv mainfont linehtag commitinfo
1670 set bbox [$canv bbox $linehtag($l)]
1671 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1675 # mark the bits of a headline, author or date that match a find string
1676 proc markmatches {canv l str tag matches font} {
1677 set bbox [$canv bbox $tag]
1678 set x0 [lindex $bbox 0]
1679 set y0 [lindex $bbox 1]
1680 set y1 [lindex $bbox 3]
1681 foreach match $matches {
1682 set start [lindex $match 0]
1683 set end [lindex $match 1]
1684 if {$start > $end} continue
1685 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1686 set xlen [font measure $font [string range $str 0 [expr $end]]]
1687 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1688 -outline {} -tags matches -fill yellow]
1693 proc unmarkmatches {} {
1694 global matchinglines findids
1695 allcanvs delete matches
1696 catch {unset matchinglines}
1697 catch {unset findids}
1700 proc selcanvline {w x y} {
1701 global canv canvy0 ctext linespc
1702 global lineid linehtag linentag linedtag rowtextx
1703 set ymax [lindex [$canv cget -scrollregion] 3]
1704 if {$ymax == {}} return
1705 set yfrac [lindex [$canv yview] 0]
1706 set y [expr {$y + $yfrac * $ymax}]
1707 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1712 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1718 proc commit_descriptor {p} {
1721 if {[info exists commitinfo($p)]} {
1722 set l [lindex $commitinfo($p) 0]
1727 proc selectline {l isnew} {
1728 global canv canv2 canv3 ctext commitinfo selectedline
1729 global lineid linehtag linentag linedtag
1730 global canvy0 linespc parents nparents children nchildren
1731 global cflist currentid sha1entry
1732 global commentend idtags idline
1735 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1737 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1738 -tags secsel -fill [$canv cget -selectbackground]]
1740 $canv2 delete secsel
1741 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1742 -tags secsel -fill [$canv2 cget -selectbackground]]
1744 $canv3 delete secsel
1745 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1746 -tags secsel -fill [$canv3 cget -selectbackground]]
1748 set y [expr {$canvy0 + $l * $linespc}]
1749 set ymax [lindex [$canv cget -scrollregion] 3]
1750 set ytop [expr {$y - $linespc - 1}]
1751 set ybot [expr {$y + $linespc + 1}]
1752 set wnow [$canv yview]
1753 set wtop [expr [lindex $wnow 0] * $ymax]
1754 set wbot [expr [lindex $wnow 1] * $ymax]
1755 set wh [expr {$wbot - $wtop}]
1757 if {$ytop < $wtop} {
1758 if {$ybot < $wtop} {
1759 set newtop [expr {$y - $wh / 2.0}]
1762 if {$newtop > $wtop - $linespc} {
1763 set newtop [expr {$wtop - $linespc}]
1766 } elseif {$ybot > $wbot} {
1767 if {$ytop > $wbot} {
1768 set newtop [expr {$y - $wh / 2.0}]
1770 set newtop [expr {$ybot - $wh}]
1771 if {$newtop < $wtop + $linespc} {
1772 set newtop [expr {$wtop + $linespc}]
1776 if {$newtop != $wtop} {
1780 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1784 addtohistory [list selectline $l 0]
1791 $sha1entry delete 0 end
1792 $sha1entry insert 0 $id
1793 $sha1entry selection from 0
1794 $sha1entry selection to end
1796 $ctext conf -state normal
1797 $ctext delete 0.0 end
1798 $ctext mark set fmark.0 0.0
1799 $ctext mark gravity fmark.0 left
1800 set info $commitinfo($id)
1801 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1802 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1803 if {[info exists idtags($id)]} {
1804 $ctext insert end "Tags:"
1805 foreach tag $idtags($id) {
1806 $ctext insert end " $tag"
1808 $ctext insert end "\n"
1811 set commentstart [$ctext index "end - 1c"]
1813 if {[info exists parents($id)]} {
1814 foreach p $parents($id) {
1815 append comment "Parent: [commit_descriptor $p]\n"
1818 if {[info exists children($id)]} {
1819 foreach c $children($id) {
1820 append comment "Child: [commit_descriptor $c]\n"
1824 append comment [lindex $info 5]
1825 $ctext insert end $comment
1826 $ctext insert end "\n"
1828 # make anything that looks like a SHA1 ID be a clickable link
1829 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
1834 set linkid [string range $comment $s $e]
1835 if {![info exists idline($linkid)]} continue
1837 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
1838 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
1839 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
1842 $ctext tag conf link -foreground blue -underline 1
1843 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
1844 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
1846 $ctext tag delete Comments
1847 $ctext tag remove found 1.0 end
1848 $ctext conf -state disabled
1849 set commentend [$ctext index "end - 1c"]
1851 $cflist delete 0 end
1852 $cflist insert end "Comments"
1853 if {$nparents($id) == 1} {
1854 startdiff [concat $id $parents($id)]
1855 } elseif {$nparents($id) > 1} {
1860 proc selnextline {dir} {
1862 if {![info exists selectedline]} return
1863 set l [expr $selectedline + $dir]
1868 proc unselectline {} {
1871 catch {unset selectedline}
1872 allcanvs delete secsel
1875 proc addtohistory {cmd} {
1876 global history historyindex
1878 if {$historyindex > 0
1879 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
1883 if {$historyindex < [llength $history]} {
1884 set history [lreplace $history $historyindex end $cmd]
1886 lappend history $cmd
1889 if {$historyindex > 1} {
1890 .ctop.top.bar.leftbut conf -state normal
1892 .ctop.top.bar.leftbut conf -state disabled
1894 .ctop.top.bar.rightbut conf -state disabled
1898 global history historyindex
1900 if {$historyindex > 1} {
1901 incr historyindex -1
1902 set cmd [lindex $history [expr {$historyindex - 1}]]
1904 .ctop.top.bar.rightbut conf -state normal
1906 if {$historyindex <= 1} {
1907 .ctop.top.bar.leftbut conf -state disabled
1912 global history historyindex
1914 if {$historyindex < [llength $history]} {
1915 set cmd [lindex $history $historyindex]
1918 .ctop.top.bar.leftbut conf -state normal
1920 if {$historyindex >= [llength $history]} {
1921 .ctop.top.bar.rightbut conf -state disabled
1925 proc mergediff {id} {
1926 global parents diffmergeid diffmergegca mergefilelist diffpindex
1930 set diffmergegca [findgca $parents($id)]
1931 if {[info exists mergefilelist($id)]} {
1932 if {$mergefilelist($id) ne {}} {
1940 proc findgca {ids} {
1947 set gca [exec git-merge-base $gca $id]
1956 proc contmergediff {ids} {
1957 global diffmergeid diffpindex parents nparents diffmergegca
1958 global treediffs mergefilelist diffids treepending
1960 # diff the child against each of the parents, and diff
1961 # each of the parents against the GCA.
1963 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
1964 set ids [list [lindex $ids 1] $diffmergegca]
1966 if {[incr diffpindex] >= $nparents($diffmergeid)} break
1967 set p [lindex $parents($diffmergeid) $diffpindex]
1968 set ids [list $diffmergeid $p]
1970 if {![info exists treediffs($ids)]} {
1972 if {![info exists treepending]} {
1979 # If a file in some parent is different from the child and also
1980 # different from the GCA, then it's interesting.
1981 # If we don't have a GCA, then a file is interesting if it is
1982 # different from the child in all the parents.
1983 if {$diffmergegca ne {}} {
1985 foreach p $parents($diffmergeid) {
1986 set gcadiffs $treediffs([list $p $diffmergegca])
1987 foreach f $treediffs([list $diffmergeid $p]) {
1988 if {[lsearch -exact $files $f] < 0
1989 && [lsearch -exact $gcadiffs $f] >= 0} {
1994 set files [lsort $files]
1996 set p [lindex $parents($diffmergeid) 0]
1997 set files $treediffs([list $diffmergeid $p])
1998 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
1999 set p [lindex $parents($diffmergeid) $i]
2000 set df $treediffs([list $diffmergeid $p])
2003 if {[lsearch -exact $df $f] >= 0} {
2011 set mergefilelist($diffmergeid) $files
2017 proc showmergediff {} {
2018 global cflist diffmergeid mergefilelist parents
2019 global diffopts diffinhunk currentfile currenthunk filelines
2020 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2022 set files $mergefilelist($diffmergeid)
2024 $cflist insert end $f
2026 set env(GIT_DIFF_OPTS) $diffopts
2028 catch {unset currentfile}
2029 catch {unset currenthunk}
2030 catch {unset filelines}
2031 catch {unset groupfilenum}
2032 catch {unset grouphunks}
2033 set groupfilelast -1
2034 foreach p $parents($diffmergeid) {
2035 set cmd [list | git-diff-tree -p $p $diffmergeid]
2036 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2037 if {[catch {set f [open $cmd r]} err]} {
2038 error_popup "Error getting diffs: $err"
2045 set ids [list $diffmergeid $p]
2046 set mergefds($ids) $f
2047 set diffinhunk($ids) 0
2048 set diffblocked($ids) 0
2049 fconfigure $f -blocking 0
2050 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2054 proc getmergediffline {f ids id} {
2055 global diffmergeid diffinhunk diffoldlines diffnewlines
2056 global currentfile currenthunk
2057 global diffoldstart diffnewstart diffoldlno diffnewlno
2058 global diffblocked mergefilelist
2059 global noldlines nnewlines difflcounts filelines
2061 set n [gets $f line]
2063 if {![eof $f]} return
2066 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2073 if {$diffinhunk($ids) != 0} {
2074 set fi $currentfile($ids)
2075 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2076 # continuing an existing hunk
2077 set line [string range $line 1 end]
2078 set p [lindex $ids 1]
2079 if {$match eq "-" || $match eq " "} {
2080 set filelines($p,$fi,$diffoldlno($ids)) $line
2081 incr diffoldlno($ids)
2083 if {$match eq "+" || $match eq " "} {
2084 set filelines($id,$fi,$diffnewlno($ids)) $line
2085 incr diffnewlno($ids)
2087 if {$match eq " "} {
2088 if {$diffinhunk($ids) == 2} {
2089 lappend difflcounts($ids) \
2090 [list $noldlines($ids) $nnewlines($ids)]
2091 set noldlines($ids) 0
2092 set diffinhunk($ids) 1
2094 incr noldlines($ids)
2095 } elseif {$match eq "-" || $match eq "+"} {
2096 if {$diffinhunk($ids) == 1} {
2097 lappend difflcounts($ids) [list $noldlines($ids)]
2098 set noldlines($ids) 0
2099 set nnewlines($ids) 0
2100 set diffinhunk($ids) 2
2102 if {$match eq "-"} {
2103 incr noldlines($ids)
2105 incr nnewlines($ids)
2108 # and if it's \ No newline at end of line, then what?
2112 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2113 lappend difflcounts($ids) [list $noldlines($ids)]
2114 } elseif {$diffinhunk($ids) == 2
2115 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2116 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2118 set currenthunk($ids) [list $currentfile($ids) \
2119 $diffoldstart($ids) $diffnewstart($ids) \
2120 $diffoldlno($ids) $diffnewlno($ids) \
2122 set diffinhunk($ids) 0
2123 # -1 = need to block, 0 = unblocked, 1 = is blocked
2124 set diffblocked($ids) -1
2126 if {$diffblocked($ids) == -1} {
2127 fileevent $f readable {}
2128 set diffblocked($ids) 1
2134 if {!$diffblocked($ids)} {
2136 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2137 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2140 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2141 # start of a new file
2142 set currentfile($ids) \
2143 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2144 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2145 $line match f1l f1c f2l f2c rest]} {
2146 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2147 # start of a new hunk
2148 if {$f1l == 0 && $f1c == 0} {
2151 if {$f2l == 0 && $f2c == 0} {
2154 set diffinhunk($ids) 1
2155 set diffoldstart($ids) $f1l
2156 set diffnewstart($ids) $f2l
2157 set diffoldlno($ids) $f1l
2158 set diffnewlno($ids) $f2l
2159 set difflcounts($ids) {}
2160 set noldlines($ids) 0
2161 set nnewlines($ids) 0
2166 proc processhunks {} {
2167 global diffmergeid parents nparents currenthunk
2168 global mergefilelist diffblocked mergefds
2169 global grouphunks grouplinestart grouplineend groupfilenum
2171 set nfiles [llength $mergefilelist($diffmergeid)]
2175 # look for the earliest hunk
2176 foreach p $parents($diffmergeid) {
2177 set ids [list $diffmergeid $p]
2178 if {![info exists currenthunk($ids)]} return
2179 set i [lindex $currenthunk($ids) 0]
2180 set l [lindex $currenthunk($ids) 2]
2181 if {$i < $fi || ($i == $fi && $l < $lno)} {
2188 if {$fi < $nfiles} {
2189 set ids [list $diffmergeid $pi]
2190 set hunk $currenthunk($ids)
2191 unset currenthunk($ids)
2192 if {$diffblocked($ids) > 0} {
2193 fileevent $mergefds($ids) readable \
2194 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2196 set diffblocked($ids) 0
2198 if {[info exists groupfilenum] && $groupfilenum == $fi
2199 && $lno <= $grouplineend} {
2200 # add this hunk to the pending group
2201 lappend grouphunks($pi) $hunk
2202 set endln [lindex $hunk 4]
2203 if {$endln > $grouplineend} {
2204 set grouplineend $endln
2210 # succeeding stuff doesn't belong in this group, so
2211 # process the group now
2212 if {[info exists groupfilenum]} {
2218 if {$fi >= $nfiles} break
2221 set groupfilenum $fi
2222 set grouphunks($pi) [list $hunk]
2223 set grouplinestart $lno
2224 set grouplineend [lindex $hunk 4]
2228 proc processgroup {} {
2229 global groupfilelast groupfilenum difffilestart
2230 global mergefilelist diffmergeid ctext filelines
2231 global parents diffmergeid diffoffset
2232 global grouphunks grouplinestart grouplineend nparents
2235 $ctext conf -state normal
2238 if {$groupfilelast != $f} {
2239 $ctext insert end "\n"
2240 set here [$ctext index "end - 1c"]
2241 set difffilestart($f) $here
2242 set mark fmark.[expr {$f + 1}]
2243 $ctext mark set $mark $here
2244 $ctext mark gravity $mark left
2245 set header [lindex $mergefilelist($id) $f]
2246 set l [expr {(78 - [string length $header]) / 2}]
2247 set pad [string range "----------------------------------------" 1 $l]
2248 $ctext insert end "$pad $header $pad\n" filesep
2249 set groupfilelast $f
2250 foreach p $parents($id) {
2251 set diffoffset($p) 0
2255 $ctext insert end "@@" msep
2256 set nlines [expr {$grouplineend - $grouplinestart}]
2259 foreach p $parents($id) {
2260 set startline [expr {$grouplinestart + $diffoffset($p)}]
2262 set nl $grouplinestart
2263 if {[info exists grouphunks($p)]} {
2264 foreach h $grouphunks($p) {
2267 for {} {$nl < $l} {incr nl} {
2268 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2272 foreach chunk [lindex $h 5] {
2273 if {[llength $chunk] == 2} {
2274 set olc [lindex $chunk 0]
2275 set nlc [lindex $chunk 1]
2276 set nnl [expr {$nl + $nlc}]
2277 lappend events [list $nl $nnl $pnum $olc $nlc]
2281 incr ol [lindex $chunk 0]
2282 incr nl [lindex $chunk 0]
2287 if {$nl < $grouplineend} {
2288 for {} {$nl < $grouplineend} {incr nl} {
2289 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2293 set nlines [expr {$ol - $startline}]
2294 $ctext insert end " -$startline,$nlines" msep
2298 set nlines [expr {$grouplineend - $grouplinestart}]
2299 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2301 set events [lsort -integer -index 0 $events]
2302 set nevents [llength $events]
2303 set nmerge $nparents($diffmergeid)
2304 set l $grouplinestart
2305 for {set i 0} {$i < $nevents} {set i $j} {
2306 set nl [lindex $events $i 0]
2308 $ctext insert end " $filelines($id,$f,$l)\n"
2311 set e [lindex $events $i]
2312 set enl [lindex $e 1]
2316 set pnum [lindex $e 2]
2317 set olc [lindex $e 3]
2318 set nlc [lindex $e 4]
2319 if {![info exists delta($pnum)]} {
2320 set delta($pnum) [expr {$olc - $nlc}]
2321 lappend active $pnum
2323 incr delta($pnum) [expr {$olc - $nlc}]
2325 if {[incr j] >= $nevents} break
2326 set e [lindex $events $j]
2327 if {[lindex $e 0] >= $enl} break
2328 if {[lindex $e 1] > $enl} {
2329 set enl [lindex $e 1]
2332 set nlc [expr {$enl - $l}]
2335 if {[llength $active] == $nmerge - 1} {
2336 # no diff for one of the parents, i.e. it's identical
2337 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2338 if {![info exists delta($pnum)]} {
2339 if {$pnum < $mergemax} {
2347 } elseif {[llength $active] == $nmerge} {
2348 # all parents are different, see if one is very similar
2350 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2351 set sim [similarity $pnum $l $nlc $f \
2352 [lrange $events $i [expr {$j-1}]]]
2353 if {$sim > $bestsim} {
2359 lappend ncol m$bestpn
2363 foreach p $parents($id) {
2365 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2366 set olc [expr {$nlc + $delta($pnum)}]
2367 set ol [expr {$l + $diffoffset($p)}]
2368 incr diffoffset($p) $delta($pnum)
2370 for {} {$olc > 0} {incr olc -1} {
2371 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2375 set endl [expr {$l + $nlc}]
2377 # show this pretty much as a normal diff
2378 set p [lindex $parents($id) $bestpn]
2379 set ol [expr {$l + $diffoffset($p)}]
2380 incr diffoffset($p) $delta($bestpn)
2381 unset delta($bestpn)
2382 for {set k $i} {$k < $j} {incr k} {
2383 set e [lindex $events $k]
2384 if {[lindex $e 2] != $bestpn} continue
2385 set nl [lindex $e 0]
2386 set ol [expr {$ol + $nl - $l}]
2387 for {} {$l < $nl} {incr l} {
2388 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2391 for {} {$c > 0} {incr c -1} {
2392 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2395 set nl [lindex $e 1]
2396 for {} {$l < $nl} {incr l} {
2397 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2401 for {} {$l < $endl} {incr l} {
2402 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2405 while {$l < $grouplineend} {
2406 $ctext insert end " $filelines($id,$f,$l)\n"
2409 $ctext conf -state disabled
2412 proc similarity {pnum l nlc f events} {
2413 global diffmergeid parents diffoffset filelines
2416 set p [lindex $parents($id) $pnum]
2417 set ol [expr {$l + $diffoffset($p)}]
2418 set endl [expr {$l + $nlc}]
2422 if {[lindex $e 2] != $pnum} continue
2423 set nl [lindex $e 0]
2424 set ol [expr {$ol + $nl - $l}]
2425 for {} {$l < $nl} {incr l} {
2426 incr same [string length $filelines($id,$f,$l)]
2429 set oc [lindex $e 3]
2430 for {} {$oc > 0} {incr oc -1} {
2431 incr diff [string length $filelines($p,$f,$ol)]
2435 set nl [lindex $e 1]
2436 for {} {$l < $nl} {incr l} {
2437 incr diff [string length $filelines($id,$f,$l)]
2441 for {} {$l < $endl} {incr l} {
2442 incr same [string length $filelines($id,$f,$l)]
2448 return [expr {200 * $same / (2 * $same + $diff)}]
2451 proc startdiff {ids} {
2452 global treediffs diffids treepending diffmergeid
2455 catch {unset diffmergeid}
2456 if {![info exists treediffs($ids)]} {
2457 if {![info exists treepending]} {
2465 proc addtocflist {ids} {
2466 global treediffs cflist
2467 foreach f $treediffs($ids) {
2468 $cflist insert end $f
2473 proc gettreediffs {ids} {
2474 global treediff parents treepending
2475 set treepending $ids
2477 set id [lindex $ids 0]
2478 set p [lindex $ids 1]
2479 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2480 fconfigure $gdtf -blocking 0
2481 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2484 proc gettreediffline {gdtf ids} {
2485 global treediff treediffs treepending diffids diffmergeid
2487 set n [gets $gdtf line]
2489 if {![eof $gdtf]} return
2491 set treediffs($ids) $treediff
2493 if {$ids != $diffids} {
2494 gettreediffs $diffids
2496 if {[info exists diffmergeid]} {
2504 set file [lindex $line 5]
2505 lappend treediff $file
2508 proc getblobdiffs {ids} {
2509 global diffopts blobdifffd diffids env curdifftag curtagstart
2510 global difffilestart nextupdate diffinhdr treediffs
2512 set id [lindex $ids 0]
2513 set p [lindex $ids 1]
2514 set env(GIT_DIFF_OPTS) $diffopts
2515 set cmd [list | git-diff-tree -r -p -C $p $id]
2516 if {[catch {set bdf [open $cmd r]} err]} {
2517 puts "error getting diffs: $err"
2521 fconfigure $bdf -blocking 0
2522 set blobdifffd($ids) $bdf
2523 set curdifftag Comments
2525 catch {unset difffilestart}
2526 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2527 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2530 proc getblobdiffline {bdf ids} {
2531 global diffids blobdifffd ctext curdifftag curtagstart
2532 global diffnexthead diffnextnote difffilestart
2533 global nextupdate diffinhdr treediffs
2536 set n [gets $bdf line]
2540 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2541 $ctext tag add $curdifftag $curtagstart end
2546 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2549 $ctext conf -state normal
2550 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2551 # start of a new file
2552 $ctext insert end "\n"
2553 $ctext tag add $curdifftag $curtagstart end
2554 set curtagstart [$ctext index "end - 1c"]
2556 set here [$ctext index "end - 1c"]
2557 set i [lsearch -exact $treediffs($diffids) $fname]
2559 set difffilestart($i) $here
2561 $ctext mark set fmark.$i $here
2562 $ctext mark gravity fmark.$i left
2564 if {$newname != $fname} {
2565 set i [lsearch -exact $treediffs($diffids) $newname]
2567 set difffilestart($i) $here
2569 $ctext mark set fmark.$i $here
2570 $ctext mark gravity fmark.$i left
2573 set curdifftag "f:$fname"
2574 $ctext tag delete $curdifftag
2575 set l [expr {(78 - [string length $header]) / 2}]
2576 set pad [string range "----------------------------------------" 1 $l]
2577 $ctext insert end "$pad $header $pad\n" filesep
2579 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2581 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2582 $line match f1l f1c f2l f2c rest]} {
2584 $ctext insert end "\t" hunksep
2585 $ctext insert end " $f1l " d0 " $f2l " d1
2586 $ctext insert end " $rest \n" hunksep
2588 $ctext insert end "$line\n" hunksep
2592 set x [string range $line 0 0]
2593 if {$x == "-" || $x == "+"} {
2594 set tag [expr {$x == "+"}]
2596 set line [string range $line 1 end]
2598 $ctext insert end "$line\n" d$tag
2599 } elseif {$x == " "} {
2601 set line [string range $line 1 end]
2603 $ctext insert end "$line\n"
2604 } elseif {$diffinhdr || $x == "\\"} {
2605 # e.g. "\ No newline at end of file"
2606 $ctext insert end "$line\n" filesep
2608 # Something else we don't recognize
2609 if {$curdifftag != "Comments"} {
2610 $ctext insert end "\n"
2611 $ctext tag add $curdifftag $curtagstart end
2612 set curtagstart [$ctext index "end - 1c"]
2613 set curdifftag Comments
2615 $ctext insert end "$line\n" filesep
2618 $ctext conf -state disabled
2619 if {[clock clicks -milliseconds] >= $nextupdate} {
2621 fileevent $bdf readable {}
2623 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2628 global difffilestart ctext
2629 set here [$ctext index @0,0]
2630 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2631 if {[$ctext compare $difffilestart($i) > $here]} {
2632 if {![info exists pos]
2633 || [$ctext compare $difffilestart($i) < $pos]} {
2634 set pos $difffilestart($i)
2638 if {[info exists pos]} {
2643 proc listboxsel {} {
2644 global ctext cflist currentid
2645 if {![info exists currentid]} return
2646 set sel [lsort [$cflist curselection]]
2647 if {$sel eq {}} return
2648 set first [lindex $sel 0]
2649 catch {$ctext yview fmark.$first}
2653 global linespc charspc canvx0 canvy0 mainfont
2656 set linespc [font metrics $mainfont -linespace]
2657 set charspc [font measure $mainfont "m"]
2658 set canvy0 [expr 3 + 0.5 * $linespc]
2659 set canvx0 [expr 3 + 0.5 * $linespc]
2660 set xspc1(0) $linespc
2665 global stopped redisplaying phase
2666 if {$stopped > 1} return
2667 if {$phase == "getcommits"} return
2669 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2676 proc incrfont {inc} {
2677 global mainfont namefont textfont ctext canv phase
2678 global stopped entries
2680 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2681 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2682 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2684 $ctext conf -font $textfont
2685 $ctext tag conf filesep -font [concat $textfont bold]
2686 foreach e $entries {
2687 $e conf -font $mainfont
2689 if {$phase == "getcommits"} {
2690 $canv itemconf textitems -font $mainfont
2696 global sha1entry sha1string
2697 if {[string length $sha1string] == 40} {
2698 $sha1entry delete 0 end
2702 proc sha1change {n1 n2 op} {
2703 global sha1string currentid sha1but
2704 if {$sha1string == {}
2705 || ([info exists currentid] && $sha1string == $currentid)} {
2710 if {[$sha1but cget -state] == $state} return
2711 if {$state == "normal"} {
2712 $sha1but conf -state normal -relief raised -text "Goto: "
2714 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2718 proc gotocommit {} {
2719 global sha1string currentid idline tagids
2720 global lineid numcommits
2722 if {$sha1string == {}
2723 || ([info exists currentid] && $sha1string == $currentid)} return
2724 if {[info exists tagids($sha1string)]} {
2725 set id $tagids($sha1string)
2727 set id [string tolower $sha1string]
2728 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2730 for {set l 0} {$l < $numcommits} {incr l} {
2731 if {[string match $id* $lineid($l)]} {
2732 lappend matches $lineid($l)
2735 if {$matches ne {}} {
2736 if {[llength $matches] > 1} {
2737 error_popup "Short SHA1 id $id is ambiguous"
2740 set id [lindex $matches 0]
2744 if {[info exists idline($id)]} {
2745 selectline $idline($id) 1
2748 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2753 error_popup "$type $sha1string is not known"
2756 proc lineenter {x y id} {
2757 global hoverx hovery hoverid hovertimer
2758 global commitinfo canv
2760 if {![info exists commitinfo($id)]} return
2764 if {[info exists hovertimer]} {
2765 after cancel $hovertimer
2767 set hovertimer [after 500 linehover]
2771 proc linemotion {x y id} {
2772 global hoverx hovery hoverid hovertimer
2774 if {[info exists hoverid] && $id == $hoverid} {
2777 if {[info exists hovertimer]} {
2778 after cancel $hovertimer
2780 set hovertimer [after 500 linehover]
2784 proc lineleave {id} {
2785 global hoverid hovertimer canv
2787 if {[info exists hoverid] && $id == $hoverid} {
2789 if {[info exists hovertimer]} {
2790 after cancel $hovertimer
2798 global hoverx hovery hoverid hovertimer
2799 global canv linespc lthickness
2800 global commitinfo mainfont
2802 set text [lindex $commitinfo($hoverid) 0]
2803 set ymax [lindex [$canv cget -scrollregion] 3]
2804 if {$ymax == {}} return
2805 set yfrac [lindex [$canv yview] 0]
2806 set x [expr {$hoverx + 2 * $linespc}]
2807 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2808 set x0 [expr {$x - 2 * $lthickness}]
2809 set y0 [expr {$y - 2 * $lthickness}]
2810 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2811 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2812 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2813 -fill \#ffff80 -outline black -width 1 -tags hover]
2815 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2819 proc lineclick {x y id isnew} {
2820 global ctext commitinfo children cflist canv
2825 addtohistory [list lineclick $x $x $id 0]
2828 # fill the details pane with info about this line
2829 $ctext conf -state normal
2830 $ctext delete 0.0 end
2831 $ctext tag conf link -foreground blue -underline 1
2832 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2833 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2834 $ctext insert end "Parent:\t"
2835 $ctext insert end $id [list link link0]
2836 $ctext tag bind link0 <1> [list selbyid $id]
2837 set info $commitinfo($id)
2838 $ctext insert end "\n\t[lindex $info 0]\n"
2839 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2840 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2841 if {[info exists children($id)]} {
2842 $ctext insert end "\nChildren:"
2844 foreach child $children($id) {
2846 set info $commitinfo($child)
2847 $ctext insert end "\n\t"
2848 $ctext insert end $child [list link link$i]
2849 $ctext tag bind link$i <1> [list selbyid $child]
2850 $ctext insert end "\n\t[lindex $info 0]"
2851 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
2852 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
2855 $ctext conf -state disabled
2857 $cflist delete 0 end
2862 if {[info exists idline($id)]} {
2863 selectline $idline($id) 1
2869 if {![info exists startmstime]} {
2870 set startmstime [clock clicks -milliseconds]
2872 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2875 proc rowmenu {x y id} {
2876 global rowctxmenu idline selectedline rowmenuid
2878 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2883 $rowctxmenu entryconfigure 0 -state $state
2884 $rowctxmenu entryconfigure 1 -state $state
2885 $rowctxmenu entryconfigure 2 -state $state
2887 tk_popup $rowctxmenu $x $y
2890 proc diffvssel {dirn} {
2891 global rowmenuid selectedline lineid
2893 if {![info exists selectedline]} return
2895 set oldid $lineid($selectedline)
2896 set newid $rowmenuid
2898 set oldid $rowmenuid
2899 set newid $lineid($selectedline)
2901 addtohistory [list doseldiff $oldid $newid]
2902 doseldiff $oldid $newid
2905 proc doseldiff {oldid newid} {
2909 $ctext conf -state normal
2910 $ctext delete 0.0 end
2911 $ctext mark set fmark.0 0.0
2912 $ctext mark gravity fmark.0 left
2913 $cflist delete 0 end
2914 $cflist insert end "Top"
2915 $ctext insert end "From "
2916 $ctext tag conf link -foreground blue -underline 1
2917 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2918 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2919 $ctext tag bind link0 <1> [list selbyid $oldid]
2920 $ctext insert end $oldid [list link link0]
2921 $ctext insert end "\n "
2922 $ctext insert end [lindex $commitinfo($oldid) 0]
2923 $ctext insert end "\n\nTo "
2924 $ctext tag bind link1 <1> [list selbyid $newid]
2925 $ctext insert end $newid [list link link1]
2926 $ctext insert end "\n "
2927 $ctext insert end [lindex $commitinfo($newid) 0]
2928 $ctext insert end "\n"
2929 $ctext conf -state disabled
2930 $ctext tag delete Comments
2931 $ctext tag remove found 1.0 end
2932 startdiff [list $newid $oldid]
2936 global rowmenuid currentid commitinfo patchtop patchnum
2938 if {![info exists currentid]} return
2939 set oldid $currentid
2940 set oldhead [lindex $commitinfo($oldid) 0]
2941 set newid $rowmenuid
2942 set newhead [lindex $commitinfo($newid) 0]
2945 catch {destroy $top}
2947 label $top.title -text "Generate patch"
2948 grid $top.title - -pady 10
2949 label $top.from -text "From:"
2950 entry $top.fromsha1 -width 40 -relief flat
2951 $top.fromsha1 insert 0 $oldid
2952 $top.fromsha1 conf -state readonly
2953 grid $top.from $top.fromsha1 -sticky w
2954 entry $top.fromhead -width 60 -relief flat
2955 $top.fromhead insert 0 $oldhead
2956 $top.fromhead conf -state readonly
2957 grid x $top.fromhead -sticky w
2958 label $top.to -text "To:"
2959 entry $top.tosha1 -width 40 -relief flat
2960 $top.tosha1 insert 0 $newid
2961 $top.tosha1 conf -state readonly
2962 grid $top.to $top.tosha1 -sticky w
2963 entry $top.tohead -width 60 -relief flat
2964 $top.tohead insert 0 $newhead
2965 $top.tohead conf -state readonly
2966 grid x $top.tohead -sticky w
2967 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2968 grid $top.rev x -pady 10
2969 label $top.flab -text "Output file:"
2970 entry $top.fname -width 60
2971 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2973 grid $top.flab $top.fname -sticky w
2975 button $top.buts.gen -text "Generate" -command mkpatchgo
2976 button $top.buts.can -text "Cancel" -command mkpatchcan
2977 grid $top.buts.gen $top.buts.can
2978 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2979 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2980 grid $top.buts - -pady 10 -sticky ew
2984 proc mkpatchrev {} {
2987 set oldid [$patchtop.fromsha1 get]
2988 set oldhead [$patchtop.fromhead get]
2989 set newid [$patchtop.tosha1 get]
2990 set newhead [$patchtop.tohead get]
2991 foreach e [list fromsha1 fromhead tosha1 tohead] \
2992 v [list $newid $newhead $oldid $oldhead] {
2993 $patchtop.$e conf -state normal
2994 $patchtop.$e delete 0 end
2995 $patchtop.$e insert 0 $v
2996 $patchtop.$e conf -state readonly
3003 set oldid [$patchtop.fromsha1 get]
3004 set newid [$patchtop.tosha1 get]
3005 set fname [$patchtop.fname get]
3006 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3007 error_popup "Error creating patch: $err"
3009 catch {destroy $patchtop}
3013 proc mkpatchcan {} {
3016 catch {destroy $patchtop}
3021 global rowmenuid mktagtop commitinfo
3025 catch {destroy $top}
3027 label $top.title -text "Create tag"
3028 grid $top.title - -pady 10
3029 label $top.id -text "ID:"
3030 entry $top.sha1 -width 40 -relief flat
3031 $top.sha1 insert 0 $rowmenuid
3032 $top.sha1 conf -state readonly
3033 grid $top.id $top.sha1 -sticky w
3034 entry $top.head -width 60 -relief flat
3035 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3036 $top.head conf -state readonly
3037 grid x $top.head -sticky w
3038 label $top.tlab -text "Tag name:"
3039 entry $top.tag -width 60
3040 grid $top.tlab $top.tag -sticky w
3042 button $top.buts.gen -text "Create" -command mktaggo
3043 button $top.buts.can -text "Cancel" -command mktagcan
3044 grid $top.buts.gen $top.buts.can
3045 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3046 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3047 grid $top.buts - -pady 10 -sticky ew
3052 global mktagtop env tagids idtags
3053 global idpos idline linehtag canv selectedline
3055 set id [$mktagtop.sha1 get]
3056 set tag [$mktagtop.tag get]
3058 error_popup "No tag name specified"
3061 if {[info exists tagids($tag)]} {
3062 error_popup "Tag \"$tag\" already exists"
3067 set fname [file join $dir "refs/tags" $tag]
3068 set f [open $fname w]
3072 error_popup "Error creating tag: $err"
3076 set tagids($tag) $id
3077 lappend idtags($id) $tag
3078 $canv delete tag.$id
3079 set xt [eval drawtags $id $idpos($id)]
3080 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3081 if {[info exists selectedline] && $selectedline == $idline($id)} {
3082 selectline $selectedline 0
3089 catch {destroy $mktagtop}
3098 proc writecommit {} {
3099 global rowmenuid wrcomtop commitinfo wrcomcmd
3101 set top .writecommit
3103 catch {destroy $top}
3105 label $top.title -text "Write commit to file"
3106 grid $top.title - -pady 10
3107 label $top.id -text "ID:"
3108 entry $top.sha1 -width 40 -relief flat
3109 $top.sha1 insert 0 $rowmenuid
3110 $top.sha1 conf -state readonly
3111 grid $top.id $top.sha1 -sticky w
3112 entry $top.head -width 60 -relief flat
3113 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3114 $top.head conf -state readonly
3115 grid x $top.head -sticky w
3116 label $top.clab -text "Command:"
3117 entry $top.cmd -width 60 -textvariable wrcomcmd
3118 grid $top.clab $top.cmd -sticky w -pady 10
3119 label $top.flab -text "Output file:"
3120 entry $top.fname -width 60
3121 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3122 grid $top.flab $top.fname -sticky w
3124 button $top.buts.gen -text "Write" -command wrcomgo
3125 button $top.buts.can -text "Cancel" -command wrcomcan
3126 grid $top.buts.gen $top.buts.can
3127 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3128 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3129 grid $top.buts - -pady 10 -sticky ew
3136 set id [$wrcomtop.sha1 get]
3137 set cmd "echo $id | [$wrcomtop.cmd get]"
3138 set fname [$wrcomtop.fname get]
3139 if {[catch {exec sh -c $cmd >$fname &} err]} {
3140 error_popup "Error writing commit: $err"
3142 catch {destroy $wrcomtop}
3149 catch {destroy $wrcomtop}
3162 set diffopts "-U 5 -p"
3163 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3165 set mainfont {Helvetica 9}
3166 set textfont {Courier 9}
3167 set findmergefiles 0
3171 set colors {green red blue magenta darkgrey brown orange}
3173 catch {source ~/.gitk}
3175 set namefont $mainfont
3177 lappend namefont bold
3182 switch -regexp -- $arg {
3184 "^-b" { set boldnames 1 }
3185 "^-d" { set datemode 1 }
3187 lappend revtreeargs $arg
3202 getcommits $revtreeargs