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 --parents $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
63 global commitlisted phase commitinfo nextupdate
64 global stopped redisplaying leftover
66 set stuff
[read $commfd]
68 if {![eof
$commfd]} return
69 # set it blocking so we wait for the process to terminate
70 fconfigure
$commfd -blocking 1
71 if {![catch
{close
$commfd} err
]} {
72 after idle finishcommits
75 if {[string range
$err 0 4] == "usage"} {
77 {Gitk
: error reading commits
: bad arguments to git-rev-list.
78 (Note
: arguments to gitk are passed to git-rev-list
79 to allow selection of commits to be displayed.
)}
81 set err
"Error reading commits: $err"
88 set i
[string first
"\0" $stuff $start]
90 append leftover
[string range
$stuff $start end
]
93 set cmit
[string range
$stuff $start [expr {$i - 1}]]
95 set cmit
"$leftover$cmit"
98 set start
[expr {$i + 1}]
99 set j
[string first
"\n" $cmit]
102 set ids
[string range
$cmit 0 [expr {$j - 1}]]
105 if {![regexp
{^
[0-9a-f]{40}$
} $id]} {
113 if {[string length
$shortcmit] > 80} {
114 set shortcmit
"[string range $shortcmit 0 80]..."
116 error_popup
"Can't parse git-rev-list output: {$shortcmit}"
119 set id
[lindex
$ids 0]
120 set olds
[lrange
$ids 1 end
]
121 set cmit
[string range
$cmit [expr {$j + 1}] end
]
123 set commitlisted
($id) 1
124 parsecommit
$id $cmit 1 [lrange
$ids 1 end
]
126 if {[clock clicks
-milliseconds] >= $nextupdate} {
129 while {$redisplaying} {
133 set phase
"getcommits"
134 foreach id
$commits {
137 if {[clock clicks
-milliseconds] >= $nextupdate} {
146 proc doupdate
{reading
} {
147 global commfd nextupdate numcommits ncmupdate
150 fileevent
$commfd readable
{}
153 set nextupdate
[expr {[clock clicks
-milliseconds] + 100}]
154 if {$numcommits < 100} {
155 set ncmupdate
[expr {$numcommits + 1}]
156 } elseif
{$numcommits < 10000} {
157 set ncmupdate
[expr {$numcommits + 10}]
159 set ncmupdate
[expr {$numcommits + 100}]
162 fileevent
$commfd readable
[list getcommitlines
$commfd]
166 proc readcommit
{id
} {
167 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
168 parsecommit
$id $contents 0 {}
171 proc parsecommit
{id contents listed olds
} {
172 global commitinfo children nchildren parents nparents cdate ncleft
181 if {![info exists nchildren
($id)]} {
186 set parents
($id) $olds
187 set nparents
($id) [llength
$olds]
189 if {![info exists nchildren
($p)]} {
190 set children
($p) [list
$id]
193 } elseif
{[lsearch
-exact $children($p) $id] < 0} {
194 lappend children
($p) $id
199 foreach line
[split $contents "\n"] {
204 set tag
[lindex
$line 0]
205 if {$tag == "author"} {
206 set x
[expr {[llength
$line] - 2}]
207 set audate
[lindex
$line $x]
208 set auname
[lrange
$line 1 [expr {$x - 1}]]
209 } elseif
{$tag == "committer"} {
210 set x
[expr {[llength
$line] - 2}]
211 set comdate
[lindex
$line $x]
212 set comname
[lrange
$line 1 [expr {$x - 1}]]
216 if {$comment == {}} {
217 set headline
[string trim
$line]
222 # git-rev-list indents the comment by 4 spaces;
223 # if we got this via git-cat-file, add the indentation
230 set audate
[clock format
$audate -format "%Y-%m-%d %H:%M:%S"]
232 if {$comdate != {}} {
233 set cdate
($id) $comdate
234 set comdate
[clock format
$comdate -format "%Y-%m-%d %H:%M:%S"]
236 set commitinfo
($id) [list
$headline $auname $audate \
237 $comname $comdate $comment]
241 global tagids idtags headids idheads
242 set tags
[glob
-nocomplain -types f
[gitdir
]/refs
/tags
/*]
247 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
248 set direct
[file tail $f]
249 set tagids
($direct) $id
250 lappend idtags
($id) $direct
251 set contents
[split [exec git-cat-file tag
$id] "\n"]
255 foreach l
$contents {
257 switch
-- [lindex
$l 0] {
258 "object" {set obj
[lindex
$l 1]}
259 "type" {set type [lindex
$l 1]}
260 "tag" {set tag
[string range
$l 4 end
]}
263 if {$obj != {} && $type == "commit" && $tag != {}} {
264 set tagids
($tag) $obj
265 lappend idtags
($obj) $tag
271 set heads
[glob
-nocomplain -types f
[gitdir
]/refs
/heads
/*]
275 set line
[read $fd 40]
276 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
277 set head [file tail $f]
278 set headids
($head) $line
279 lappend idheads
($line) $head
284 readotherrefs refs
{} {tags heads
}
287 proc readotherrefs
{base dname excl
} {
288 global otherrefids idotherrefs
291 set files
[glob
-nocomplain -types f
[file join $git $base *]]
295 set line
[read $fd 40]
296 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
297 set name
"$dname[file tail $f]"
298 set otherrefids
($name) $id
299 lappend idotherrefs
($id) $name
304 set dirs [glob
-nocomplain -types d
[file join $git $base *]]
306 set dir
[file tail $d]
307 if {[lsearch
-exact $excl $dir] >= 0} continue
308 readotherrefs
[file join $base $dir] "$dname$dir/" {}
312 proc error_popup msg
{
316 message
$w.m
-text $msg -justify center
-aspect 400
317 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
318 button
$w.ok
-text OK
-command "destroy $w"
319 pack
$w.ok
-side bottom
-fill x
320 bind $w <Visibility
> "grab $w; focus $w"
325 global canv canv2 canv3 linespc charspc ctext cflist textfont
326 global findtype findtypemenu findloc findstring fstring geometry
327 global entries sha1entry sha1string sha1but
328 global maincursor textcursor curtextcursor
329 global rowctxmenu gaudydiff mergemax
332 .bar add cascade
-label "File" -menu .bar.
file
334 .bar.
file add
command -label "Reread references" -command rereadrefs
335 .bar.
file add
command -label "Quit" -command doquit
337 .bar add cascade
-label "Help" -menu .bar.
help
338 .bar.
help add
command -label "About gitk" -command about
339 . configure
-menu .bar
341 if {![info exists geometry
(canv1
)]} {
342 set geometry
(canv1
) [expr 45 * $charspc]
343 set geometry
(canv2
) [expr 30 * $charspc]
344 set geometry
(canv3
) [expr 15 * $charspc]
345 set geometry
(canvh
) [expr 25 * $linespc + 4]
346 set geometry
(ctextw
) 80
347 set geometry
(ctexth
) 30
348 set geometry
(cflistw
) 30
350 panedwindow .ctop
-orient vertical
351 if {[info exists geometry
(width
)]} {
352 .ctop conf
-width $geometry(width
) -height $geometry(height
)
353 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
354 set geometry
(ctexth
) [expr {($texth - 8) /
355 [font metrics
$textfont -linespace]}]
359 pack .ctop.top.bar
-side bottom
-fill x
360 set cscroll .ctop.top.csb
361 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
362 pack
$cscroll -side right
-fill y
363 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
364 pack .ctop.top.clist
-side top
-fill both
-expand 1
366 set canv .ctop.top.clist.canv
367 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
369 -yscrollincr $linespc -yscrollcommand "$cscroll set"
370 .ctop.top.clist add
$canv
371 set canv2 .ctop.top.clist.canv2
372 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
373 -bg white
-bd 0 -yscrollincr $linespc
374 .ctop.top.clist add
$canv2
375 set canv3 .ctop.top.clist.canv3
376 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
377 -bg white
-bd 0 -yscrollincr $linespc
378 .ctop.top.clist add
$canv3
379 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
381 set sha1entry .ctop.top.bar.sha1
382 set entries
$sha1entry
383 set sha1but .ctop.top.bar.sha1label
384 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
385 -command gotocommit
-width 8
386 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
387 pack .ctop.top.bar.sha1label
-side left
388 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
389 trace add variable sha1string
write sha1change
390 pack
$sha1entry -side left
-pady 2
392 image create bitmap bm-left
-data {
393 #define left_width 16
394 #define left_height 16
395 static unsigned char left_bits
[] = {
396 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
397 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
398 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
400 image create bitmap bm-right
-data {
401 #define right_width 16
402 #define right_height 16
403 static unsigned char right_bits
[] = {
404 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
405 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
406 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
408 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
409 -state disabled
-width 26
410 pack .ctop.top.bar.leftbut
-side left
-fill y
411 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
412 -state disabled
-width 26
413 pack .ctop.top.bar.rightbut
-side left
-fill y
415 button .ctop.top.bar.findbut
-text "Find" -command dofind
416 pack .ctop.top.bar.findbut
-side left
418 set fstring .ctop.top.bar.findstring
419 lappend entries
$fstring
420 entry
$fstring -width 30 -font $textfont -textvariable findstring
421 pack
$fstring -side left
-expand 1 -fill x
423 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
424 findtype Exact IgnCase Regexp
]
425 set findloc
"All fields"
426 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
427 Comments Author Committer Files Pickaxe
428 pack .ctop.top.bar.findloc
-side right
429 pack .ctop.top.bar.findtype
-side right
430 # for making sure type==Exact whenever loc==Pickaxe
431 trace add variable findloc
write findlocchange
433 panedwindow .ctop.cdet
-orient horizontal
435 frame .ctop.cdet.left
436 set ctext .ctop.cdet.left.ctext
437 text
$ctext -bg white
-state disabled
-font $textfont \
438 -width $geometry(ctextw
) -height $geometry(ctexth
) \
439 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
440 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
441 pack .ctop.cdet.left.sb
-side right
-fill y
442 pack
$ctext -side left
-fill both
-expand 1
443 .ctop.cdet add .ctop.cdet.left
445 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
447 $ctext tag conf hunksep
-back blue
-fore white
448 $ctext tag conf d0
-back "#ff8080"
449 $ctext tag conf d1
-back green
451 $ctext tag conf hunksep
-fore blue
452 $ctext tag conf d0
-fore red
453 $ctext tag conf d1
-fore "#00a000"
454 $ctext tag conf m0
-fore red
455 $ctext tag conf m1
-fore blue
456 $ctext tag conf m2
-fore green
457 $ctext tag conf m3
-fore purple
458 $ctext tag conf
m4 -fore brown
459 $ctext tag conf mmax
-fore darkgrey
461 $ctext tag conf mresult
-font [concat
$textfont bold
]
462 $ctext tag conf msep
-font [concat
$textfont bold
]
463 $ctext tag conf found
-back yellow
466 frame .ctop.cdet.right
467 set cflist .ctop.cdet.right.cfiles
468 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
469 -yscrollcommand ".ctop.cdet.right.sb set"
470 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
471 pack .ctop.cdet.right.sb
-side right
-fill y
472 pack
$cflist -side left
-fill both
-expand 1
473 .ctop.cdet add .ctop.cdet.right
474 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
476 pack .ctop
-side top
-fill both
-expand 1
478 bindall
<1> {selcanvline
%W
%x
%y
}
479 #bindall <B1-Motion> {selcanvline %W %x %y}
480 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
481 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
482 bindall
<2> "allcanvs scan mark 0 %y"
483 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
484 bind .
<Key-Up
> "selnextline -1"
485 bind .
<Key-Down
> "selnextline 1"
486 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
487 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
488 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
489 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
490 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
491 bindkey p
"selnextline -1"
492 bindkey n
"selnextline 1"
493 bindkey b
"$ctext yview scroll -1 pages"
494 bindkey d
"$ctext yview scroll 18 units"
495 bindkey u
"$ctext yview scroll -18 units"
496 bindkey
/ {findnext
1}
497 bindkey
<Key-Return
> {findnext
0}
500 bind .
<Control-q
> doquit
501 bind .
<Control-f
> dofind
502 bind .
<Control-g
> {findnext
0}
503 bind .
<Control-r
> findprev
504 bind .
<Control-equal
> {incrfont
1}
505 bind .
<Control-KP_Add
> {incrfont
1}
506 bind .
<Control-minus
> {incrfont
-1}
507 bind .
<Control-KP_Subtract
> {incrfont
-1}
508 bind $cflist <<ListboxSelect>> listboxsel
509 bind . <Destroy> {savestuff %W}
510 bind . <Button-1> "click %W"
511 bind $fstring <Key-Return> dofind
512 bind $sha1entry <Key-Return> gotocommit
513 bind $sha1entry <<PasteSelection>> clearsha1
515 set maincursor [. cget -cursor]
516 set textcursor [$ctext cget -cursor]
517 set curtextcursor $textcursor
519 set rowctxmenu .rowctxmenu
520 menu $rowctxmenu -tearoff 0
521 $rowctxmenu add command -label "Diff this -> selected" \
522 -command {diffvssel 0}
523 $rowctxmenu add command -label "Diff selected -> this" \
524 -command {diffvssel 1}
525 $rowctxmenu add command -label "Make patch" -command mkpatch
526 $rowctxmenu add command -label "Create tag" -command mktag
527 $rowctxmenu add command -label "Write commit to file" -command writecommit
530 # when we make a key binding for the toplevel, make sure
531 # it doesn't get triggered when that key is pressed in the
532 # find string entry widget.
533 proc bindkey {ev script} {
536 set escript [bind Entry $ev]
537 if {$escript == {}} {
538 set escript [bind Entry <Key>]
541 bind $e $ev "$escript; break"
545 # set the focus back to the toplevel for any click outside
556 global canv canv2 canv3 ctext cflist mainfont textfont
557 global stuffsaved findmergefiles gaudydiff maxgraphpct
560 if {$stuffsaved} return
561 if {![winfo viewable .]} return
563 set f [open "~/.gitk-new" w]
564 puts $f [list set mainfont $mainfont]
565 puts $f [list set textfont $textfont]
566 puts $f [list set findmergefiles $findmergefiles]
567 puts $f [list set gaudydiff $gaudydiff]
568 puts $f [list set maxgraphpct $maxgraphpct]
569 puts $f [list set maxwidth $maxwidth]
570 puts $f "set geometry(width) [winfo width .ctop]"
571 puts $f "set geometry(height) [winfo height .ctop]"
572 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
573 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
574 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
575 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
576 set wid [expr {([winfo width $ctext] - 8) \
577 / [font measure $textfont "0"]}]
578 puts $f "set geometry(ctextw) $wid"
579 set wid [expr {([winfo width $cflist] - 11) \
580 / [font measure [$cflist cget -font] "0"]}]
581 puts $f "set geometry(cflistw) $wid"
583 file rename -force "~/.gitk-new" "~/.gitk"
588 proc resizeclistpanes {win w} {
590 if [info exists oldwidth($win)] {
591 set s0 [$win sash coord 0]
592 set s1 [$win sash coord 1]
594 set sash0 [expr {int($w/2 - 2)}]
595 set sash1 [expr {int($w*5/6 - 2)}]
597 set factor [expr {1.0 * $w / $oldwidth($win)}]
598 set sash0 [expr {int($factor * [lindex $s0 0])}]
599 set sash1 [expr {int($factor * [lindex $s1 0])}]
603 if {$sash1 < $sash0 + 20} {
604 set sash1 [expr $sash0 + 20]
606 if {$sash1 > $w - 10} {
607 set sash1 [expr $w - 10]
608 if {$sash0 > $sash1 - 20} {
609 set sash0 [expr $sash1 - 20]
613 $win sash place 0 $sash0 [lindex $s0 1]
614 $win sash place 1 $sash1 [lindex $s1 1]
616 set oldwidth($win) $w
619 proc resizecdetpanes {win w} {
621 if [info exists oldwidth($win)] {
622 set s0 [$win sash coord 0]
624 set sash0 [expr {int($w*3/4 - 2)}]
626 set factor [expr {1.0 * $w / $oldwidth($win)}]
627 set sash0 [expr {int($factor * [lindex $s0 0])}]
631 if {$sash0 > $w - 15} {
632 set sash0 [expr $w - 15]
635 $win sash place 0 $sash0 [lindex $s0 1]
637 set oldwidth($win) $w
641 global canv canv2 canv3
647 proc bindall {event action} {
648 global canv canv2 canv3
649 bind $canv $event $action
650 bind $canv2 $event $action
651 bind $canv3 $event $action
656 if {[winfo exists $w]} {
661 wm title $w "About gitk"
665 Copyright © 2005 Paul Mackerras
667 Use and redistribute under the terms of the GNU General Public License} \
668 -justify center -aspect 400
669 pack $w.m -side top -fill x -padx 20 -pady 20
670 button $w.ok -text Close -command "destroy $w"
671 pack $w.ok -side bottom
674 proc assigncolor {id} {
675 global commitinfo colormap commcolors colors nextcolor
676 global parents nparents children nchildren
677 global cornercrossings crossings
679 if [info exists colormap($id)] return
680 set ncolors [llength $colors]
681 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
682 set child [lindex $children($id) 0]
683 if {[info exists colormap($child)]
684 && $nparents($child) == 1} {
685 set colormap($id) $colormap($child)
690 if {[info exists cornercrossings($id)]} {
691 foreach x $cornercrossings($id) {
692 if {[info exists colormap($x)]
693 && [lsearch -exact $badcolors $colormap($x)] < 0} {
694 lappend badcolors $colormap($x)
697 if {[llength $badcolors] >= $ncolors} {
701 set origbad $badcolors
702 if {[llength $badcolors] < $ncolors - 1} {
703 if {[info exists crossings($id)]} {
704 foreach x $crossings($id) {
705 if {[info exists colormap($x)]
706 && [lsearch -exact $badcolors $colormap($x)] < 0} {
707 lappend badcolors $colormap($x)
710 if {[llength $badcolors] >= $ncolors} {
711 set badcolors $origbad
714 set origbad $badcolors
716 if {[llength $badcolors] < $ncolors - 1} {
717 foreach child $children($id) {
718 if {[info exists colormap($child)]
719 && [lsearch -exact $badcolors $colormap($child)] < 0} {
720 lappend badcolors $colormap($child)
722 if {[info exists parents($child)]} {
723 foreach p $parents($child) {
724 if {[info exists colormap($p)]
725 && [lsearch -exact $badcolors $colormap($p)] < 0} {
726 lappend badcolors $colormap($p)
731 if {[llength $badcolors] >= $ncolors} {
732 set badcolors $origbad
735 for {set i 0} {$i <= $ncolors} {incr i} {
736 set c [lindex $colors $nextcolor]
737 if {[incr nextcolor] >= $ncolors} {
740 if {[lsearch -exact $badcolors $c]} break
746 global canvy canvy0 lineno numcommits nextcolor linespc
747 global mainline mainlinearrow sidelines
748 global nchildren ncleft
749 global displist nhyperspace
756 catch {unset mainline}
757 catch {unset mainlinearrow}
758 catch {unset sidelines}
759 foreach id [array names nchildren] {
760 set ncleft($id) $nchildren($id)
766 proc bindline {t id} {
769 $canv bind $t <Enter> "lineenter %x %y $id"
770 $canv bind $t <Motion> "linemotion %x %y $id"
771 $canv bind $t <Leave> "lineleave $id"
772 $canv bind $t <Button-1> "lineclick %x %y $id 1"
775 # level here is an index in displist
776 proc drawcommitline {level} {
777 global parents children nparents displist
778 global canv canv2 canv3 mainfont namefont canvy linespc
779 global lineid linehtag linentag linedtag commitinfo
780 global colormap numcommits currentparents dupparents
781 global idtags idline idheads idotherrefs
782 global lineno lthickness mainline mainlinearrow sidelines
783 global commitlisted rowtextx idpos lastuse displist
784 global oldnlines olddlevel olddisplist
788 set id [lindex $displist $level]
789 set lastuse($id) $lineno
790 set lineid($lineno) $id
791 set idline($id) $lineno
792 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
793 if {![info exists commitinfo($id)]} {
795 if {![info exists commitinfo($id)]} {
796 set commitinfo($id) {"No commit information available"}
801 set currentparents {}
803 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
804 foreach p $parents($id) {
805 if {[lsearch -exact $currentparents $p] < 0} {
806 lappend currentparents $p
808 # remember that this parent was listed twice
809 lappend dupparents $p
813 set x [xcoord $level $level $lineno]
815 set canvy [expr $canvy + $linespc]
816 allcanvs conf -scrollregion \
817 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
818 if {[info exists mainline($id)]} {
819 lappend mainline($id) $x $y1
820 if {$mainlinearrow($id) ne "none"} {
821 set mainline($id) [trimdiagstart $mainline($id)]
823 set t [$canv create line $mainline($id) \
824 -width $lthickness -fill $colormap($id) \
825 -arrow $mainlinearrow($id)]
829 if {[info exists sidelines($id)]} {
830 foreach ls $sidelines($id) {
831 set coords [lindex $ls 0]
832 set thick [lindex $ls 1]
833 set arrow [lindex $ls 2]
834 set t [$canv create line $coords -fill $colormap($id) \
835 -width [expr {$thick * $lthickness}] -arrow $arrow]
840 set orad [expr {$linespc / 3}]
841 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
842 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
843 -fill $ofill -outline black -width 1]
845 $canv bind $t <1> {selcanvline {} %x %y}
846 set xt [xcoord [llength $displist] $level $lineno]
847 if {[llength $currentparents] > 2} {
848 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
850 set rowtextx($lineno) $xt
851 set idpos($id) [list $x $xt $y1]
852 if {[info exists idtags($id)] || [info exists idheads($id)]
853 || [info exists idotherrefs($id)]} {
854 set xt [drawtags $id $x $xt $y1]
856 set headline [lindex $commitinfo($id) 0]
857 set name [lindex $commitinfo($id) 1]
858 set date [lindex $commitinfo($id) 2]
859 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
860 -text $headline -font $mainfont ]
861 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
862 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
863 -text $name -font $namefont]
864 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
865 -text $date -font $mainfont]
868 set olddisplist $displist
869 set oldnlines [llength $displist]
872 proc drawtags {id x xt y1} {
873 global idtags idheads idotherrefs
874 global linespc lthickness
880 if {[info exists idtags($id)]} {
881 set marks $idtags($id)
882 set ntags [llength $marks]
884 if {[info exists idheads($id)]} {
885 set marks [concat $marks $idheads($id)]
886 set nheads [llength $idheads($id)]
888 if {[info exists idotherrefs($id)]} {
889 set marks [concat $marks $idotherrefs($id)]
895 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
896 set yt [expr $y1 - 0.5 * $linespc]
897 set yb [expr $yt + $linespc - 1]
901 set wid [font measure $mainfont $tag]
904 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
906 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
907 -width $lthickness -fill black -tags tag.$id]
909 foreach tag $marks x $xvals wid $wvals {
910 set xl [expr $x + $delta]
911 set xr [expr $x + $delta + $wid + $lthickness]
912 if {[incr ntags -1] >= 0} {
914 $canv create polygon $x [expr $yt + $delta] $xl $yt\
915 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
916 -width 1 -outline black -fill yellow -tags tag.$id
918 # draw a head or other ref
919 if {[incr nheads -1] >= 0} {
924 set xl [expr $xl - $delta/2]
925 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
926 -width 1 -outline black -fill $col -tags tag.$id
928 $canv create text $xl $y1 -anchor w -text $tag \
929 -font $mainfont -tags tag.$id
934 proc notecrossings {id lo hi corner} {
935 global olddisplist crossings cornercrossings
937 for {set i $lo} {[incr i] < $hi} {} {
938 set p [lindex $olddisplist $i]
939 if {$p == {}} continue
941 if {![info exists cornercrossings($id)]
942 || [lsearch -exact $cornercrossings($id) $p] < 0} {
943 lappend cornercrossings($id) $p
945 if {![info exists cornercrossings($p)]
946 || [lsearch -exact $cornercrossings($p) $id] < 0} {
947 lappend cornercrossings($p) $id
950 if {![info exists crossings($id)]
951 || [lsearch -exact $crossings($id) $p] < 0} {
952 lappend crossings($id) $p
954 if {![info exists crossings($p)]
955 || [lsearch -exact $crossings($p) $id] < 0} {
956 lappend crossings($p) $id
962 proc xcoord {i level ln} {
963 global canvx0 xspc1 xspc2
965 set x [expr {$canvx0 + $i * $xspc1($ln)}]
966 if {$i > 0 && $i == $level} {
967 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
968 } elseif {$i > $level} {
969 set x [expr {$x + $xspc2 - $xspc1($ln)}]
974 # it seems Tk can't draw arrows on the end of diagonal line segments...
975 proc trimdiagend {line} {
976 while {[llength $line] > 4} {
977 set x1 [lindex $line end-3]
978 set y1 [lindex $line end-2]
979 set x2 [lindex $line end-1]
980 set y2 [lindex $line end]
981 if {($x1 == $x2) != ($y1 == $y2)} break
982 set line [lreplace $line end-1 end]
987 proc trimdiagstart {line} {
988 while {[llength $line] > 4} {
989 set x1 [lindex $line 0]
990 set y1 [lindex $line 1]
991 set x2 [lindex $line 2]
992 set y2 [lindex $line 3]
993 if {($x1 == $x2) != ($y1 == $y2)} break
994 set line [lreplace $line 0 1]
999 proc drawslants {id needonscreen nohs} {
1000 global canv mainline mainlinearrow sidelines
1001 global canvx0 canvy xspc1 xspc2 lthickness
1002 global currentparents dupparents
1003 global lthickness linespc canvy colormap lineno geometry
1004 global maxgraphpct maxwidth
1005 global displist onscreen lastuse
1006 global parents commitlisted
1007 global oldnlines olddlevel olddisplist
1008 global nhyperspace numcommits nnewparents
1011 lappend displist $id
1016 set y1 [expr {$canvy - $linespc}]
1019 # work out what we need to get back on screen
1021 if {$onscreen($id) < 0} {
1022 # next to do isn't displayed, better get it on screen...
1023 lappend reins [list $id 0]
1025 # make sure all the previous commits's parents are on the screen
1026 foreach p $currentparents {
1027 if {$onscreen($p) < 0} {
1028 lappend reins [list $p 0]
1031 # bring back anything requested by caller
1032 if {$needonscreen ne {}} {
1033 lappend reins $needonscreen
1037 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1038 set dlevel $olddlevel
1039 set x [xcoord $dlevel $dlevel $lineno]
1040 set mainline($id) [list $x $y1]
1041 set mainlinearrow($id) none
1042 set lastuse($id) $lineno
1043 set displist [lreplace $displist $dlevel $dlevel $id]
1045 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1050 set displist [lreplace $displist $olddlevel $olddlevel]
1052 foreach p $currentparents {
1053 set lastuse($p) $lineno
1054 if {$onscreen($p) == 0} {
1055 set displist [linsert $displist $j $p]
1060 if {$onscreen($id) == 0} {
1061 lappend displist $id
1065 # remove the null entry if present
1066 set nullentry [lsearch -exact $displist {}]
1067 if {$nullentry >= 0} {
1068 set displist [lreplace $displist $nullentry $nullentry]
1071 # bring back the ones we need now (if we did it earlier
1072 # it would change displist and invalidate olddlevel)
1074 # test again in case of duplicates in reins
1075 set p [lindex $pi 0]
1076 if {$onscreen($p) < 0} {
1078 set lastuse($p) $lineno
1079 set displist [linsert $displist [lindex $pi 1] $p]
1084 set lastuse($id) $lineno
1086 # see if we need to make any lines jump off into hyperspace
1087 set displ [llength $displist]
1088 if {$displ > $maxwidth} {
1090 foreach x $displist {
1091 lappend ages [list $lastuse($x) $x]
1093 set ages [lsort -integer -index 0 $ages]
1095 while {$displ > $maxwidth} {
1096 set use [lindex $ages $k 0]
1097 set victim [lindex $ages $k 1]
1098 if {$use >= $lineno - 5} break
1100 if {[lsearch -exact $nohs $victim] >= 0} continue
1101 set i [lsearch -exact $displist $victim]
1102 set displist [lreplace $displist $i $i]
1103 set onscreen($victim) -1
1106 if {$i < $nullentry} {
1109 set x [lindex $mainline($victim) end-1]
1110 lappend mainline($victim) $x $y1
1111 set line [trimdiagend $mainline($victim)]
1113 if {$mainlinearrow($victim) ne "none"} {
1114 set line [trimdiagstart $line]
1117 lappend sidelines($victim) [list $line 1 $arrow]
1118 unset mainline($victim)
1122 set dlevel [lsearch -exact $displist $id]
1124 # If we are reducing, put in a null entry
1125 if {$displ < $oldnlines} {
1126 # does the next line look like a merge?
1127 # i.e. does it have > 1 new parent?
1128 if {$nnewparents($id) > 1} {
1129 set i [expr {$dlevel + 1}]
1130 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1132 if {$nullentry >= 0 && $nullentry < $i} {
1135 } elseif {$nullentry >= 0} {
1138 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1143 if {$dlevel >= $i} {
1148 set displist [linsert $displist $i {}]
1150 if {$dlevel >= $i} {
1156 # decide on the line spacing for the next line
1157 set lj [expr {$lineno + 1}]
1158 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1159 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1160 set xspc1($lj) $xspc2
1162 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1163 if {$xspc1($lj) < $lthickness} {
1164 set xspc1($lj) $lthickness
1168 foreach idi $reins {
1169 set id [lindex $idi 0]
1170 set j [lsearch -exact $displist $id]
1171 set xj [xcoord $j $dlevel $lj]
1172 set mainline($id) [list $xj $y2]
1173 set mainlinearrow($id) first
1177 foreach id $olddisplist {
1179 if {$id == {}} continue
1180 if {$onscreen($id) <= 0} continue
1181 set xi [xcoord $i $olddlevel $lineno]
1182 if {$i == $olddlevel} {
1183 foreach p $currentparents {
1184 set j [lsearch -exact $displist $p]
1185 set coords [list $xi $y1]
1186 set xj [xcoord $j $dlevel $lj]
1187 if {$xj < $xi - $linespc} {
1188 lappend coords [expr {$xj + $linespc}] $y1
1189 notecrossings $p $j $i [expr {$j + 1}]
1190 } elseif {$xj > $xi + $linespc} {
1191 lappend coords [expr {$xj - $linespc}] $y1
1192 notecrossings $p $i $j [expr {$j - 1}]
1194 if {[lsearch -exact $dupparents $p] >= 0} {
1195 # draw a double-width line to indicate the doubled parent
1196 lappend coords $xj $y2
1197 lappend sidelines($p) [list $coords 2 none]
1198 if {![info exists mainline($p)]} {
1199 set mainline($p) [list $xj $y2]
1200 set mainlinearrow($p) none
1203 # normal case, no parent duplicated
1205 set dx [expr {abs($xi - $xj)}]
1206 if {0 && $dx < $linespc} {
1207 set yb [expr {$y1 + $dx}]
1209 if {![info exists mainline($p)]} {
1211 lappend coords $xj $yb
1213 set mainline($p) $coords
1214 set mainlinearrow($p) none
1216 lappend coords $xj $yb
1218 lappend coords $xj $y2
1220 lappend sidelines($p) [list $coords 1 none]
1226 if {[lindex $displist $i] != $id} {
1227 set j [lsearch -exact $displist $id]
1229 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1230 || ($olddlevel < $i && $i < $dlevel)
1231 || ($dlevel < $i && $i < $olddlevel)} {
1232 set xj [xcoord $j $dlevel $lj]
1233 lappend mainline($id) $xi $y1 $xj $y2
1240 # search for x in a list of lists
1241 proc llsearch {llist x} {
1244 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1252 proc drawmore {reading} {
1253 global displayorder numcommits ncmupdate nextupdate
1254 global stopped nhyperspace parents commitlisted
1255 global maxwidth onscreen displist currentparents olddlevel
1257 set n [llength $displayorder]
1258 while {$numcommits < $n} {
1259 set id [lindex $displayorder $numcommits]
1260 set ctxend [expr {$numcommits + 10}]
1261 if {!$reading && $ctxend > $n} {
1265 if {$numcommits > 0} {
1266 set dlist [lreplace $displist $olddlevel $olddlevel]
1268 foreach p $currentparents {
1269 if {$onscreen($p) == 0} {
1270 set dlist [linsert $dlist $i $p]
1277 set isfat [expr {[llength $dlist] > $maxwidth}]
1278 if {$nhyperspace > 0 || $isfat} {
1279 if {$ctxend > $n} break
1280 # work out what to bring back and
1281 # what we want to don't want to send into hyperspace
1283 for {set k $numcommits} {$k < $ctxend} {incr k} {
1284 set x [lindex $displayorder $k]
1285 set i [llsearch $dlist $x]
1287 set i [llength $dlist]
1290 if {[lsearch -exact $nohs $x] < 0} {
1293 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1294 set reins [list $x $i]
1297 if {[info exists commitlisted($x)]} {
1299 foreach p $parents($x) {
1300 if {[llsearch $dlist $p] < 0} {
1302 if {[lsearch -exact $nohs $p] < 0} {
1305 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1306 set reins [list $p [expr {$i + $right}]]
1312 set l [lindex $dlist $i]
1313 if {[llength $l] == 1} {
1316 set j [lsearch -exact $l $x]
1317 set l [concat [lreplace $l $j $j] $newp]
1319 set dlist [lreplace $dlist $i $i $l]
1320 if {$room && $isfat && [llength $newp] <= 1} {
1326 set dlevel [drawslants $id $reins $nohs]
1327 drawcommitline $dlevel
1328 if {[clock clicks -milliseconds] >= $nextupdate
1329 && $numcommits >= $ncmupdate} {
1336 # level here is an index in todo
1337 proc updatetodo {level noshortcut} {
1338 global ncleft todo nnewparents
1339 global commitlisted parents onscreen
1341 set id [lindex $todo $level]
1343 if {[info exists commitlisted($id)]} {
1344 foreach p $parents($id) {
1345 if {[lsearch -exact $olds $p] < 0} {
1350 if {!$noshortcut && [llength $olds] == 1} {
1351 set p [lindex $olds 0]
1352 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1354 set todo [lreplace $todo $level $level $p]
1356 set nnewparents($id) 1
1361 set todo [lreplace $todo $level $level]
1366 set k [lsearch -exact $todo $p]
1368 set todo [linsert $todo $i $p]
1374 set nnewparents($id) $n
1379 proc decidenext {{noread 0}} {
1381 global datemode cdate
1384 # choose which one to do next time around
1385 set todol [llength $todo]
1388 for {set k $todol} {[incr k -1] >= 0} {} {
1389 set p [lindex $todo $k]
1390 if {$ncleft($p) == 0} {
1392 if {![info exists commitinfo($p)]} {
1398 if {$latest == {} || $cdate($p) > $latest} {
1400 set latest $cdate($p)
1410 puts "ERROR: none of the pending commits can be done yet:"
1412 puts " $p ($ncleft($p))"
1421 proc drawcommit {id} {
1422 global phase todo nchildren datemode nextupdate
1423 global numcommits ncmupdate displayorder todo onscreen
1425 if {$phase != "incrdraw"} {
1431 if {$nchildren($id) == 0} {
1435 set level [decidenext 1]
1436 if {$level == {} || $id != [lindex $todo $level]} {
1440 lappend displayorder [lindex $todo $level]
1441 if {[updatetodo $level $datemode]} {
1442 set level [decidenext 1]
1443 if {$level == {}} break
1445 set id [lindex $todo $level]
1446 if {![info exists commitlisted($id)]} {
1453 proc finishcommits {} {
1455 global canv mainfont ctext maincursor textcursor
1457 if {$phase != "incrdraw"} {
1459 $canv create text 3 3 -anchor nw -text "No commits selected" \
1460 -font $mainfont -tags textitems
1465 . config -cursor $maincursor
1466 settextcursor $textcursor
1469 # Don't change the text pane cursor if it is currently the hand cursor,
1470 # showing that we are over a sha1 ID link.
1471 proc settextcursor {c} {
1472 global ctext curtextcursor
1474 if {[$ctext cget -cursor] == $curtextcursor} {
1475 $ctext config -cursor $c
1477 set curtextcursor $c
1481 global nextupdate startmsecs ncmupdate
1482 global displayorder onscreen
1484 if {$displayorder == {}} return
1485 set startmsecs [clock clicks -milliseconds]
1486 set nextupdate [expr $startmsecs + 100]
1489 foreach id $displayorder {
1496 global phase stopped redisplaying selectedline
1497 global datemode todo displayorder
1498 global numcommits ncmupdate
1499 global nextupdate startmsecs idline
1501 set level [decidenext]
1505 lappend displayorder [lindex $todo $level]
1506 set hard [updatetodo $level $datemode]
1508 set level [decidenext]
1509 if {$level < 0} break
1515 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1516 #puts "overall $drawmsecs ms for $numcommits commits"
1517 if {$redisplaying} {
1518 if {$stopped == 0 && [info exists selectedline]} {
1519 selectline $selectedline 0
1521 if {$stopped == 1} {
1523 after idle drawgraph
1530 proc findmatches {f} {
1531 global findtype foundstring foundstrlen
1532 if {$findtype == "Regexp"} {
1533 set matches [regexp -indices -all -inline $foundstring $f]
1535 if {$findtype == "IgnCase"} {
1536 set str [string tolower $f]
1542 while {[set j [string first $foundstring $str $i]] >= 0} {
1543 lappend matches [list $j [expr $j+$foundstrlen-1]]
1544 set i [expr $j + $foundstrlen]
1551 global findtype findloc findstring markedmatches commitinfo
1552 global numcommits lineid linehtag linentag linedtag
1553 global mainfont namefont canv canv2 canv3 selectedline
1554 global matchinglines foundstring foundstrlen
1559 set matchinglines {}
1560 if {$findloc == "Pickaxe"} {
1564 if {$findtype == "IgnCase"} {
1565 set foundstring [string tolower $findstring]
1567 set foundstring $findstring
1569 set foundstrlen [string length $findstring]
1570 if {$foundstrlen == 0} return
1571 if {$findloc == "Files"} {
1575 if {![info exists selectedline]} {
1578 set oldsel $selectedline
1581 set fldtypes {Headline Author Date Committer CDate Comment}
1582 for {set l 0} {$l < $numcommits} {incr l} {
1584 set info $commitinfo($id)
1586 foreach f $info ty $fldtypes {
1587 if {$findloc != "All fields" && $findloc != $ty} {
1590 set matches [findmatches $f]
1591 if {$matches == {}} continue
1593 if {$ty == "Headline"} {
1594 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1595 } elseif {$ty == "Author"} {
1596 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1597 } elseif {$ty == "Date"} {
1598 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1602 lappend matchinglines $l
1603 if {!$didsel && $l > $oldsel} {
1609 if {$matchinglines == {}} {
1611 } elseif {!$didsel} {
1612 findselectline [lindex $matchinglines 0]
1616 proc findselectline {l} {
1617 global findloc commentend ctext
1619 if {$findloc == "All fields" || $findloc == "Comments"} {
1620 # highlight the matches in the comments
1621 set f [$ctext get 1.0 $commentend]
1622 set matches [findmatches $f]
1623 foreach match $matches {
1624 set start [lindex $match 0]
1625 set end [expr [lindex $match 1] + 1]
1626 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1631 proc findnext {restart} {
1632 global matchinglines selectedline
1633 if {![info exists matchinglines]} {
1639 if {![info exists selectedline]} return
1640 foreach l $matchinglines {
1641 if {$l > $selectedline} {
1650 global matchinglines selectedline
1651 if {![info exists matchinglines]} {
1655 if {![info exists selectedline]} return
1657 foreach l $matchinglines {
1658 if {$l >= $selectedline} break
1662 findselectline $prev
1668 proc findlocchange {name ix op} {
1669 global findloc findtype findtypemenu
1670 if {$findloc == "Pickaxe"} {
1676 $findtypemenu entryconf 1 -state $state
1677 $findtypemenu entryconf 2 -state $state
1680 proc stopfindproc {{done 0}} {
1681 global findprocpid findprocfile findids
1682 global ctext findoldcursor phase maincursor textcursor
1683 global findinprogress
1685 catch {unset findids}
1686 if {[info exists findprocpid]} {
1688 catch {exec kill $findprocpid}
1690 catch {close $findprocfile}
1693 if {[info exists findinprogress]} {
1694 unset findinprogress
1695 if {$phase != "incrdraw"} {
1696 . config -cursor $maincursor
1697 settextcursor $textcursor
1702 proc findpatches {} {
1703 global findstring selectedline numcommits
1704 global findprocpid findprocfile
1705 global finddidsel ctext lineid findinprogress
1706 global findinsertpos
1708 if {$numcommits == 0} return
1710 # make a list of all the ids to search, starting at the one
1711 # after the selected line (if any)
1712 if {[info exists selectedline]} {
1718 for {set i 0} {$i < $numcommits} {incr i} {
1719 if {[incr l] >= $numcommits} {
1722 append inputids $lineid($l) "\n"
1726 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1729 error_popup "Error starting search process: $err"
1733 set findinsertpos end
1735 set findprocpid [pid $f]
1736 fconfigure $f -blocking 0
1737 fileevent $f readable readfindproc
1739 . config -cursor watch
1741 set findinprogress 1
1744 proc readfindproc {} {
1745 global findprocfile finddidsel
1746 global idline matchinglines findinsertpos
1748 set n [gets $findprocfile line]
1750 if {[eof $findprocfile]} {
1758 if {![regexp {^[0-9a-f]{40}} $line id]} {
1759 error_popup "Can't parse git-diff-tree output: $line"
1763 if {![info exists idline($id)]} {
1764 puts stderr "spurious id: $id"
1771 proc insertmatch {l id} {
1772 global matchinglines findinsertpos finddidsel
1774 if {$findinsertpos == "end"} {
1775 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1776 set matchinglines [linsert $matchinglines 0 $l]
1779 lappend matchinglines $l
1782 set matchinglines [linsert $matchinglines $findinsertpos $l]
1793 global selectedline numcommits lineid ctext
1794 global ffileline finddidsel parents nparents
1795 global findinprogress findstartline findinsertpos
1796 global treediffs fdiffids fdiffsneeded fdiffpos
1797 global findmergefiles
1799 if {$numcommits == 0} return
1801 if {[info exists selectedline]} {
1802 set l [expr {$selectedline + 1}]
1807 set findstartline $l
1812 if {$findmergefiles || $nparents($id) == 1} {
1813 foreach p $parents($id) {
1814 if {![info exists treediffs([list $id $p])]} {
1815 append diffsneeded "$id $p\n"
1816 lappend fdiffsneeded [list $id $p]
1820 if {[incr l] >= $numcommits} {
1823 if {$l == $findstartline} break
1826 # start off a git-diff-tree process if needed
1827 if {$diffsneeded ne {}} {
1829 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1831 error_popup "Error starting search process: $err"
1834 catch {unset fdiffids}
1836 fconfigure $df -blocking 0
1837 fileevent $df readable [list readfilediffs $df]
1841 set findinsertpos end
1843 set p [lindex $parents($id) 0]
1844 . config -cursor watch
1846 set findinprogress 1
1847 findcont [list $id $p]
1851 proc readfilediffs {df} {
1852 global findids fdiffids fdiffs
1854 set n [gets $df line]
1858 if {[catch {close $df} err]} {
1861 error_popup "Error in git-diff-tree: $err"
1862 } elseif {[info exists findids]} {
1866 error_popup "Couldn't find diffs for {$ids}"
1871 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1872 # start of a new string of diffs
1874 set fdiffids [list $id $p]
1876 } elseif {[string match ":*" $line]} {
1877 lappend fdiffs [lindex $line 5]
1881 proc donefilediff {} {
1882 global fdiffids fdiffs treediffs findids
1883 global fdiffsneeded fdiffpos
1885 if {[info exists fdiffids]} {
1886 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1887 && $fdiffpos < [llength $fdiffsneeded]} {
1888 # git-diff-tree doesn't output anything for a commit
1889 # which doesn't change anything
1890 set nullids [lindex $fdiffsneeded $fdiffpos]
1891 set treediffs($nullids) {}
1892 if {[info exists findids] && $nullids eq $findids} {
1900 if {![info exists treediffs($fdiffids)]} {
1901 set treediffs($fdiffids) $fdiffs
1903 if {[info exists findids] && $fdiffids eq $findids} {
1910 proc findcont {ids} {
1911 global findids treediffs parents nparents
1912 global ffileline findstartline finddidsel
1913 global lineid numcommits matchinglines findinprogress
1914 global findmergefiles
1916 set id [lindex $ids 0]
1917 set p [lindex $ids 1]
1918 set pi [lsearch -exact $parents($id) $p]
1921 if {$findmergefiles || $nparents($id) == 1} {
1922 if {![info exists treediffs($ids)]} {
1928 foreach f $treediffs($ids) {
1929 set x [findmatches $f]
1937 set pi $nparents($id)
1940 set pi $nparents($id)
1942 if {[incr pi] >= $nparents($id)} {
1944 if {[incr l] >= $numcommits} {
1947 if {$l == $findstartline} break
1950 set p [lindex $parents($id) $pi]
1951 set ids [list $id $p]
1959 # mark a commit as matching by putting a yellow background
1960 # behind the headline
1961 proc markheadline {l id} {
1962 global canv mainfont linehtag commitinfo
1964 set bbox [$canv bbox $linehtag($l)]
1965 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1969 # mark the bits of a headline, author or date that match a find string
1970 proc markmatches {canv l str tag matches font} {
1971 set bbox [$canv bbox $tag]
1972 set x0 [lindex $bbox 0]
1973 set y0 [lindex $bbox 1]
1974 set y1 [lindex $bbox 3]
1975 foreach match $matches {
1976 set start [lindex $match 0]
1977 set end [lindex $match 1]
1978 if {$start > $end} continue
1979 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1980 set xlen [font measure $font [string range $str 0 [expr $end]]]
1981 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1982 -outline {} -tags matches -fill yellow]
1987 proc unmarkmatches {} {
1988 global matchinglines findids
1989 allcanvs delete matches
1990 catch {unset matchinglines}
1991 catch {unset findids}
1994 proc selcanvline {w x y} {
1995 global canv canvy0 ctext linespc
1996 global lineid linehtag linentag linedtag rowtextx
1997 set ymax [lindex [$canv cget -scrollregion] 3]
1998 if {$ymax == {}} return
1999 set yfrac [lindex [$canv yview] 0]
2000 set y [expr {$y + $yfrac * $ymax}]
2001 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2006 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2012 proc commit_descriptor {p} {
2015 if {[info exists commitinfo($p)]} {
2016 set l [lindex $commitinfo($p) 0]
2021 proc selectline {l isnew} {
2022 global canv canv2 canv3 ctext commitinfo selectedline
2023 global lineid linehtag linentag linedtag
2024 global canvy0 linespc parents nparents children
2025 global cflist currentid sha1entry
2026 global commentend idtags idline
2029 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2031 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2032 -tags secsel -fill [$canv cget -selectbackground]]
2034 $canv2 delete secsel
2035 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2036 -tags secsel -fill [$canv2 cget -selectbackground]]
2038 $canv3 delete secsel
2039 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2040 -tags secsel -fill [$canv3 cget -selectbackground]]
2042 set y [expr {$canvy0 + $l * $linespc}]
2043 set ymax [lindex [$canv cget -scrollregion] 3]
2044 set ytop [expr {$y - $linespc - 1}]
2045 set ybot [expr {$y + $linespc + 1}]
2046 set wnow [$canv yview]
2047 set wtop [expr [lindex $wnow 0] * $ymax]
2048 set wbot [expr [lindex $wnow 1] * $ymax]
2049 set wh [expr {$wbot - $wtop}]
2051 if {$ytop < $wtop} {
2052 if {$ybot < $wtop} {
2053 set newtop [expr {$y - $wh / 2.0}]
2056 if {$newtop > $wtop - $linespc} {
2057 set newtop [expr {$wtop - $linespc}]
2060 } elseif {$ybot > $wbot} {
2061 if {$ytop > $wbot} {
2062 set newtop [expr {$y - $wh / 2.0}]
2064 set newtop [expr {$ybot - $wh}]
2065 if {$newtop < $wtop + $linespc} {
2066 set newtop [expr {$wtop + $linespc}]
2070 if {$newtop != $wtop} {
2074 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
2078 addtohistory [list selectline $l 0]
2085 $sha1entry delete 0 end
2086 $sha1entry insert 0 $id
2087 $sha1entry selection from 0
2088 $sha1entry selection to end
2090 $ctext conf -state normal
2091 $ctext delete 0.0 end
2092 $ctext mark set fmark.0 0.0
2093 $ctext mark gravity fmark.0 left
2094 set info $commitinfo($id)
2095 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
2096 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
2097 if {[info exists idtags($id)]} {
2098 $ctext insert end "Tags:"
2099 foreach tag $idtags($id) {
2100 $ctext insert end " $tag"
2102 $ctext insert end "\n"
2105 set commentstart [$ctext index "end - 1c"]
2107 if {[info exists parents($id)]} {
2108 foreach p $parents($id) {
2109 append comment "Parent: [commit_descriptor $p]\n"
2112 if {[info exists children($id)]} {
2113 foreach c $children($id) {
2114 append comment "Child: [commit_descriptor $c]\n"
2118 append comment [lindex $info 5]
2119 $ctext insert end $comment
2120 $ctext insert end "\n"
2122 # make anything that looks like a SHA1 ID be a clickable link
2123 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
2128 set linkid [string range $comment $s $e]
2129 if {![info exists idline($linkid)]} continue
2131 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
2132 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
2133 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
2136 $ctext tag conf link -foreground blue -underline 1
2137 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2138 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2140 $ctext tag delete Comments
2141 $ctext tag remove found 1.0 end
2142 $ctext conf -state disabled
2143 set commentend [$ctext index "end - 1c"]
2145 $cflist delete 0 end
2146 $cflist insert end "Comments"
2147 if {$nparents($id) == 1} {
2148 startdiff [concat $id $parents($id)]
2149 } elseif {$nparents($id) > 1} {
2154 proc selnextline {dir} {
2156 if {![info exists selectedline]} return
2157 set l [expr $selectedline + $dir]
2162 proc unselectline {} {
2165 catch {unset selectedline}
2166 allcanvs delete secsel
2169 proc addtohistory {cmd} {
2170 global history historyindex
2172 if {$historyindex > 0
2173 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2177 if {$historyindex < [llength $history]} {
2178 set history [lreplace $history $historyindex end $cmd]
2180 lappend history $cmd
2183 if {$historyindex > 1} {
2184 .ctop.top.bar.leftbut conf -state normal
2186 .ctop.top.bar.leftbut conf -state disabled
2188 .ctop.top.bar.rightbut conf -state disabled
2192 global history historyindex
2194 if {$historyindex > 1} {
2195 incr historyindex -1
2196 set cmd [lindex $history [expr {$historyindex - 1}]]
2198 .ctop.top.bar.rightbut conf -state normal
2200 if {$historyindex <= 1} {
2201 .ctop.top.bar.leftbut conf -state disabled
2206 global history historyindex
2208 if {$historyindex < [llength $history]} {
2209 set cmd [lindex $history $historyindex]
2212 .ctop.top.bar.leftbut conf -state normal
2214 if {$historyindex >= [llength $history]} {
2215 .ctop.top.bar.rightbut conf -state disabled
2219 proc mergediff {id} {
2220 global parents diffmergeid diffmergegca mergefilelist diffpindex
2224 set diffmergegca [findgca $parents($id)]
2225 if {[info exists mergefilelist($id)]} {
2226 if {$mergefilelist($id) ne {}} {
2234 proc findgca {ids} {
2241 set gca [exec git-merge-base $gca $id]
2250 proc contmergediff {ids} {
2251 global diffmergeid diffpindex parents nparents diffmergegca
2252 global treediffs mergefilelist diffids treepending
2254 # diff the child against each of the parents, and diff
2255 # each of the parents against the GCA.
2257 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2258 set ids [list [lindex $ids 1] $diffmergegca]
2260 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2261 set p [lindex $parents($diffmergeid) $diffpindex]
2262 set ids [list $diffmergeid $p]
2264 if {![info exists treediffs($ids)]} {
2266 if {![info exists treepending]} {
2273 # If a file in some parent is different from the child and also
2274 # different from the GCA, then it's interesting.
2275 # If we don't have a GCA, then a file is interesting if it is
2276 # different from the child in all the parents.
2277 if {$diffmergegca ne {}} {
2279 foreach p $parents($diffmergeid) {
2280 set gcadiffs $treediffs([list $p $diffmergegca])
2281 foreach f $treediffs([list $diffmergeid $p]) {
2282 if {[lsearch -exact $files $f] < 0
2283 && [lsearch -exact $gcadiffs $f] >= 0} {
2288 set files [lsort $files]
2290 set p [lindex $parents($diffmergeid) 0]
2291 set files $treediffs([list $diffmergeid $p])
2292 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2293 set p [lindex $parents($diffmergeid) $i]
2294 set df $treediffs([list $diffmergeid $p])
2297 if {[lsearch -exact $df $f] >= 0} {
2305 set mergefilelist($diffmergeid) $files
2311 proc showmergediff {} {
2312 global cflist diffmergeid mergefilelist parents
2313 global diffopts diffinhunk currentfile currenthunk filelines
2314 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2316 set files $mergefilelist($diffmergeid)
2318 $cflist insert end $f
2320 set env(GIT_DIFF_OPTS) $diffopts
2322 catch {unset currentfile}
2323 catch {unset currenthunk}
2324 catch {unset filelines}
2325 catch {unset groupfilenum}
2326 catch {unset grouphunks}
2327 set groupfilelast -1
2328 foreach p $parents($diffmergeid) {
2329 set cmd [list | git-diff-tree -p $p $diffmergeid]
2330 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2331 if {[catch {set f [open $cmd r]} err]} {
2332 error_popup "Error getting diffs: $err"
2339 set ids [list $diffmergeid $p]
2340 set mergefds($ids) $f
2341 set diffinhunk($ids) 0
2342 set diffblocked($ids) 0
2343 fconfigure $f -blocking 0
2344 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2348 proc getmergediffline {f ids id} {
2349 global diffmergeid diffinhunk diffoldlines diffnewlines
2350 global currentfile currenthunk
2351 global diffoldstart diffnewstart diffoldlno diffnewlno
2352 global diffblocked mergefilelist
2353 global noldlines nnewlines difflcounts filelines
2355 set n [gets $f line]
2357 if {![eof $f]} return
2360 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2367 if {$diffinhunk($ids) != 0} {
2368 set fi $currentfile($ids)
2369 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2370 # continuing an existing hunk
2371 set line [string range $line 1 end]
2372 set p [lindex $ids 1]
2373 if {$match eq "-" || $match eq " "} {
2374 set filelines($p,$fi,$diffoldlno($ids)) $line
2375 incr diffoldlno($ids)
2377 if {$match eq "+" || $match eq " "} {
2378 set filelines($id,$fi,$diffnewlno($ids)) $line
2379 incr diffnewlno($ids)
2381 if {$match eq " "} {
2382 if {$diffinhunk($ids) == 2} {
2383 lappend difflcounts($ids) \
2384 [list $noldlines($ids) $nnewlines($ids)]
2385 set noldlines($ids) 0
2386 set diffinhunk($ids) 1
2388 incr noldlines($ids)
2389 } elseif {$match eq "-" || $match eq "+"} {
2390 if {$diffinhunk($ids) == 1} {
2391 lappend difflcounts($ids) [list $noldlines($ids)]
2392 set noldlines($ids) 0
2393 set nnewlines($ids) 0
2394 set diffinhunk($ids) 2
2396 if {$match eq "-"} {
2397 incr noldlines($ids)
2399 incr nnewlines($ids)
2402 # and if it's \ No newline at end of line, then what?
2406 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2407 lappend difflcounts($ids) [list $noldlines($ids)]
2408 } elseif {$diffinhunk($ids) == 2
2409 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2410 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2412 set currenthunk($ids) [list $currentfile($ids) \
2413 $diffoldstart($ids) $diffnewstart($ids) \
2414 $diffoldlno($ids) $diffnewlno($ids) \
2416 set diffinhunk($ids) 0
2417 # -1 = need to block, 0 = unblocked, 1 = is blocked
2418 set diffblocked($ids) -1
2420 if {$diffblocked($ids) == -1} {
2421 fileevent $f readable {}
2422 set diffblocked($ids) 1
2428 if {!$diffblocked($ids)} {
2430 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2431 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2434 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2435 # start of a new file
2436 set currentfile($ids) \
2437 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2438 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2439 $line match f1l f1c f2l f2c rest]} {
2440 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2441 # start of a new hunk
2442 if {$f1l == 0 && $f1c == 0} {
2445 if {$f2l == 0 && $f2c == 0} {
2448 set diffinhunk($ids) 1
2449 set diffoldstart($ids) $f1l
2450 set diffnewstart($ids) $f2l
2451 set diffoldlno($ids) $f1l
2452 set diffnewlno($ids) $f2l
2453 set difflcounts($ids) {}
2454 set noldlines($ids) 0
2455 set nnewlines($ids) 0
2460 proc processhunks {} {
2461 global diffmergeid parents nparents currenthunk
2462 global mergefilelist diffblocked mergefds
2463 global grouphunks grouplinestart grouplineend groupfilenum
2465 set nfiles [llength $mergefilelist($diffmergeid)]
2469 # look for the earliest hunk
2470 foreach p $parents($diffmergeid) {
2471 set ids [list $diffmergeid $p]
2472 if {![info exists currenthunk($ids)]} return
2473 set i [lindex $currenthunk($ids) 0]
2474 set l [lindex $currenthunk($ids) 2]
2475 if {$i < $fi || ($i == $fi && $l < $lno)} {
2482 if {$fi < $nfiles} {
2483 set ids [list $diffmergeid $pi]
2484 set hunk $currenthunk($ids)
2485 unset currenthunk($ids)
2486 if {$diffblocked($ids) > 0} {
2487 fileevent $mergefds($ids) readable \
2488 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2490 set diffblocked($ids) 0
2492 if {[info exists groupfilenum] && $groupfilenum == $fi
2493 && $lno <= $grouplineend} {
2494 # add this hunk to the pending group
2495 lappend grouphunks($pi) $hunk
2496 set endln [lindex $hunk 4]
2497 if {$endln > $grouplineend} {
2498 set grouplineend $endln
2504 # succeeding stuff doesn't belong in this group, so
2505 # process the group now
2506 if {[info exists groupfilenum]} {
2512 if {$fi >= $nfiles} break
2515 set groupfilenum $fi
2516 set grouphunks($pi) [list $hunk]
2517 set grouplinestart $lno
2518 set grouplineend [lindex $hunk 4]
2522 proc processgroup {} {
2523 global groupfilelast groupfilenum difffilestart
2524 global mergefilelist diffmergeid ctext filelines
2525 global parents diffmergeid diffoffset
2526 global grouphunks grouplinestart grouplineend nparents
2529 $ctext conf -state normal
2532 if {$groupfilelast != $f} {
2533 $ctext insert end "\n"
2534 set here [$ctext index "end - 1c"]
2535 set difffilestart($f) $here
2536 set mark fmark.[expr {$f + 1}]
2537 $ctext mark set $mark $here
2538 $ctext mark gravity $mark left
2539 set header [lindex $mergefilelist($id) $f]
2540 set l [expr {(78 - [string length $header]) / 2}]
2541 set pad [string range "----------------------------------------" 1 $l]
2542 $ctext insert end "$pad $header $pad\n" filesep
2543 set groupfilelast $f
2544 foreach p $parents($id) {
2545 set diffoffset($p) 0
2549 $ctext insert end "@@" msep
2550 set nlines [expr {$grouplineend - $grouplinestart}]
2553 foreach p $parents($id) {
2554 set startline [expr {$grouplinestart + $diffoffset($p)}]
2556 set nl $grouplinestart
2557 if {[info exists grouphunks($p)]} {
2558 foreach h $grouphunks($p) {
2561 for {} {$nl < $l} {incr nl} {
2562 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2566 foreach chunk [lindex $h 5] {
2567 if {[llength $chunk] == 2} {
2568 set olc [lindex $chunk 0]
2569 set nlc [lindex $chunk 1]
2570 set nnl [expr {$nl + $nlc}]
2571 lappend events [list $nl $nnl $pnum $olc $nlc]
2575 incr ol [lindex $chunk 0]
2576 incr nl [lindex $chunk 0]
2581 if {$nl < $grouplineend} {
2582 for {} {$nl < $grouplineend} {incr nl} {
2583 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2587 set nlines [expr {$ol - $startline}]
2588 $ctext insert end " -$startline,$nlines" msep
2592 set nlines [expr {$grouplineend - $grouplinestart}]
2593 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2595 set events [lsort -integer -index 0 $events]
2596 set nevents [llength $events]
2597 set nmerge $nparents($diffmergeid)
2598 set l $grouplinestart
2599 for {set i 0} {$i < $nevents} {set i $j} {
2600 set nl [lindex $events $i 0]
2602 $ctext insert end " $filelines($id,$f,$l)\n"
2605 set e [lindex $events $i]
2606 set enl [lindex $e 1]
2610 set pnum [lindex $e 2]
2611 set olc [lindex $e 3]
2612 set nlc [lindex $e 4]
2613 if {![info exists delta($pnum)]} {
2614 set delta($pnum) [expr {$olc - $nlc}]
2615 lappend active $pnum
2617 incr delta($pnum) [expr {$olc - $nlc}]
2619 if {[incr j] >= $nevents} break
2620 set e [lindex $events $j]
2621 if {[lindex $e 0] >= $enl} break
2622 if {[lindex $e 1] > $enl} {
2623 set enl [lindex $e 1]
2626 set nlc [expr {$enl - $l}]
2629 if {[llength $active] == $nmerge - 1} {
2630 # no diff for one of the parents, i.e. it's identical
2631 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2632 if {![info exists delta($pnum)]} {
2633 if {$pnum < $mergemax} {
2641 } elseif {[llength $active] == $nmerge} {
2642 # all parents are different, see if one is very similar
2644 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2645 set sim [similarity $pnum $l $nlc $f \
2646 [lrange $events $i [expr {$j-1}]]]
2647 if {$sim > $bestsim} {
2653 lappend ncol m$bestpn
2657 foreach p $parents($id) {
2659 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2660 set olc [expr {$nlc + $delta($pnum)}]
2661 set ol [expr {$l + $diffoffset($p)}]
2662 incr diffoffset($p) $delta($pnum)
2664 for {} {$olc > 0} {incr olc -1} {
2665 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2669 set endl [expr {$l + $nlc}]
2671 # show this pretty much as a normal diff
2672 set p [lindex $parents($id) $bestpn]
2673 set ol [expr {$l + $diffoffset($p)}]
2674 incr diffoffset($p) $delta($bestpn)
2675 unset delta($bestpn)
2676 for {set k $i} {$k < $j} {incr k} {
2677 set e [lindex $events $k]
2678 if {[lindex $e 2] != $bestpn} continue
2679 set nl [lindex $e 0]
2680 set ol [expr {$ol + $nl - $l}]
2681 for {} {$l < $nl} {incr l} {
2682 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2685 for {} {$c > 0} {incr c -1} {
2686 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2689 set nl [lindex $e 1]
2690 for {} {$l < $nl} {incr l} {
2691 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2695 for {} {$l < $endl} {incr l} {
2696 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2699 while {$l < $grouplineend} {
2700 $ctext insert end " $filelines($id,$f,$l)\n"
2703 $ctext conf -state disabled
2706 proc similarity {pnum l nlc f events} {
2707 global diffmergeid parents diffoffset filelines
2710 set p [lindex $parents($id) $pnum]
2711 set ol [expr {$l + $diffoffset($p)}]
2712 set endl [expr {$l + $nlc}]
2716 if {[lindex $e 2] != $pnum} continue
2717 set nl [lindex $e 0]
2718 set ol [expr {$ol + $nl - $l}]
2719 for {} {$l < $nl} {incr l} {
2720 incr same [string length $filelines($id,$f,$l)]
2723 set oc [lindex $e 3]
2724 for {} {$oc > 0} {incr oc -1} {
2725 incr diff [string length $filelines($p,$f,$ol)]
2729 set nl [lindex $e 1]
2730 for {} {$l < $nl} {incr l} {
2731 incr diff [string length $filelines($id,$f,$l)]
2735 for {} {$l < $endl} {incr l} {
2736 incr same [string length $filelines($id,$f,$l)]
2742 return [expr {200 * $same / (2 * $same + $diff)}]
2745 proc startdiff {ids} {
2746 global treediffs diffids treepending diffmergeid
2749 catch {unset diffmergeid}
2750 if {![info exists treediffs($ids)]} {
2751 if {![info exists treepending]} {
2759 proc addtocflist {ids} {
2760 global treediffs cflist
2761 foreach f $treediffs($ids) {
2762 $cflist insert end $f
2767 proc gettreediffs {ids} {
2768 global treediff parents treepending
2769 set treepending $ids
2771 set id [lindex $ids 0]
2772 set p [lindex $ids 1]
2773 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2774 fconfigure $gdtf -blocking 0
2775 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2778 proc gettreediffline {gdtf ids} {
2779 global treediff treediffs treepending diffids diffmergeid
2781 set n [gets $gdtf line]
2783 if {![eof $gdtf]} return
2785 set treediffs($ids) $treediff
2787 if {$ids != $diffids} {
2788 gettreediffs $diffids
2790 if {[info exists diffmergeid]} {
2798 set file [lindex $line 5]
2799 lappend treediff $file
2802 proc getblobdiffs {ids} {
2803 global diffopts blobdifffd diffids env curdifftag curtagstart
2804 global difffilestart nextupdate diffinhdr treediffs
2806 set id [lindex $ids 0]
2807 set p [lindex $ids 1]
2808 set env(GIT_DIFF_OPTS) $diffopts
2809 set cmd [list | git-diff-tree -r -p -C $p $id]
2810 if {[catch {set bdf [open $cmd r]} err]} {
2811 puts "error getting diffs: $err"
2815 fconfigure $bdf -blocking 0
2816 set blobdifffd($ids) $bdf
2817 set curdifftag Comments
2819 catch {unset difffilestart}
2820 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2821 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2824 proc getblobdiffline {bdf ids} {
2825 global diffids blobdifffd ctext curdifftag curtagstart
2826 global diffnexthead diffnextnote difffilestart
2827 global nextupdate diffinhdr treediffs
2830 set n [gets $bdf line]
2834 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2835 $ctext tag add $curdifftag $curtagstart end
2840 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2843 $ctext conf -state normal
2844 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2845 # start of a new file
2846 $ctext insert end "\n"
2847 $ctext tag add $curdifftag $curtagstart end
2848 set curtagstart [$ctext index "end - 1c"]
2850 set here [$ctext index "end - 1c"]
2851 set i [lsearch -exact $treediffs($diffids) $fname]
2853 set difffilestart($i) $here
2855 $ctext mark set fmark.$i $here
2856 $ctext mark gravity fmark.$i left
2858 if {$newname != $fname} {
2859 set i [lsearch -exact $treediffs($diffids) $newname]
2861 set difffilestart($i) $here
2863 $ctext mark set fmark.$i $here
2864 $ctext mark gravity fmark.$i left
2867 set curdifftag "f:$fname"
2868 $ctext tag delete $curdifftag
2869 set l [expr {(78 - [string length $header]) / 2}]
2870 set pad [string range "----------------------------------------" 1 $l]
2871 $ctext insert end "$pad $header $pad\n" filesep
2873 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2875 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2876 $line match f1l f1c f2l f2c rest]} {
2878 $ctext insert end "\t" hunksep
2879 $ctext insert end " $f1l " d0 " $f2l " d1
2880 $ctext insert end " $rest \n" hunksep
2882 $ctext insert end "$line\n" hunksep
2886 set x [string range $line 0 0]
2887 if {$x == "-" || $x == "+"} {
2888 set tag [expr {$x == "+"}]
2890 set line [string range $line 1 end]
2892 $ctext insert end "$line\n" d$tag
2893 } elseif {$x == " "} {
2895 set line [string range $line 1 end]
2897 $ctext insert end "$line\n"
2898 } elseif {$diffinhdr || $x == "\\"} {
2899 # e.g. "\ No newline at end of file"
2900 $ctext insert end "$line\n" filesep
2902 # Something else we don't recognize
2903 if {$curdifftag != "Comments"} {
2904 $ctext insert end "\n"
2905 $ctext tag add $curdifftag $curtagstart end
2906 set curtagstart [$ctext index "end - 1c"]
2907 set curdifftag Comments
2909 $ctext insert end "$line\n" filesep
2912 $ctext conf -state disabled
2913 if {[clock clicks -milliseconds] >= $nextupdate} {
2915 fileevent $bdf readable {}
2917 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2922 global difffilestart ctext
2923 set here [$ctext index @0,0]
2924 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2925 if {[$ctext compare $difffilestart($i) > $here]} {
2926 if {![info exists pos]
2927 || [$ctext compare $difffilestart($i) < $pos]} {
2928 set pos $difffilestart($i)
2932 if {[info exists pos]} {
2937 proc listboxsel {} {
2938 global ctext cflist currentid
2939 if {![info exists currentid]} return
2940 set sel [lsort [$cflist curselection]]
2941 if {$sel eq {}} return
2942 set first [lindex $sel 0]
2943 catch {$ctext yview fmark.$first}
2947 global linespc charspc canvx0 canvy0 mainfont
2948 global xspc1 xspc2 lthickness
2950 set linespc [font metrics $mainfont -linespace]
2951 set charspc [font measure $mainfont "m"]
2952 set canvy0 [expr 3 + 0.5 * $linespc]
2953 set canvx0 [expr 3 + 0.5 * $linespc]
2954 set lthickness [expr {int($linespc / 9) + 1}]
2955 set xspc1(0) $linespc
2960 global stopped redisplaying phase
2961 if {$stopped > 1} return
2962 if {$phase == "getcommits"} return
2964 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2971 proc incrfont {inc} {
2972 global mainfont namefont textfont ctext canv phase
2973 global stopped entries
2975 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2976 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2977 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2979 $ctext conf -font $textfont
2980 $ctext tag conf filesep -font [concat $textfont bold]
2981 foreach e $entries {
2982 $e conf -font $mainfont
2984 if {$phase == "getcommits"} {
2985 $canv itemconf textitems -font $mainfont
2991 global sha1entry sha1string
2992 if {[string length $sha1string] == 40} {
2993 $sha1entry delete 0 end
2997 proc sha1change {n1 n2 op} {
2998 global sha1string currentid sha1but
2999 if {$sha1string == {}
3000 || ([info exists currentid] && $sha1string == $currentid)} {
3005 if {[$sha1but cget -state] == $state} return
3006 if {$state == "normal"} {
3007 $sha1but conf -state normal -relief raised -text "Goto: "
3009 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3013 proc gotocommit {} {
3014 global sha1string currentid idline tagids
3015 global lineid numcommits
3017 if {$sha1string == {}
3018 || ([info exists currentid] && $sha1string == $currentid)} return
3019 if {[info exists tagids($sha1string)]} {
3020 set id $tagids($sha1string)
3022 set id [string tolower $sha1string]
3023 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3025 for {set l 0} {$l < $numcommits} {incr l} {
3026 if {[string match $id* $lineid($l)]} {
3027 lappend matches $lineid($l)
3030 if {$matches ne {}} {
3031 if {[llength $matches] > 1} {
3032 error_popup "Short SHA1 id $id is ambiguous"
3035 set id [lindex $matches 0]
3039 if {[info exists idline($id)]} {
3040 selectline $idline($id) 1
3043 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3048 error_popup "$type $sha1string is not known"
3051 proc lineenter {x y id} {
3052 global hoverx hovery hoverid hovertimer
3053 global commitinfo canv
3055 if {![info exists commitinfo($id)]} return
3059 if {[info exists hovertimer]} {
3060 after cancel $hovertimer
3062 set hovertimer [after 500 linehover]
3066 proc linemotion {x y id} {
3067 global hoverx hovery hoverid hovertimer
3069 if {[info exists hoverid] && $id == $hoverid} {
3072 if {[info exists hovertimer]} {
3073 after cancel $hovertimer
3075 set hovertimer [after 500 linehover]
3079 proc lineleave {id} {
3080 global hoverid hovertimer canv
3082 if {[info exists hoverid] && $id == $hoverid} {
3084 if {[info exists hovertimer]} {
3085 after cancel $hovertimer
3093 global hoverx hovery hoverid hovertimer
3094 global canv linespc lthickness
3095 global commitinfo mainfont
3097 set text [lindex $commitinfo($hoverid) 0]
3098 set ymax [lindex [$canv cget -scrollregion] 3]
3099 if {$ymax == {}} return
3100 set yfrac [lindex [$canv yview] 0]
3101 set x [expr {$hoverx + 2 * $linespc}]
3102 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3103 set x0 [expr {$x - 2 * $lthickness}]
3104 set y0 [expr {$y - 2 * $lthickness}]
3105 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3106 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3107 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3108 -fill \#ffff80 -outline black -width 1 -tags hover]
3110 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
3114 proc lineclick {x y id isnew} {
3115 global ctext commitinfo children cflist canv
3120 addtohistory [list lineclick $x $x $id 0]
3123 # fill the details pane with info about this line
3124 $ctext conf -state normal
3125 $ctext delete 0.0 end
3126 $ctext tag conf link -foreground blue -underline 1
3127 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3128 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3129 $ctext insert end "Parent:\t"
3130 $ctext insert end $id [list link link0]
3131 $ctext tag bind link0 <1> [list selbyid $id]
3132 set info $commitinfo($id)
3133 $ctext insert end "\n\t[lindex $info 0]\n"
3134 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3135 $ctext insert end "\tDate:\t[lindex $info 2]\n"
3136 if {[info exists children($id)]} {
3137 $ctext insert end "\nChildren:"
3139 foreach child $children($id) {
3141 set info $commitinfo($child)
3142 $ctext insert end "\n\t"
3143 $ctext insert end $child [list link link$i]
3144 $ctext tag bind link$i <1> [list selbyid $child]
3145 $ctext insert end "\n\t[lindex $info 0]"
3146 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3147 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
3150 $ctext conf -state disabled
3152 $cflist delete 0 end
3157 if {[info exists idline($id)]} {
3158 selectline $idline($id) 1
3164 if {![info exists startmstime]} {
3165 set startmstime [clock clicks -milliseconds]
3167 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3170 proc rowmenu {x y id} {
3171 global rowctxmenu idline selectedline rowmenuid
3173 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3178 $rowctxmenu entryconfigure 0 -state $state
3179 $rowctxmenu entryconfigure 1 -state $state
3180 $rowctxmenu entryconfigure 2 -state $state
3182 tk_popup $rowctxmenu $x $y
3185 proc diffvssel {dirn} {
3186 global rowmenuid selectedline lineid
3188 if {![info exists selectedline]} return
3190 set oldid $lineid($selectedline)
3191 set newid $rowmenuid
3193 set oldid $rowmenuid
3194 set newid $lineid($selectedline)
3196 addtohistory [list doseldiff $oldid $newid]
3197 doseldiff $oldid $newid
3200 proc doseldiff {oldid newid} {
3204 $ctext conf -state normal
3205 $ctext delete 0.0 end
3206 $ctext mark set fmark.0 0.0
3207 $ctext mark gravity fmark.0 left
3208 $cflist delete 0 end
3209 $cflist insert end "Top"
3210 $ctext insert end "From "
3211 $ctext tag conf link -foreground blue -underline 1
3212 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3213 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3214 $ctext tag bind link0 <1> [list selbyid $oldid]
3215 $ctext insert end $oldid [list link link0]
3216 $ctext insert end "\n "
3217 $ctext insert end [lindex $commitinfo($oldid) 0]
3218 $ctext insert end "\n\nTo "
3219 $ctext tag bind link1 <1> [list selbyid $newid]
3220 $ctext insert end $newid [list link link1]
3221 $ctext insert end "\n "
3222 $ctext insert end [lindex $commitinfo($newid) 0]
3223 $ctext insert end "\n"
3224 $ctext conf -state disabled
3225 $ctext tag delete Comments
3226 $ctext tag remove found 1.0 end
3227 startdiff [list $newid $oldid]
3231 global rowmenuid currentid commitinfo patchtop patchnum
3233 if {![info exists currentid]} return
3234 set oldid $currentid
3235 set oldhead [lindex $commitinfo($oldid) 0]
3236 set newid $rowmenuid
3237 set newhead [lindex $commitinfo($newid) 0]
3240 catch {destroy $top}
3242 label $top.title -text "Generate patch"
3243 grid $top.title - -pady 10
3244 label $top.from -text "From:"
3245 entry $top.fromsha1 -width 40 -relief flat
3246 $top.fromsha1 insert 0 $oldid
3247 $top.fromsha1 conf -state readonly
3248 grid $top.from $top.fromsha1 -sticky w
3249 entry $top.fromhead -width 60 -relief flat
3250 $top.fromhead insert 0 $oldhead
3251 $top.fromhead conf -state readonly
3252 grid x $top.fromhead -sticky w
3253 label $top.to -text "To:"
3254 entry $top.tosha1 -width 40 -relief flat
3255 $top.tosha1 insert 0 $newid
3256 $top.tosha1 conf -state readonly
3257 grid $top.to $top.tosha1 -sticky w
3258 entry $top.tohead -width 60 -relief flat
3259 $top.tohead insert 0 $newhead
3260 $top.tohead conf -state readonly
3261 grid x $top.tohead -sticky w
3262 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3263 grid $top.rev x -pady 10
3264 label $top.flab -text "Output file:"
3265 entry $top.fname -width 60
3266 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3268 grid $top.flab $top.fname -sticky w
3270 button $top.buts.gen -text "Generate" -command mkpatchgo
3271 button $top.buts.can -text "Cancel" -command mkpatchcan
3272 grid $top.buts.gen $top.buts.can
3273 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3274 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3275 grid $top.buts - -pady 10 -sticky ew
3279 proc mkpatchrev {} {
3282 set oldid [$patchtop.fromsha1 get]
3283 set oldhead [$patchtop.fromhead get]
3284 set newid [$patchtop.tosha1 get]
3285 set newhead [$patchtop.tohead get]
3286 foreach e [list fromsha1 fromhead tosha1 tohead] \
3287 v [list $newid $newhead $oldid $oldhead] {
3288 $patchtop.$e conf -state normal
3289 $patchtop.$e delete 0 end
3290 $patchtop.$e insert 0 $v
3291 $patchtop.$e conf -state readonly
3298 set oldid [$patchtop.fromsha1 get]
3299 set newid [$patchtop.tosha1 get]
3300 set fname [$patchtop.fname get]
3301 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3302 error_popup "Error creating patch: $err"
3304 catch {destroy $patchtop}
3308 proc mkpatchcan {} {
3311 catch {destroy $patchtop}
3316 global rowmenuid mktagtop commitinfo
3320 catch {destroy $top}
3322 label $top.title -text "Create tag"
3323 grid $top.title - -pady 10
3324 label $top.id -text "ID:"
3325 entry $top.sha1 -width 40 -relief flat
3326 $top.sha1 insert 0 $rowmenuid
3327 $top.sha1 conf -state readonly
3328 grid $top.id $top.sha1 -sticky w
3329 entry $top.head -width 60 -relief flat
3330 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3331 $top.head conf -state readonly
3332 grid x $top.head -sticky w
3333 label $top.tlab -text "Tag name:"
3334 entry $top.tag -width 60
3335 grid $top.tlab $top.tag -sticky w
3337 button $top.buts.gen -text "Create" -command mktaggo
3338 button $top.buts.can -text "Cancel" -command mktagcan
3339 grid $top.buts.gen $top.buts.can
3340 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3341 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3342 grid $top.buts - -pady 10 -sticky ew
3347 global mktagtop env tagids idtags
3349 set id [$mktagtop.sha1 get]
3350 set tag [$mktagtop.tag get]
3352 error_popup "No tag name specified"
3355 if {[info exists tagids($tag)]} {
3356 error_popup "Tag \"$tag\" already exists"
3361 set fname [file join $dir "refs/tags" $tag]
3362 set f [open $fname w]
3366 error_popup "Error creating tag: $err"
3370 set tagids($tag) $id
3371 lappend idtags($id) $tag
3375 proc redrawtags {id} {
3376 global canv linehtag idline idpos selectedline
3378 if {![info exists idline($id)]} return
3379 $canv delete tag.$id
3380 set xt [eval drawtags $id $idpos($id)]
3381 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3382 if {[info exists selectedline] && $selectedline == $idline($id)} {
3383 selectline $selectedline 0
3390 catch {destroy $mktagtop}
3399 proc writecommit {} {
3400 global rowmenuid wrcomtop commitinfo wrcomcmd
3402 set top .writecommit
3404 catch {destroy $top}
3406 label $top.title -text "Write commit to file"
3407 grid $top.title - -pady 10
3408 label $top.id -text "ID:"
3409 entry $top.sha1 -width 40 -relief flat
3410 $top.sha1 insert 0 $rowmenuid
3411 $top.sha1 conf -state readonly
3412 grid $top.id $top.sha1 -sticky w
3413 entry $top.head -width 60 -relief flat
3414 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3415 $top.head conf -state readonly
3416 grid x $top.head -sticky w
3417 label $top.clab -text "Command:"
3418 entry $top.cmd -width 60 -textvariable wrcomcmd
3419 grid $top.clab $top.cmd -sticky w -pady 10
3420 label $top.flab -text "Output file:"
3421 entry $top.fname -width 60
3422 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3423 grid $top.flab $top.fname -sticky w
3425 button $top.buts.gen -text "Write" -command wrcomgo
3426 button $top.buts.can -text "Cancel" -command wrcomcan
3427 grid $top.buts.gen $top.buts.can
3428 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3429 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3430 grid $top.buts - -pady 10 -sticky ew
3437 set id [$wrcomtop.sha1 get]
3438 set cmd "echo $id | [$wrcomtop.cmd get]"
3439 set fname [$wrcomtop.fname get]
3440 if {[catch {exec sh -c $cmd >$fname &} err]} {
3441 error_popup "Error writing commit: $err"
3443 catch {destroy $wrcomtop}
3450 catch {destroy $wrcomtop}
3454 proc listrefs {id} {
3455 global idtags idheads idotherrefs
3458 if {[info exists idtags($id)]} {
3462 if {[info exists idheads($id)]} {
3466 if {[info exists idotherrefs($id)]} {
3467 set z $idotherrefs($id)
3469 return [list $x $y $z]
3472 proc rereadrefs {} {
3473 global idtags idheads idotherrefs
3474 global tagids headids otherrefids
3476 set refids [concat [array names idtags] \
3477 [array names idheads] [array names idotherrefs]]
3478 foreach id $refids {
3479 if {![info exists ref($id)]} {
3480 set ref($id) [listrefs $id]
3483 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
3487 set refids [lsort -unique [concat $refids [array names idtags] \
3488 [array names idheads] [array names idotherrefs]]]
3489 foreach id $refids {
3490 set v [listrefs $id]
3491 if {![info exists ref($id)] || $ref($id) != $v} {
3506 set diffopts "-U 5 -p"
3507 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3509 set mainfont {Helvetica 9}
3510 set textfont {Courier 9}
3511 set findmergefiles 0
3516 set colors {green red blue magenta darkgrey brown orange}
3518 catch {source ~/.gitk}
3520 set namefont $mainfont
3522 lappend namefont bold
3527 switch -regexp -- $arg {
3529 "^-b" { set boldnames 1 }
3530 "^-d" { set datemode 1 }
3532 lappend revtreeargs $arg
3547 getcommits $revtreeargs