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
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 if {![regexp
{^
([0-9a-f]{40})\n} $cmit match id
]} {
101 if {[string length
$shortcmit] > 80} {
102 set shortcmit
"[string range $shortcmit 0 80]..."
104 error_popup
"Can't parse git-rev-list output: {$shortcmit}"
107 set cmit
[string range
$cmit 41 end
]
109 set commitlisted
($id) 1
110 parsecommit
$id $cmit 1
112 if {[clock clicks
-milliseconds] >= $nextupdate} {
115 while {$redisplaying} {
119 set phase
"getcommits"
120 foreach id
$commits {
123 if {[clock clicks
-milliseconds] >= $nextupdate} {
132 proc doupdate
{reading
} {
133 global commfd nextupdate numcommits ncmupdate
136 fileevent
$commfd readable
{}
139 set nextupdate
[expr {[clock clicks
-milliseconds] + 100}]
140 if {$numcommits < 100} {
141 set ncmupdate
[expr {$numcommits + 1}]
142 } elseif
{$numcommits < 10000} {
143 set ncmupdate
[expr {$numcommits + 10}]
145 set ncmupdate
[expr {$numcommits + 100}]
148 fileevent
$commfd readable
[list getcommitlines
$commfd]
152 proc readcommit
{id
} {
153 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
154 parsecommit
$id $contents 0
157 proc parsecommit
{id contents listed
} {
158 global commitinfo children nchildren parents nparents cdate ncleft
167 if {![info exists nchildren
($id)]} {
174 foreach line
[split $contents "\n"] {
179 set tag
[lindex
$line 0]
180 if {$tag == "parent"} {
181 set p
[lindex
$line 1]
182 if {![info exists nchildren
($p)]} {
187 lappend parents
($id) $p
189 # sometimes we get a commit that lists a parent twice...
190 if {$listed && [lsearch
-exact $children($p) $id] < 0} {
191 lappend children
($p) $id
195 } elseif
{$tag == "author"} {
196 set x
[expr {[llength
$line] - 2}]
197 set audate
[lindex
$line $x]
198 set auname
[lrange
$line 1 [expr {$x - 1}]]
199 } elseif
{$tag == "committer"} {
200 set x
[expr {[llength
$line] - 2}]
201 set comdate
[lindex
$line $x]
202 set comname
[lrange
$line 1 [expr {$x - 1}]]
206 if {$comment == {}} {
207 set headline
[string trim
$line]
212 # git-rev-list indents the comment by 4 spaces;
213 # if we got this via git-cat-file, add the indentation
220 set audate
[clock format
$audate -format "%Y-%m-%d %H:%M:%S"]
222 if {$comdate != {}} {
223 set cdate
($id) $comdate
224 set comdate
[clock format
$comdate -format "%Y-%m-%d %H:%M:%S"]
226 set commitinfo
($id) [list
$headline $auname $audate \
227 $comname $comdate $comment]
231 global tagids idtags headids idheads
232 set tags
[glob
-nocomplain -types f
[gitdir
]/refs
/tags
/*]
237 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
238 set direct
[file tail $f]
239 set tagids
($direct) $id
240 lappend idtags
($id) $direct
241 set contents
[split [exec git-cat-file tag
$id] "\n"]
245 foreach l
$contents {
247 switch
-- [lindex
$l 0] {
248 "object" {set obj
[lindex
$l 1]}
249 "type" {set type [lindex
$l 1]}
250 "tag" {set tag
[string range
$l 4 end
]}
253 if {$obj != {} && $type == "commit" && $tag != {}} {
254 set tagids
($tag) $obj
255 lappend idtags
($obj) $tag
261 set heads
[glob
-nocomplain -types f
[gitdir
]/refs
/heads
/*]
265 set line
[read $fd 40]
266 if {[regexp
{^
[0-9a-f]{40}} $line id
]} {
267 set head [file tail $f]
268 set headids
($head) $line
269 lappend idheads
($line) $head
276 proc error_popup msg
{
280 message
$w.m
-text $msg -justify center
-aspect 400
281 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
282 button
$w.ok
-text OK
-command "destroy $w"
283 pack
$w.ok
-side bottom
-fill x
284 bind $w <Visibility
> "grab $w; focus $w"
289 global canv canv2 canv3 linespc charspc ctext cflist textfont
290 global findtype findtypemenu findloc findstring fstring geometry
291 global entries sha1entry sha1string sha1but
292 global maincursor textcursor curtextcursor
293 global rowctxmenu gaudydiff mergemax
296 .bar add cascade
-label "File" -menu .bar.
file
298 .bar.
file add
command -label "Quit" -command doquit
300 .bar add cascade
-label "Help" -menu .bar.
help
301 .bar.
help add
command -label "About gitk" -command about
302 . configure
-menu .bar
304 if {![info exists geometry
(canv1
)]} {
305 set geometry
(canv1
) [expr 45 * $charspc]
306 set geometry
(canv2
) [expr 30 * $charspc]
307 set geometry
(canv3
) [expr 15 * $charspc]
308 set geometry
(canvh
) [expr 25 * $linespc + 4]
309 set geometry
(ctextw
) 80
310 set geometry
(ctexth
) 30
311 set geometry
(cflistw
) 30
313 panedwindow .ctop
-orient vertical
314 if {[info exists geometry
(width
)]} {
315 .ctop conf
-width $geometry(width
) -height $geometry(height
)
316 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
317 set geometry
(ctexth
) [expr {($texth - 8) /
318 [font metrics
$textfont -linespace]}]
322 pack .ctop.top.bar
-side bottom
-fill x
323 set cscroll .ctop.top.csb
324 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
325 pack
$cscroll -side right
-fill y
326 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
327 pack .ctop.top.clist
-side top
-fill both
-expand 1
329 set canv .ctop.top.clist.canv
330 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
332 -yscrollincr $linespc -yscrollcommand "$cscroll set"
333 .ctop.top.clist add
$canv
334 set canv2 .ctop.top.clist.canv2
335 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
336 -bg white
-bd 0 -yscrollincr $linespc
337 .ctop.top.clist add
$canv2
338 set canv3 .ctop.top.clist.canv3
339 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
340 -bg white
-bd 0 -yscrollincr $linespc
341 .ctop.top.clist add
$canv3
342 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
344 set sha1entry .ctop.top.bar.sha1
345 set entries
$sha1entry
346 set sha1but .ctop.top.bar.sha1label
347 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
348 -command gotocommit
-width 8
349 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
350 pack .ctop.top.bar.sha1label
-side left
351 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
352 trace add variable sha1string
write sha1change
353 pack
$sha1entry -side left
-pady 2
355 image create bitmap bm-left
-data {
356 #define left_width 16
357 #define left_height 16
358 static unsigned char left_bits
[] = {
359 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
360 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
361 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
363 image create bitmap bm-right
-data {
364 #define right_width 16
365 #define right_height 16
366 static unsigned char right_bits
[] = {
367 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
368 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
369 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
371 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
372 -state disabled
-width 26
373 pack .ctop.top.bar.leftbut
-side left
-fill y
374 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
375 -state disabled
-width 26
376 pack .ctop.top.bar.rightbut
-side left
-fill y
378 button .ctop.top.bar.findbut
-text "Find" -command dofind
379 pack .ctop.top.bar.findbut
-side left
381 set fstring .ctop.top.bar.findstring
382 lappend entries
$fstring
383 entry
$fstring -width 30 -font $textfont -textvariable findstring
384 pack
$fstring -side left
-expand 1 -fill x
386 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
387 findtype Exact IgnCase Regexp
]
388 set findloc
"All fields"
389 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
390 Comments Author Committer Files Pickaxe
391 pack .ctop.top.bar.findloc
-side right
392 pack .ctop.top.bar.findtype
-side right
393 # for making sure type==Exact whenever loc==Pickaxe
394 trace add variable findloc
write findlocchange
396 panedwindow .ctop.cdet
-orient horizontal
398 frame .ctop.cdet.left
399 set ctext .ctop.cdet.left.ctext
400 text
$ctext -bg white
-state disabled
-font $textfont \
401 -width $geometry(ctextw
) -height $geometry(ctexth
) \
402 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
403 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
404 pack .ctop.cdet.left.sb
-side right
-fill y
405 pack
$ctext -side left
-fill both
-expand 1
406 .ctop.cdet add .ctop.cdet.left
408 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
410 $ctext tag conf hunksep
-back blue
-fore white
411 $ctext tag conf d0
-back "#ff8080"
412 $ctext tag conf d1
-back green
414 $ctext tag conf hunksep
-fore blue
415 $ctext tag conf d0
-fore red
416 $ctext tag conf d1
-fore "#00a000"
417 $ctext tag conf m0
-fore red
418 $ctext tag conf m1
-fore blue
419 $ctext tag conf m2
-fore green
420 $ctext tag conf m3
-fore purple
421 $ctext tag conf
m4 -fore brown
422 $ctext tag conf mmax
-fore darkgrey
424 $ctext tag conf mresult
-font [concat
$textfont bold
]
425 $ctext tag conf msep
-font [concat
$textfont bold
]
426 $ctext tag conf found
-back yellow
429 frame .ctop.cdet.right
430 set cflist .ctop.cdet.right.cfiles
431 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
432 -yscrollcommand ".ctop.cdet.right.sb set"
433 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
434 pack .ctop.cdet.right.sb
-side right
-fill y
435 pack
$cflist -side left
-fill both
-expand 1
436 .ctop.cdet add .ctop.cdet.right
437 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
439 pack .ctop
-side top
-fill both
-expand 1
441 bindall
<1> {selcanvline
%W
%x
%y
}
442 #bindall <B1-Motion> {selcanvline %W %x %y}
443 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
444 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
445 bindall
<2> "allcanvs scan mark 0 %y"
446 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
447 bind .
<Key-Up
> "selnextline -1"
448 bind .
<Key-Down
> "selnextline 1"
449 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
450 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
451 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
452 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
453 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
454 bindkey p
"selnextline -1"
455 bindkey n
"selnextline 1"
456 bindkey b
"$ctext yview scroll -1 pages"
457 bindkey d
"$ctext yview scroll 18 units"
458 bindkey u
"$ctext yview scroll -18 units"
459 bindkey
/ {findnext
1}
460 bindkey
<Key-Return
> {findnext
0}
463 bind .
<Control-q
> doquit
464 bind .
<Control-f
> dofind
465 bind .
<Control-g
> {findnext
0}
466 bind .
<Control-r
> findprev
467 bind .
<Control-equal
> {incrfont
1}
468 bind .
<Control-KP_Add
> {incrfont
1}
469 bind .
<Control-minus
> {incrfont
-1}
470 bind .
<Control-KP_Subtract
> {incrfont
-1}
471 bind $cflist <<ListboxSelect>> listboxsel
472 bind . <Destroy> {savestuff %W}
473 bind . <Button-1> "click %W"
474 bind $fstring <Key-Return> dofind
475 bind $sha1entry <Key-Return> gotocommit
476 bind $sha1entry <<PasteSelection>> clearsha1
478 set maincursor [. cget -cursor]
479 set textcursor [$ctext cget -cursor]
480 set curtextcursor $textcursor
482 set rowctxmenu .rowctxmenu
483 menu $rowctxmenu -tearoff 0
484 $rowctxmenu add command -label "Diff this -> selected" \
485 -command {diffvssel 0}
486 $rowctxmenu add command -label "Diff selected -> this" \
487 -command {diffvssel 1}
488 $rowctxmenu add command -label "Make patch" -command mkpatch
489 $rowctxmenu add command -label "Create tag" -command mktag
490 $rowctxmenu add command -label "Write commit to file" -command writecommit
493 # when we make a key binding for the toplevel, make sure
494 # it doesn't get triggered when that key is pressed in the
495 # find string entry widget.
496 proc bindkey {ev script} {
499 set escript [bind Entry $ev]
500 if {$escript == {}} {
501 set escript [bind Entry <Key>]
504 bind $e $ev "$escript; break"
508 # set the focus back to the toplevel for any click outside
519 global canv canv2 canv3 ctext cflist mainfont textfont
520 global stuffsaved findmergefiles gaudydiff maxgraphpct
522 if {$stuffsaved} return
523 if {![winfo viewable .]} return
525 set f [open "~/.gitk-new" w]
526 puts $f [list set mainfont $mainfont]
527 puts $f [list set textfont $textfont]
528 puts $f [list set findmergefiles $findmergefiles]
529 puts $f [list set gaudydiff $gaudydiff]
530 puts $f [list set maxgraphpct $maxgraphpct]
531 puts $f "set geometry(width) [winfo width .ctop]"
532 puts $f "set geometry(height) [winfo height .ctop]"
533 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
534 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
535 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
536 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
537 set wid [expr {([winfo width $ctext] - 8) \
538 / [font measure $textfont "0"]}]
539 puts $f "set geometry(ctextw) $wid"
540 set wid [expr {([winfo width $cflist] - 11) \
541 / [font measure [$cflist cget -font] "0"]}]
542 puts $f "set geometry(cflistw) $wid"
544 file rename -force "~/.gitk-new" "~/.gitk"
549 proc resizeclistpanes {win w} {
551 if [info exists oldwidth($win)] {
552 set s0 [$win sash coord 0]
553 set s1 [$win sash coord 1]
555 set sash0 [expr {int($w/2 - 2)}]
556 set sash1 [expr {int($w*5/6 - 2)}]
558 set factor [expr {1.0 * $w / $oldwidth($win)}]
559 set sash0 [expr {int($factor * [lindex $s0 0])}]
560 set sash1 [expr {int($factor * [lindex $s1 0])}]
564 if {$sash1 < $sash0 + 20} {
565 set sash1 [expr $sash0 + 20]
567 if {$sash1 > $w - 10} {
568 set sash1 [expr $w - 10]
569 if {$sash0 > $sash1 - 20} {
570 set sash0 [expr $sash1 - 20]
574 $win sash place 0 $sash0 [lindex $s0 1]
575 $win sash place 1 $sash1 [lindex $s1 1]
577 set oldwidth($win) $w
580 proc resizecdetpanes {win w} {
582 if [info exists oldwidth($win)] {
583 set s0 [$win sash coord 0]
585 set sash0 [expr {int($w*3/4 - 2)}]
587 set factor [expr {1.0 * $w / $oldwidth($win)}]
588 set sash0 [expr {int($factor * [lindex $s0 0])}]
592 if {$sash0 > $w - 15} {
593 set sash0 [expr $w - 15]
596 $win sash place 0 $sash0 [lindex $s0 1]
598 set oldwidth($win) $w
602 global canv canv2 canv3
608 proc bindall {event action} {
609 global canv canv2 canv3
610 bind $canv $event $action
611 bind $canv2 $event $action
612 bind $canv3 $event $action
617 if {[winfo exists $w]} {
622 wm title $w "About gitk"
626 Copyright © 2005 Paul Mackerras
628 Use and redistribute under the terms of the GNU General Public License} \
629 -justify center -aspect 400
630 pack $w.m -side top -fill x -padx 20 -pady 20
631 button $w.ok -text Close -command "destroy $w"
632 pack $w.ok -side bottom
635 proc assigncolor {id} {
636 global commitinfo colormap commcolors colors nextcolor
637 global parents nparents children nchildren
638 global cornercrossings crossings
640 if [info exists colormap($id)] return
641 set ncolors [llength $colors]
642 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
643 set child [lindex $children($id) 0]
644 if {[info exists colormap($child)]
645 && $nparents($child) == 1} {
646 set colormap($id) $colormap($child)
651 if {[info exists cornercrossings($id)]} {
652 foreach x $cornercrossings($id) {
653 if {[info exists colormap($x)]
654 && [lsearch -exact $badcolors $colormap($x)] < 0} {
655 lappend badcolors $colormap($x)
658 if {[llength $badcolors] >= $ncolors} {
662 set origbad $badcolors
663 if {[llength $badcolors] < $ncolors - 1} {
664 if {[info exists crossings($id)]} {
665 foreach x $crossings($id) {
666 if {[info exists colormap($x)]
667 && [lsearch -exact $badcolors $colormap($x)] < 0} {
668 lappend badcolors $colormap($x)
671 if {[llength $badcolors] >= $ncolors} {
672 set badcolors $origbad
675 set origbad $badcolors
677 if {[llength $badcolors] < $ncolors - 1} {
678 foreach child $children($id) {
679 if {[info exists colormap($child)]
680 && [lsearch -exact $badcolors $colormap($child)] < 0} {
681 lappend badcolors $colormap($child)
683 if {[info exists parents($child)]} {
684 foreach p $parents($child) {
685 if {[info exists colormap($p)]
686 && [lsearch -exact $badcolors $colormap($p)] < 0} {
687 lappend badcolors $colormap($p)
692 if {[llength $badcolors] >= $ncolors} {
693 set badcolors $origbad
696 for {set i 0} {$i <= $ncolors} {incr i} {
697 set c [lindex $colors $nextcolor]
698 if {[incr nextcolor] >= $ncolors} {
701 if {[lsearch -exact $badcolors $c]} break
707 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
708 global mainline sidelines
709 global nchildren ncleft
716 set lthickness [expr {int($linespc / 9) + 1}]
717 catch {unset mainline}
718 catch {unset sidelines}
719 foreach id [array names nchildren] {
720 set ncleft($id) $nchildren($id)
724 proc bindline {t id} {
727 $canv bind $t <Enter> "lineenter %x %y $id"
728 $canv bind $t <Motion> "linemotion %x %y $id"
729 $canv bind $t <Leave> "lineleave $id"
730 $canv bind $t <Button-1> "lineclick %x %y $id 1"
733 proc drawcommitline {level} {
734 global parents children nparents nchildren todo
735 global canv canv2 canv3 mainfont namefont canvy linespc
736 global lineid linehtag linentag linedtag commitinfo
737 global colormap numcommits currentparents dupparents
738 global oldlevel oldnlines oldtodo
739 global idtags idline idheads
740 global lineno lthickness mainline sidelines
741 global commitlisted rowtextx idpos
745 set id [lindex $todo $level]
746 set lineid($lineno) $id
747 set idline($id) $lineno
748 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
749 if {![info exists commitinfo($id)]} {
751 if {![info exists commitinfo($id)]} {
752 set commitinfo($id) {"No commit information available"}
757 set currentparents {}
759 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
760 foreach p $parents($id) {
761 if {[lsearch -exact $currentparents $p] < 0} {
762 lappend currentparents $p
764 # remember that this parent was listed twice
765 lappend dupparents $p
769 set x [xcoord $level $level $lineno]
771 set canvy [expr $canvy + $linespc]
772 allcanvs conf -scrollregion \
773 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
774 if {[info exists mainline($id)]} {
775 lappend mainline($id) $x $y1
776 set t [$canv create line $mainline($id) \
777 -width $lthickness -fill $colormap($id)]
781 if {[info exists sidelines($id)]} {
782 foreach ls $sidelines($id) {
783 set coords [lindex $ls 0]
784 set thick [lindex $ls 1]
785 set t [$canv create line $coords -fill $colormap($id) \
786 -width [expr {$thick * $lthickness}]]
791 set orad [expr {$linespc / 3}]
792 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
793 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
794 -fill $ofill -outline black -width 1]
796 $canv bind $t <1> {selcanvline {} %x %y}
797 set xt [xcoord [llength $todo] $level $lineno]
798 if {[llength $currentparents] > 2} {
799 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
801 set rowtextx($lineno) $xt
802 set idpos($id) [list $x $xt $y1]
803 if {[info exists idtags($id)] || [info exists idheads($id)]} {
804 set xt [drawtags $id $x $xt $y1]
806 set headline [lindex $commitinfo($id) 0]
807 set name [lindex $commitinfo($id) 1]
808 set date [lindex $commitinfo($id) 2]
809 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
810 -text $headline -font $mainfont ]
811 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
812 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
813 -text $name -font $namefont]
814 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
815 -text $date -font $mainfont]
818 proc drawtags {id x xt y1} {
819 global idtags idheads
820 global linespc lthickness
825 if {[info exists idtags($id)]} {
826 set marks $idtags($id)
827 set ntags [llength $marks]
829 if {[info exists idheads($id)]} {
830 set marks [concat $marks $idheads($id)]
836 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
837 set yt [expr $y1 - 0.5 * $linespc]
838 set yb [expr $yt + $linespc - 1]
842 set wid [font measure $mainfont $tag]
845 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
847 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
848 -width $lthickness -fill black -tags tag.$id]
850 foreach tag $marks x $xvals wid $wvals {
851 set xl [expr $x + $delta]
852 set xr [expr $x + $delta + $wid + $lthickness]
853 if {[incr ntags -1] >= 0} {
855 $canv create polygon $x [expr $yt + $delta] $xl $yt\
856 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
857 -width 1 -outline black -fill yellow -tags tag.$id
860 set xl [expr $xl - $delta/2]
861 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
862 -width 1 -outline black -fill green -tags tag.$id
864 $canv create text $xl $y1 -anchor w -text $tag \
865 -font $mainfont -tags tag.$id
870 proc updatetodo {level noshortcut} {
871 global currentparents ncleft todo
872 global mainline oldlevel oldtodo oldnlines
873 global canvy linespc mainline
874 global commitinfo lineno xspc1
878 set oldnlines [llength $todo]
879 if {!$noshortcut && [llength $currentparents] == 1} {
880 set p [lindex $currentparents 0]
881 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
883 set x [xcoord $level $level $lineno]
884 set y [expr $canvy - $linespc]
885 set mainline($p) [list $x $y]
886 set todo [lreplace $todo $level $level $p]
887 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
892 set todo [lreplace $todo $level $level]
894 foreach p $currentparents {
896 set k [lsearch -exact $todo $p]
898 set todo [linsert $todo $i $p]
905 proc notecrossings {id lo hi corner} {
906 global oldtodo crossings cornercrossings
908 for {set i $lo} {[incr i] < $hi} {} {
909 set p [lindex $oldtodo $i]
910 if {$p == {}} continue
912 if {![info exists cornercrossings($id)]
913 || [lsearch -exact $cornercrossings($id) $p] < 0} {
914 lappend cornercrossings($id) $p
916 if {![info exists cornercrossings($p)]
917 || [lsearch -exact $cornercrossings($p) $id] < 0} {
918 lappend cornercrossings($p) $id
921 if {![info exists crossings($id)]
922 || [lsearch -exact $crossings($id) $p] < 0} {
923 lappend crossings($id) $p
925 if {![info exists crossings($p)]
926 || [lsearch -exact $crossings($p) $id] < 0} {
927 lappend crossings($p) $id
933 proc xcoord {i level ln} {
934 global canvx0 xspc1 xspc2
936 set x [expr {$canvx0 + $i * $xspc1($ln)}]
937 if {$i > 0 && $i == $level} {
938 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
939 } elseif {$i > $level} {
940 set x [expr {$x + $xspc2 - $xspc1($ln)}]
945 proc drawslants {level} {
946 global canv mainline sidelines canvx0 canvy xspc1 xspc2 lthickness
947 global oldlevel oldtodo todo currentparents dupparents
948 global lthickness linespc canvy colormap lineno geometry
951 # decide on the line spacing for the next line
952 set lj [expr {$lineno + 1}]
953 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
954 set n [llength $todo]
955 if {$n <= 1 || $canvx0 + $n * $xspc2 <= $maxw} {
956 set xspc1($lj) $xspc2
958 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($n - 1)}]
959 if {$xspc1($lj) < $lthickness} {
960 set xspc1($lj) $lthickness
964 set y1 [expr $canvy - $linespc]
967 foreach id $oldtodo {
969 if {$id == {}} continue
970 set xi [xcoord $i $oldlevel $lineno]
971 if {$i == $oldlevel} {
972 foreach p $currentparents {
973 set j [lsearch -exact $todo $p]
974 set coords [list $xi $y1]
975 set xj [xcoord $j $level $lj]
976 if {$xj < $xi - $linespc} {
977 lappend coords [expr {$xj + $linespc}] $y1
978 notecrossings $p $j $i [expr {$j + 1}]
979 } elseif {$xj > $xi + $linespc} {
980 lappend coords [expr {$xj - $linespc}] $y1
981 notecrossings $p $i $j [expr {$j - 1}]
983 if {[lsearch -exact $dupparents $p] >= 0} {
984 # draw a double-width line to indicate the doubled parent
985 lappend coords $xj $y2
986 lappend sidelines($p) [list $coords 2]
987 if {![info exists mainline($p)]} {
988 set mainline($p) [list $xj $y2]
991 # normal case, no parent duplicated
993 set dx [expr {abs($xi - $xj)}]
994 if {0 && $dx < $linespc} {
995 set yb [expr {$y1 + $dx}]
997 if {![info exists mainline($p)]} {
999 lappend coords $xj $yb
1001 set mainline($p) $coords
1003 lappend coords $xj $yb
1005 lappend coords $xj $y2
1007 lappend sidelines($p) [list $coords 1]
1013 if {[lindex $todo $i] != $id} {
1014 set j [lsearch -exact $todo $id]
1016 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1017 || ($oldlevel <= $i && $i <= $level)
1018 || ($level <= $i && $i <= $oldlevel)} {
1019 set xj [xcoord $j $level $lj]
1020 set dx [expr {abs($xi - $xj)}]
1022 if {0 && $dx < $linespc} {
1023 set yb [expr {$y1 + $dx}]
1025 lappend mainline($id) $xi $y1 $xj $yb
1031 proc decidenext {{noread 0}} {
1032 global parents children nchildren ncleft todo
1033 global canv canv2 canv3 mainfont namefont canvy linespc
1034 global datemode cdate
1036 global currentparents oldlevel oldnlines oldtodo
1037 global lineno lthickness
1039 # remove the null entry if present
1040 set nullentry [lsearch -exact $todo {}]
1041 if {$nullentry >= 0} {
1042 set todo [lreplace $todo $nullentry $nullentry]
1045 # choose which one to do next time around
1046 set todol [llength $todo]
1049 for {set k $todol} {[incr k -1] >= 0} {} {
1050 set p [lindex $todo $k]
1051 if {$ncleft($p) == 0} {
1053 if {![info exists commitinfo($p)]} {
1059 if {$latest == {} || $cdate($p) > $latest} {
1061 set latest $cdate($p)
1071 puts "ERROR: none of the pending commits can be done yet:"
1073 puts " $p ($ncleft($p))"
1079 # If we are reducing, put in a null entry
1080 if {$todol < $oldnlines} {
1081 if {$nullentry >= 0} {
1084 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1094 set todo [linsert $todo $i {}]
1103 proc drawcommit {id} {
1104 global phase todo nchildren datemode nextupdate
1105 global startcommits numcommits ncmupdate
1107 if {$phase != "incrdraw"} {
1110 set startcommits $id
1113 updatetodo 0 $datemode
1115 if {$nchildren($id) == 0} {
1117 lappend startcommits $id
1119 set level [decidenext 1]
1120 if {$level == {} || $id != [lindex $todo $level]} {
1125 drawcommitline $level
1126 if {[updatetodo $level $datemode]} {
1127 set level [decidenext 1]
1128 if {$level == {}} break
1130 set id [lindex $todo $level]
1131 if {![info exists commitlisted($id)]} {
1134 if {[clock clicks -milliseconds] >= $nextupdate
1135 && $numcommits >= $ncmupdate} {
1143 proc finishcommits {} {
1146 global canv mainfont ctext maincursor textcursor
1148 if {$phase != "incrdraw"} {
1150 $canv create text 3 3 -anchor nw -text "No commits selected" \
1151 -font $mainfont -tags textitems
1154 set level [decidenext]
1156 drawrest $level [llength $startcommits]
1158 . config -cursor $maincursor
1159 settextcursor $textcursor
1162 # Don't change the text pane cursor if it is currently the hand cursor,
1163 # showing that we are over a sha1 ID link.
1164 proc settextcursor {c} {
1165 global ctext curtextcursor
1167 if {[$ctext cget -cursor] == $curtextcursor} {
1168 $ctext config -cursor $c
1170 set curtextcursor $c
1174 global nextupdate startmsecs startcommits todo ncmupdate
1176 if {$startcommits == {}} return
1177 set startmsecs [clock clicks -milliseconds]
1178 set nextupdate [expr $startmsecs + 100]
1181 set todo [lindex $startcommits 0]
1185 proc drawrest {level startix} {
1186 global phase stopped redisplaying selectedline
1187 global datemode currentparents todo
1188 global numcommits ncmupdate
1189 global nextupdate startmsecs startcommits idline
1193 set startid [lindex $startcommits $startix]
1195 if {$startid != {}} {
1196 set startline $idline($startid)
1200 drawcommitline $level
1201 set hard [updatetodo $level $datemode]
1202 if {$numcommits == $startline} {
1203 lappend todo $startid
1206 set startid [lindex $startcommits $startix]
1208 if {$startid != {}} {
1209 set startline $idline($startid)
1213 set level [decidenext]
1214 if {$level < 0} break
1217 if {[clock clicks -milliseconds] >= $nextupdate
1218 && $numcommits >= $ncmupdate} {
1224 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1225 #puts "overall $drawmsecs ms for $numcommits commits"
1226 if {$redisplaying} {
1227 if {$stopped == 0 && [info exists selectedline]} {
1228 selectline $selectedline 0
1230 if {$stopped == 1} {
1232 after idle drawgraph
1239 proc findmatches {f} {
1240 global findtype foundstring foundstrlen
1241 if {$findtype == "Regexp"} {
1242 set matches [regexp -indices -all -inline $foundstring $f]
1244 if {$findtype == "IgnCase"} {
1245 set str [string tolower $f]
1251 while {[set j [string first $foundstring $str $i]] >= 0} {
1252 lappend matches [list $j [expr $j+$foundstrlen-1]]
1253 set i [expr $j + $foundstrlen]
1260 global findtype findloc findstring markedmatches commitinfo
1261 global numcommits lineid linehtag linentag linedtag
1262 global mainfont namefont canv canv2 canv3 selectedline
1263 global matchinglines foundstring foundstrlen
1268 set matchinglines {}
1269 if {$findloc == "Pickaxe"} {
1273 if {$findtype == "IgnCase"} {
1274 set foundstring [string tolower $findstring]
1276 set foundstring $findstring
1278 set foundstrlen [string length $findstring]
1279 if {$foundstrlen == 0} return
1280 if {$findloc == "Files"} {
1284 if {![info exists selectedline]} {
1287 set oldsel $selectedline
1290 set fldtypes {Headline Author Date Committer CDate Comment}
1291 for {set l 0} {$l < $numcommits} {incr l} {
1293 set info $commitinfo($id)
1295 foreach f $info ty $fldtypes {
1296 if {$findloc != "All fields" && $findloc != $ty} {
1299 set matches [findmatches $f]
1300 if {$matches == {}} continue
1302 if {$ty == "Headline"} {
1303 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1304 } elseif {$ty == "Author"} {
1305 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1306 } elseif {$ty == "Date"} {
1307 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1311 lappend matchinglines $l
1312 if {!$didsel && $l > $oldsel} {
1318 if {$matchinglines == {}} {
1320 } elseif {!$didsel} {
1321 findselectline [lindex $matchinglines 0]
1325 proc findselectline {l} {
1326 global findloc commentend ctext
1328 if {$findloc == "All fields" || $findloc == "Comments"} {
1329 # highlight the matches in the comments
1330 set f [$ctext get 1.0 $commentend]
1331 set matches [findmatches $f]
1332 foreach match $matches {
1333 set start [lindex $match 0]
1334 set end [expr [lindex $match 1] + 1]
1335 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1340 proc findnext {restart} {
1341 global matchinglines selectedline
1342 if {![info exists matchinglines]} {
1348 if {![info exists selectedline]} return
1349 foreach l $matchinglines {
1350 if {$l > $selectedline} {
1359 global matchinglines selectedline
1360 if {![info exists matchinglines]} {
1364 if {![info exists selectedline]} return
1366 foreach l $matchinglines {
1367 if {$l >= $selectedline} break
1371 findselectline $prev
1377 proc findlocchange {name ix op} {
1378 global findloc findtype findtypemenu
1379 if {$findloc == "Pickaxe"} {
1385 $findtypemenu entryconf 1 -state $state
1386 $findtypemenu entryconf 2 -state $state
1389 proc stopfindproc {{done 0}} {
1390 global findprocpid findprocfile findids
1391 global ctext findoldcursor phase maincursor textcursor
1392 global findinprogress
1394 catch {unset findids}
1395 if {[info exists findprocpid]} {
1397 catch {exec kill $findprocpid}
1399 catch {close $findprocfile}
1402 if {[info exists findinprogress]} {
1403 unset findinprogress
1404 if {$phase != "incrdraw"} {
1405 . config -cursor $maincursor
1406 settextcursor $textcursor
1411 proc findpatches {} {
1412 global findstring selectedline numcommits
1413 global findprocpid findprocfile
1414 global finddidsel ctext lineid findinprogress
1415 global findinsertpos
1417 if {$numcommits == 0} return
1419 # make a list of all the ids to search, starting at the one
1420 # after the selected line (if any)
1421 if {[info exists selectedline]} {
1427 for {set i 0} {$i < $numcommits} {incr i} {
1428 if {[incr l] >= $numcommits} {
1431 append inputids $lineid($l) "\n"
1435 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1438 error_popup "Error starting search process: $err"
1442 set findinsertpos end
1444 set findprocpid [pid $f]
1445 fconfigure $f -blocking 0
1446 fileevent $f readable readfindproc
1448 . config -cursor watch
1450 set findinprogress 1
1453 proc readfindproc {} {
1454 global findprocfile finddidsel
1455 global idline matchinglines findinsertpos
1457 set n [gets $findprocfile line]
1459 if {[eof $findprocfile]} {
1467 if {![regexp {^[0-9a-f]{40}} $line id]} {
1468 error_popup "Can't parse git-diff-tree output: $line"
1472 if {![info exists idline($id)]} {
1473 puts stderr "spurious id: $id"
1480 proc insertmatch {l id} {
1481 global matchinglines findinsertpos finddidsel
1483 if {$findinsertpos == "end"} {
1484 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1485 set matchinglines [linsert $matchinglines 0 $l]
1488 lappend matchinglines $l
1491 set matchinglines [linsert $matchinglines $findinsertpos $l]
1502 global selectedline numcommits lineid ctext
1503 global ffileline finddidsel parents nparents
1504 global findinprogress findstartline findinsertpos
1505 global treediffs fdiffids fdiffsneeded fdiffpos
1506 global findmergefiles
1508 if {$numcommits == 0} return
1510 if {[info exists selectedline]} {
1511 set l [expr {$selectedline + 1}]
1516 set findstartline $l
1521 if {$findmergefiles || $nparents($id) == 1} {
1522 foreach p $parents($id) {
1523 if {![info exists treediffs([list $id $p])]} {
1524 append diffsneeded "$id $p\n"
1525 lappend fdiffsneeded [list $id $p]
1529 if {[incr l] >= $numcommits} {
1532 if {$l == $findstartline} break
1535 # start off a git-diff-tree process if needed
1536 if {$diffsneeded ne {}} {
1538 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1540 error_popup "Error starting search process: $err"
1543 catch {unset fdiffids}
1545 fconfigure $df -blocking 0
1546 fileevent $df readable [list readfilediffs $df]
1550 set findinsertpos end
1552 set p [lindex $parents($id) 0]
1553 . config -cursor watch
1555 set findinprogress 1
1556 findcont [list $id $p]
1560 proc readfilediffs {df} {
1561 global findids fdiffids fdiffs
1563 set n [gets $df line]
1567 if {[catch {close $df} err]} {
1570 error_popup "Error in git-diff-tree: $err"
1571 } elseif {[info exists findids]} {
1575 error_popup "Couldn't find diffs for {$ids}"
1580 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1581 # start of a new string of diffs
1583 set fdiffids [list $id $p]
1585 } elseif {[string match ":*" $line]} {
1586 lappend fdiffs [lindex $line 5]
1590 proc donefilediff {} {
1591 global fdiffids fdiffs treediffs findids
1592 global fdiffsneeded fdiffpos
1594 if {[info exists fdiffids]} {
1595 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1596 && $fdiffpos < [llength $fdiffsneeded]} {
1597 # git-diff-tree doesn't output anything for a commit
1598 # which doesn't change anything
1599 set nullids [lindex $fdiffsneeded $fdiffpos]
1600 set treediffs($nullids) {}
1601 if {[info exists findids] && $nullids eq $findids} {
1609 if {![info exists treediffs($fdiffids)]} {
1610 set treediffs($fdiffids) $fdiffs
1612 if {[info exists findids] && $fdiffids eq $findids} {
1619 proc findcont {ids} {
1620 global findids treediffs parents nparents
1621 global ffileline findstartline finddidsel
1622 global lineid numcommits matchinglines findinprogress
1623 global findmergefiles
1625 set id [lindex $ids 0]
1626 set p [lindex $ids 1]
1627 set pi [lsearch -exact $parents($id) $p]
1630 if {$findmergefiles || $nparents($id) == 1} {
1631 if {![info exists treediffs($ids)]} {
1637 foreach f $treediffs($ids) {
1638 set x [findmatches $f]
1646 set pi $nparents($id)
1649 set pi $nparents($id)
1651 if {[incr pi] >= $nparents($id)} {
1653 if {[incr l] >= $numcommits} {
1656 if {$l == $findstartline} break
1659 set p [lindex $parents($id) $pi]
1660 set ids [list $id $p]
1668 # mark a commit as matching by putting a yellow background
1669 # behind the headline
1670 proc markheadline {l id} {
1671 global canv mainfont linehtag commitinfo
1673 set bbox [$canv bbox $linehtag($l)]
1674 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1678 # mark the bits of a headline, author or date that match a find string
1679 proc markmatches {canv l str tag matches font} {
1680 set bbox [$canv bbox $tag]
1681 set x0 [lindex $bbox 0]
1682 set y0 [lindex $bbox 1]
1683 set y1 [lindex $bbox 3]
1684 foreach match $matches {
1685 set start [lindex $match 0]
1686 set end [lindex $match 1]
1687 if {$start > $end} continue
1688 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1689 set xlen [font measure $font [string range $str 0 [expr $end]]]
1690 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1691 -outline {} -tags matches -fill yellow]
1696 proc unmarkmatches {} {
1697 global matchinglines findids
1698 allcanvs delete matches
1699 catch {unset matchinglines}
1700 catch {unset findids}
1703 proc selcanvline {w x y} {
1704 global canv canvy0 ctext linespc
1705 global lineid linehtag linentag linedtag rowtextx
1706 set ymax [lindex [$canv cget -scrollregion] 3]
1707 if {$ymax == {}} return
1708 set yfrac [lindex [$canv yview] 0]
1709 set y [expr {$y + $yfrac * $ymax}]
1710 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1715 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1721 proc commit_descriptor {p} {
1724 if {[info exists commitinfo($p)]} {
1725 set l [lindex $commitinfo($p) 0]
1730 proc selectline {l isnew} {
1731 global canv canv2 canv3 ctext commitinfo selectedline
1732 global lineid linehtag linentag linedtag
1733 global canvy0 linespc parents nparents children nchildren
1734 global cflist currentid sha1entry
1735 global commentend idtags idline
1738 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1740 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1741 -tags secsel -fill [$canv cget -selectbackground]]
1743 $canv2 delete secsel
1744 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1745 -tags secsel -fill [$canv2 cget -selectbackground]]
1747 $canv3 delete secsel
1748 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1749 -tags secsel -fill [$canv3 cget -selectbackground]]
1751 set y [expr {$canvy0 + $l * $linespc}]
1752 set ymax [lindex [$canv cget -scrollregion] 3]
1753 set ytop [expr {$y - $linespc - 1}]
1754 set ybot [expr {$y + $linespc + 1}]
1755 set wnow [$canv yview]
1756 set wtop [expr [lindex $wnow 0] * $ymax]
1757 set wbot [expr [lindex $wnow 1] * $ymax]
1758 set wh [expr {$wbot - $wtop}]
1760 if {$ytop < $wtop} {
1761 if {$ybot < $wtop} {
1762 set newtop [expr {$y - $wh / 2.0}]
1765 if {$newtop > $wtop - $linespc} {
1766 set newtop [expr {$wtop - $linespc}]
1769 } elseif {$ybot > $wbot} {
1770 if {$ytop > $wbot} {
1771 set newtop [expr {$y - $wh / 2.0}]
1773 set newtop [expr {$ybot - $wh}]
1774 if {$newtop < $wtop + $linespc} {
1775 set newtop [expr {$wtop + $linespc}]
1779 if {$newtop != $wtop} {
1783 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1787 addtohistory [list selectline $l 0]
1794 $sha1entry delete 0 end
1795 $sha1entry insert 0 $id
1796 $sha1entry selection from 0
1797 $sha1entry selection to end
1799 $ctext conf -state normal
1800 $ctext delete 0.0 end
1801 $ctext mark set fmark.0 0.0
1802 $ctext mark gravity fmark.0 left
1803 set info $commitinfo($id)
1804 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1805 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1806 if {[info exists idtags($id)]} {
1807 $ctext insert end "Tags:"
1808 foreach tag $idtags($id) {
1809 $ctext insert end " $tag"
1811 $ctext insert end "\n"
1814 set commentstart [$ctext index "end - 1c"]
1816 if {[info exists parents($id)]} {
1817 foreach p $parents($id) {
1818 append comment "Parent: [commit_descriptor $p]\n"
1821 if {[info exists children($id)]} {
1822 foreach c $children($id) {
1823 append comment "Child: [commit_descriptor $c]\n"
1827 append comment [lindex $info 5]
1828 $ctext insert end $comment
1829 $ctext insert end "\n"
1831 # make anything that looks like a SHA1 ID be a clickable link
1832 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
1837 set linkid [string range $comment $s $e]
1838 if {![info exists idline($linkid)]} continue
1840 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
1841 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
1842 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
1845 $ctext tag conf link -foreground blue -underline 1
1846 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
1847 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
1849 $ctext tag delete Comments
1850 $ctext tag remove found 1.0 end
1851 $ctext conf -state disabled
1852 set commentend [$ctext index "end - 1c"]
1854 $cflist delete 0 end
1855 $cflist insert end "Comments"
1856 if {$nparents($id) == 1} {
1857 startdiff [concat $id $parents($id)]
1858 } elseif {$nparents($id) > 1} {
1863 proc selnextline {dir} {
1865 if {![info exists selectedline]} return
1866 set l [expr $selectedline + $dir]
1871 proc unselectline {} {
1874 catch {unset selectedline}
1875 allcanvs delete secsel
1878 proc addtohistory {cmd} {
1879 global history historyindex
1881 if {$historyindex > 0
1882 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
1886 if {$historyindex < [llength $history]} {
1887 set history [lreplace $history $historyindex end $cmd]
1889 lappend history $cmd
1892 if {$historyindex > 1} {
1893 .ctop.top.bar.leftbut conf -state normal
1895 .ctop.top.bar.leftbut conf -state disabled
1897 .ctop.top.bar.rightbut conf -state disabled
1901 global history historyindex
1903 if {$historyindex > 1} {
1904 incr historyindex -1
1905 set cmd [lindex $history [expr {$historyindex - 1}]]
1907 .ctop.top.bar.rightbut conf -state normal
1909 if {$historyindex <= 1} {
1910 .ctop.top.bar.leftbut conf -state disabled
1915 global history historyindex
1917 if {$historyindex < [llength $history]} {
1918 set cmd [lindex $history $historyindex]
1921 .ctop.top.bar.leftbut conf -state normal
1923 if {$historyindex >= [llength $history]} {
1924 .ctop.top.bar.rightbut conf -state disabled
1928 proc mergediff {id} {
1929 global parents diffmergeid diffmergegca mergefilelist diffpindex
1933 set diffmergegca [findgca $parents($id)]
1934 if {[info exists mergefilelist($id)]} {
1935 if {$mergefilelist($id) ne {}} {
1943 proc findgca {ids} {
1950 set gca [exec git-merge-base $gca $id]
1959 proc contmergediff {ids} {
1960 global diffmergeid diffpindex parents nparents diffmergegca
1961 global treediffs mergefilelist diffids treepending
1963 # diff the child against each of the parents, and diff
1964 # each of the parents against the GCA.
1966 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
1967 set ids [list [lindex $ids 1] $diffmergegca]
1969 if {[incr diffpindex] >= $nparents($diffmergeid)} break
1970 set p [lindex $parents($diffmergeid) $diffpindex]
1971 set ids [list $diffmergeid $p]
1973 if {![info exists treediffs($ids)]} {
1975 if {![info exists treepending]} {
1982 # If a file in some parent is different from the child and also
1983 # different from the GCA, then it's interesting.
1984 # If we don't have a GCA, then a file is interesting if it is
1985 # different from the child in all the parents.
1986 if {$diffmergegca ne {}} {
1988 foreach p $parents($diffmergeid) {
1989 set gcadiffs $treediffs([list $p $diffmergegca])
1990 foreach f $treediffs([list $diffmergeid $p]) {
1991 if {[lsearch -exact $files $f] < 0
1992 && [lsearch -exact $gcadiffs $f] >= 0} {
1997 set files [lsort $files]
1999 set p [lindex $parents($diffmergeid) 0]
2000 set files $treediffs([list $diffmergeid $p])
2001 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2002 set p [lindex $parents($diffmergeid) $i]
2003 set df $treediffs([list $diffmergeid $p])
2006 if {[lsearch -exact $df $f] >= 0} {
2014 set mergefilelist($diffmergeid) $files
2020 proc showmergediff {} {
2021 global cflist diffmergeid mergefilelist parents
2022 global diffopts diffinhunk currentfile currenthunk filelines
2023 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2025 set files $mergefilelist($diffmergeid)
2027 $cflist insert end $f
2029 set env(GIT_DIFF_OPTS) $diffopts
2031 catch {unset currentfile}
2032 catch {unset currenthunk}
2033 catch {unset filelines}
2034 catch {unset groupfilenum}
2035 catch {unset grouphunks}
2036 set groupfilelast -1
2037 foreach p $parents($diffmergeid) {
2038 set cmd [list | git-diff-tree -p $p $diffmergeid]
2039 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2040 if {[catch {set f [open $cmd r]} err]} {
2041 error_popup "Error getting diffs: $err"
2048 set ids [list $diffmergeid $p]
2049 set mergefds($ids) $f
2050 set diffinhunk($ids) 0
2051 set diffblocked($ids) 0
2052 fconfigure $f -blocking 0
2053 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2057 proc getmergediffline {f ids id} {
2058 global diffmergeid diffinhunk diffoldlines diffnewlines
2059 global currentfile currenthunk
2060 global diffoldstart diffnewstart diffoldlno diffnewlno
2061 global diffblocked mergefilelist
2062 global noldlines nnewlines difflcounts filelines
2064 set n [gets $f line]
2066 if {![eof $f]} return
2069 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2076 if {$diffinhunk($ids) != 0} {
2077 set fi $currentfile($ids)
2078 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2079 # continuing an existing hunk
2080 set line [string range $line 1 end]
2081 set p [lindex $ids 1]
2082 if {$match eq "-" || $match eq " "} {
2083 set filelines($p,$fi,$diffoldlno($ids)) $line
2084 incr diffoldlno($ids)
2086 if {$match eq "+" || $match eq " "} {
2087 set filelines($id,$fi,$diffnewlno($ids)) $line
2088 incr diffnewlno($ids)
2090 if {$match eq " "} {
2091 if {$diffinhunk($ids) == 2} {
2092 lappend difflcounts($ids) \
2093 [list $noldlines($ids) $nnewlines($ids)]
2094 set noldlines($ids) 0
2095 set diffinhunk($ids) 1
2097 incr noldlines($ids)
2098 } elseif {$match eq "-" || $match eq "+"} {
2099 if {$diffinhunk($ids) == 1} {
2100 lappend difflcounts($ids) [list $noldlines($ids)]
2101 set noldlines($ids) 0
2102 set nnewlines($ids) 0
2103 set diffinhunk($ids) 2
2105 if {$match eq "-"} {
2106 incr noldlines($ids)
2108 incr nnewlines($ids)
2111 # and if it's \ No newline at end of line, then what?
2115 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2116 lappend difflcounts($ids) [list $noldlines($ids)]
2117 } elseif {$diffinhunk($ids) == 2
2118 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2119 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2121 set currenthunk($ids) [list $currentfile($ids) \
2122 $diffoldstart($ids) $diffnewstart($ids) \
2123 $diffoldlno($ids) $diffnewlno($ids) \
2125 set diffinhunk($ids) 0
2126 # -1 = need to block, 0 = unblocked, 1 = is blocked
2127 set diffblocked($ids) -1
2129 if {$diffblocked($ids) == -1} {
2130 fileevent $f readable {}
2131 set diffblocked($ids) 1
2137 if {!$diffblocked($ids)} {
2139 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2140 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2143 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2144 # start of a new file
2145 set currentfile($ids) \
2146 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2147 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2148 $line match f1l f1c f2l f2c rest]} {
2149 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2150 # start of a new hunk
2151 if {$f1l == 0 && $f1c == 0} {
2154 if {$f2l == 0 && $f2c == 0} {
2157 set diffinhunk($ids) 1
2158 set diffoldstart($ids) $f1l
2159 set diffnewstart($ids) $f2l
2160 set diffoldlno($ids) $f1l
2161 set diffnewlno($ids) $f2l
2162 set difflcounts($ids) {}
2163 set noldlines($ids) 0
2164 set nnewlines($ids) 0
2169 proc processhunks {} {
2170 global diffmergeid parents nparents currenthunk
2171 global mergefilelist diffblocked mergefds
2172 global grouphunks grouplinestart grouplineend groupfilenum
2174 set nfiles [llength $mergefilelist($diffmergeid)]
2178 # look for the earliest hunk
2179 foreach p $parents($diffmergeid) {
2180 set ids [list $diffmergeid $p]
2181 if {![info exists currenthunk($ids)]} return
2182 set i [lindex $currenthunk($ids) 0]
2183 set l [lindex $currenthunk($ids) 2]
2184 if {$i < $fi || ($i == $fi && $l < $lno)} {
2191 if {$fi < $nfiles} {
2192 set ids [list $diffmergeid $pi]
2193 set hunk $currenthunk($ids)
2194 unset currenthunk($ids)
2195 if {$diffblocked($ids) > 0} {
2196 fileevent $mergefds($ids) readable \
2197 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2199 set diffblocked($ids) 0
2201 if {[info exists groupfilenum] && $groupfilenum == $fi
2202 && $lno <= $grouplineend} {
2203 # add this hunk to the pending group
2204 lappend grouphunks($pi) $hunk
2205 set endln [lindex $hunk 4]
2206 if {$endln > $grouplineend} {
2207 set grouplineend $endln
2213 # succeeding stuff doesn't belong in this group, so
2214 # process the group now
2215 if {[info exists groupfilenum]} {
2221 if {$fi >= $nfiles} break
2224 set groupfilenum $fi
2225 set grouphunks($pi) [list $hunk]
2226 set grouplinestart $lno
2227 set grouplineend [lindex $hunk 4]
2231 proc processgroup {} {
2232 global groupfilelast groupfilenum difffilestart
2233 global mergefilelist diffmergeid ctext filelines
2234 global parents diffmergeid diffoffset
2235 global grouphunks grouplinestart grouplineend nparents
2238 $ctext conf -state normal
2241 if {$groupfilelast != $f} {
2242 $ctext insert end "\n"
2243 set here [$ctext index "end - 1c"]
2244 set difffilestart($f) $here
2245 set mark fmark.[expr {$f + 1}]
2246 $ctext mark set $mark $here
2247 $ctext mark gravity $mark left
2248 set header [lindex $mergefilelist($id) $f]
2249 set l [expr {(78 - [string length $header]) / 2}]
2250 set pad [string range "----------------------------------------" 1 $l]
2251 $ctext insert end "$pad $header $pad\n" filesep
2252 set groupfilelast $f
2253 foreach p $parents($id) {
2254 set diffoffset($p) 0
2258 $ctext insert end "@@" msep
2259 set nlines [expr {$grouplineend - $grouplinestart}]
2262 foreach p $parents($id) {
2263 set startline [expr {$grouplinestart + $diffoffset($p)}]
2265 set nl $grouplinestart
2266 if {[info exists grouphunks($p)]} {
2267 foreach h $grouphunks($p) {
2270 for {} {$nl < $l} {incr nl} {
2271 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2275 foreach chunk [lindex $h 5] {
2276 if {[llength $chunk] == 2} {
2277 set olc [lindex $chunk 0]
2278 set nlc [lindex $chunk 1]
2279 set nnl [expr {$nl + $nlc}]
2280 lappend events [list $nl $nnl $pnum $olc $nlc]
2284 incr ol [lindex $chunk 0]
2285 incr nl [lindex $chunk 0]
2290 if {$nl < $grouplineend} {
2291 for {} {$nl < $grouplineend} {incr nl} {
2292 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2296 set nlines [expr {$ol - $startline}]
2297 $ctext insert end " -$startline,$nlines" msep
2301 set nlines [expr {$grouplineend - $grouplinestart}]
2302 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2304 set events [lsort -integer -index 0 $events]
2305 set nevents [llength $events]
2306 set nmerge $nparents($diffmergeid)
2307 set l $grouplinestart
2308 for {set i 0} {$i < $nevents} {set i $j} {
2309 set nl [lindex $events $i 0]
2311 $ctext insert end " $filelines($id,$f,$l)\n"
2314 set e [lindex $events $i]
2315 set enl [lindex $e 1]
2319 set pnum [lindex $e 2]
2320 set olc [lindex $e 3]
2321 set nlc [lindex $e 4]
2322 if {![info exists delta($pnum)]} {
2323 set delta($pnum) [expr {$olc - $nlc}]
2324 lappend active $pnum
2326 incr delta($pnum) [expr {$olc - $nlc}]
2328 if {[incr j] >= $nevents} break
2329 set e [lindex $events $j]
2330 if {[lindex $e 0] >= $enl} break
2331 if {[lindex $e 1] > $enl} {
2332 set enl [lindex $e 1]
2335 set nlc [expr {$enl - $l}]
2338 if {[llength $active] == $nmerge - 1} {
2339 # no diff for one of the parents, i.e. it's identical
2340 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2341 if {![info exists delta($pnum)]} {
2342 if {$pnum < $mergemax} {
2350 } elseif {[llength $active] == $nmerge} {
2351 # all parents are different, see if one is very similar
2353 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2354 set sim [similarity $pnum $l $nlc $f \
2355 [lrange $events $i [expr {$j-1}]]]
2356 if {$sim > $bestsim} {
2362 lappend ncol m$bestpn
2366 foreach p $parents($id) {
2368 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2369 set olc [expr {$nlc + $delta($pnum)}]
2370 set ol [expr {$l + $diffoffset($p)}]
2371 incr diffoffset($p) $delta($pnum)
2373 for {} {$olc > 0} {incr olc -1} {
2374 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2378 set endl [expr {$l + $nlc}]
2380 # show this pretty much as a normal diff
2381 set p [lindex $parents($id) $bestpn]
2382 set ol [expr {$l + $diffoffset($p)}]
2383 incr diffoffset($p) $delta($bestpn)
2384 unset delta($bestpn)
2385 for {set k $i} {$k < $j} {incr k} {
2386 set e [lindex $events $k]
2387 if {[lindex $e 2] != $bestpn} continue
2388 set nl [lindex $e 0]
2389 set ol [expr {$ol + $nl - $l}]
2390 for {} {$l < $nl} {incr l} {
2391 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2394 for {} {$c > 0} {incr c -1} {
2395 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2398 set nl [lindex $e 1]
2399 for {} {$l < $nl} {incr l} {
2400 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2404 for {} {$l < $endl} {incr l} {
2405 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2408 while {$l < $grouplineend} {
2409 $ctext insert end " $filelines($id,$f,$l)\n"
2412 $ctext conf -state disabled
2415 proc similarity {pnum l nlc f events} {
2416 global diffmergeid parents diffoffset filelines
2419 set p [lindex $parents($id) $pnum]
2420 set ol [expr {$l + $diffoffset($p)}]
2421 set endl [expr {$l + $nlc}]
2425 if {[lindex $e 2] != $pnum} continue
2426 set nl [lindex $e 0]
2427 set ol [expr {$ol + $nl - $l}]
2428 for {} {$l < $nl} {incr l} {
2429 incr same [string length $filelines($id,$f,$l)]
2432 set oc [lindex $e 3]
2433 for {} {$oc > 0} {incr oc -1} {
2434 incr diff [string length $filelines($p,$f,$ol)]
2438 set nl [lindex $e 1]
2439 for {} {$l < $nl} {incr l} {
2440 incr diff [string length $filelines($id,$f,$l)]
2444 for {} {$l < $endl} {incr l} {
2445 incr same [string length $filelines($id,$f,$l)]
2451 return [expr {200 * $same / (2 * $same + $diff)}]
2454 proc startdiff {ids} {
2455 global treediffs diffids treepending diffmergeid
2458 catch {unset diffmergeid}
2459 if {![info exists treediffs($ids)]} {
2460 if {![info exists treepending]} {
2468 proc addtocflist {ids} {
2469 global treediffs cflist
2470 foreach f $treediffs($ids) {
2471 $cflist insert end $f
2476 proc gettreediffs {ids} {
2477 global treediff parents treepending
2478 set treepending $ids
2480 set id [lindex $ids 0]
2481 set p [lindex $ids 1]
2482 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2483 fconfigure $gdtf -blocking 0
2484 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2487 proc gettreediffline {gdtf ids} {
2488 global treediff treediffs treepending diffids diffmergeid
2490 set n [gets $gdtf line]
2492 if {![eof $gdtf]} return
2494 set treediffs($ids) $treediff
2496 if {$ids != $diffids} {
2497 gettreediffs $diffids
2499 if {[info exists diffmergeid]} {
2507 set file [lindex $line 5]
2508 lappend treediff $file
2511 proc getblobdiffs {ids} {
2512 global diffopts blobdifffd diffids env curdifftag curtagstart
2513 global difffilestart nextupdate diffinhdr treediffs
2515 set id [lindex $ids 0]
2516 set p [lindex $ids 1]
2517 set env(GIT_DIFF_OPTS) $diffopts
2518 set cmd [list | git-diff-tree -r -p -C $p $id]
2519 if {[catch {set bdf [open $cmd r]} err]} {
2520 puts "error getting diffs: $err"
2524 fconfigure $bdf -blocking 0
2525 set blobdifffd($ids) $bdf
2526 set curdifftag Comments
2528 catch {unset difffilestart}
2529 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2530 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2533 proc getblobdiffline {bdf ids} {
2534 global diffids blobdifffd ctext curdifftag curtagstart
2535 global diffnexthead diffnextnote difffilestart
2536 global nextupdate diffinhdr treediffs
2539 set n [gets $bdf line]
2543 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2544 $ctext tag add $curdifftag $curtagstart end
2549 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2552 $ctext conf -state normal
2553 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2554 # start of a new file
2555 $ctext insert end "\n"
2556 $ctext tag add $curdifftag $curtagstart end
2557 set curtagstart [$ctext index "end - 1c"]
2559 set here [$ctext index "end - 1c"]
2560 set i [lsearch -exact $treediffs($diffids) $fname]
2562 set difffilestart($i) $here
2564 $ctext mark set fmark.$i $here
2565 $ctext mark gravity fmark.$i left
2567 if {$newname != $fname} {
2568 set i [lsearch -exact $treediffs($diffids) $newname]
2570 set difffilestart($i) $here
2572 $ctext mark set fmark.$i $here
2573 $ctext mark gravity fmark.$i left
2576 set curdifftag "f:$fname"
2577 $ctext tag delete $curdifftag
2578 set l [expr {(78 - [string length $header]) / 2}]
2579 set pad [string range "----------------------------------------" 1 $l]
2580 $ctext insert end "$pad $header $pad\n" filesep
2582 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2584 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2585 $line match f1l f1c f2l f2c rest]} {
2587 $ctext insert end "\t" hunksep
2588 $ctext insert end " $f1l " d0 " $f2l " d1
2589 $ctext insert end " $rest \n" hunksep
2591 $ctext insert end "$line\n" hunksep
2595 set x [string range $line 0 0]
2596 if {$x == "-" || $x == "+"} {
2597 set tag [expr {$x == "+"}]
2599 set line [string range $line 1 end]
2601 $ctext insert end "$line\n" d$tag
2602 } elseif {$x == " "} {
2604 set line [string range $line 1 end]
2606 $ctext insert end "$line\n"
2607 } elseif {$diffinhdr || $x == "\\"} {
2608 # e.g. "\ No newline at end of file"
2609 $ctext insert end "$line\n" filesep
2611 # Something else we don't recognize
2612 if {$curdifftag != "Comments"} {
2613 $ctext insert end "\n"
2614 $ctext tag add $curdifftag $curtagstart end
2615 set curtagstart [$ctext index "end - 1c"]
2616 set curdifftag Comments
2618 $ctext insert end "$line\n" filesep
2621 $ctext conf -state disabled
2622 if {[clock clicks -milliseconds] >= $nextupdate} {
2624 fileevent $bdf readable {}
2626 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2631 global difffilestart ctext
2632 set here [$ctext index @0,0]
2633 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2634 if {[$ctext compare $difffilestart($i) > $here]} {
2635 if {![info exists pos]
2636 || [$ctext compare $difffilestart($i) < $pos]} {
2637 set pos $difffilestart($i)
2641 if {[info exists pos]} {
2646 proc listboxsel {} {
2647 global ctext cflist currentid
2648 if {![info exists currentid]} return
2649 set sel [lsort [$cflist curselection]]
2650 if {$sel eq {}} return
2651 set first [lindex $sel 0]
2652 catch {$ctext yview fmark.$first}
2656 global linespc charspc canvx0 canvy0 mainfont
2659 set linespc [font metrics $mainfont -linespace]
2660 set charspc [font measure $mainfont "m"]
2661 set canvy0 [expr 3 + 0.5 * $linespc]
2662 set canvx0 [expr 3 + 0.5 * $linespc]
2663 set xspc1(0) $linespc
2668 global stopped redisplaying phase
2669 if {$stopped > 1} return
2670 if {$phase == "getcommits"} return
2672 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2679 proc incrfont {inc} {
2680 global mainfont namefont textfont ctext canv phase
2681 global stopped entries
2683 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2684 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2685 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2687 $ctext conf -font $textfont
2688 $ctext tag conf filesep -font [concat $textfont bold]
2689 foreach e $entries {
2690 $e conf -font $mainfont
2692 if {$phase == "getcommits"} {
2693 $canv itemconf textitems -font $mainfont
2699 global sha1entry sha1string
2700 if {[string length $sha1string] == 40} {
2701 $sha1entry delete 0 end
2705 proc sha1change {n1 n2 op} {
2706 global sha1string currentid sha1but
2707 if {$sha1string == {}
2708 || ([info exists currentid] && $sha1string == $currentid)} {
2713 if {[$sha1but cget -state] == $state} return
2714 if {$state == "normal"} {
2715 $sha1but conf -state normal -relief raised -text "Goto: "
2717 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2721 proc gotocommit {} {
2722 global sha1string currentid idline tagids
2723 global lineid numcommits
2725 if {$sha1string == {}
2726 || ([info exists currentid] && $sha1string == $currentid)} return
2727 if {[info exists tagids($sha1string)]} {
2728 set id $tagids($sha1string)
2730 set id [string tolower $sha1string]
2731 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2733 for {set l 0} {$l < $numcommits} {incr l} {
2734 if {[string match $id* $lineid($l)]} {
2735 lappend matches $lineid($l)
2738 if {$matches ne {}} {
2739 if {[llength $matches] > 1} {
2740 error_popup "Short SHA1 id $id is ambiguous"
2743 set id [lindex $matches 0]
2747 if {[info exists idline($id)]} {
2748 selectline $idline($id) 1
2751 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2756 error_popup "$type $sha1string is not known"
2759 proc lineenter {x y id} {
2760 global hoverx hovery hoverid hovertimer
2761 global commitinfo canv
2763 if {![info exists commitinfo($id)]} return
2767 if {[info exists hovertimer]} {
2768 after cancel $hovertimer
2770 set hovertimer [after 500 linehover]
2774 proc linemotion {x y id} {
2775 global hoverx hovery hoverid hovertimer
2777 if {[info exists hoverid] && $id == $hoverid} {
2780 if {[info exists hovertimer]} {
2781 after cancel $hovertimer
2783 set hovertimer [after 500 linehover]
2787 proc lineleave {id} {
2788 global hoverid hovertimer canv
2790 if {[info exists hoverid] && $id == $hoverid} {
2792 if {[info exists hovertimer]} {
2793 after cancel $hovertimer
2801 global hoverx hovery hoverid hovertimer
2802 global canv linespc lthickness
2803 global commitinfo mainfont
2805 set text [lindex $commitinfo($hoverid) 0]
2806 set ymax [lindex [$canv cget -scrollregion] 3]
2807 if {$ymax == {}} return
2808 set yfrac [lindex [$canv yview] 0]
2809 set x [expr {$hoverx + 2 * $linespc}]
2810 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2811 set x0 [expr {$x - 2 * $lthickness}]
2812 set y0 [expr {$y - 2 * $lthickness}]
2813 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2814 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2815 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2816 -fill \#ffff80 -outline black -width 1 -tags hover]
2818 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2822 proc lineclick {x y id isnew} {
2823 global ctext commitinfo children cflist canv
2828 addtohistory [list lineclick $x $x $id 0]
2831 # fill the details pane with info about this line
2832 $ctext conf -state normal
2833 $ctext delete 0.0 end
2834 $ctext tag conf link -foreground blue -underline 1
2835 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2836 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2837 $ctext insert end "Parent:\t"
2838 $ctext insert end $id [list link link0]
2839 $ctext tag bind link0 <1> [list selbyid $id]
2840 set info $commitinfo($id)
2841 $ctext insert end "\n\t[lindex $info 0]\n"
2842 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2843 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2844 if {[info exists children($id)]} {
2845 $ctext insert end "\nChildren:"
2847 foreach child $children($id) {
2849 set info $commitinfo($child)
2850 $ctext insert end "\n\t"
2851 $ctext insert end $child [list link link$i]
2852 $ctext tag bind link$i <1> [list selbyid $child]
2853 $ctext insert end "\n\t[lindex $info 0]"
2854 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
2855 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
2858 $ctext conf -state disabled
2860 $cflist delete 0 end
2865 if {[info exists idline($id)]} {
2866 selectline $idline($id) 1
2872 if {![info exists startmstime]} {
2873 set startmstime [clock clicks -milliseconds]
2875 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2878 proc rowmenu {x y id} {
2879 global rowctxmenu idline selectedline rowmenuid
2881 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2886 $rowctxmenu entryconfigure 0 -state $state
2887 $rowctxmenu entryconfigure 1 -state $state
2888 $rowctxmenu entryconfigure 2 -state $state
2890 tk_popup $rowctxmenu $x $y
2893 proc diffvssel {dirn} {
2894 global rowmenuid selectedline lineid
2896 if {![info exists selectedline]} return
2898 set oldid $lineid($selectedline)
2899 set newid $rowmenuid
2901 set oldid $rowmenuid
2902 set newid $lineid($selectedline)
2904 addtohistory [list doseldiff $oldid $newid]
2905 doseldiff $oldid $newid
2908 proc doseldiff {oldid newid} {
2912 $ctext conf -state normal
2913 $ctext delete 0.0 end
2914 $ctext mark set fmark.0 0.0
2915 $ctext mark gravity fmark.0 left
2916 $cflist delete 0 end
2917 $cflist insert end "Top"
2918 $ctext insert end "From "
2919 $ctext tag conf link -foreground blue -underline 1
2920 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2921 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2922 $ctext tag bind link0 <1> [list selbyid $oldid]
2923 $ctext insert end $oldid [list link link0]
2924 $ctext insert end "\n "
2925 $ctext insert end [lindex $commitinfo($oldid) 0]
2926 $ctext insert end "\n\nTo "
2927 $ctext tag bind link1 <1> [list selbyid $newid]
2928 $ctext insert end $newid [list link link1]
2929 $ctext insert end "\n "
2930 $ctext insert end [lindex $commitinfo($newid) 0]
2931 $ctext insert end "\n"
2932 $ctext conf -state disabled
2933 $ctext tag delete Comments
2934 $ctext tag remove found 1.0 end
2935 startdiff [list $newid $oldid]
2939 global rowmenuid currentid commitinfo patchtop patchnum
2941 if {![info exists currentid]} return
2942 set oldid $currentid
2943 set oldhead [lindex $commitinfo($oldid) 0]
2944 set newid $rowmenuid
2945 set newhead [lindex $commitinfo($newid) 0]
2948 catch {destroy $top}
2950 label $top.title -text "Generate patch"
2951 grid $top.title - -pady 10
2952 label $top.from -text "From:"
2953 entry $top.fromsha1 -width 40 -relief flat
2954 $top.fromsha1 insert 0 $oldid
2955 $top.fromsha1 conf -state readonly
2956 grid $top.from $top.fromsha1 -sticky w
2957 entry $top.fromhead -width 60 -relief flat
2958 $top.fromhead insert 0 $oldhead
2959 $top.fromhead conf -state readonly
2960 grid x $top.fromhead -sticky w
2961 label $top.to -text "To:"
2962 entry $top.tosha1 -width 40 -relief flat
2963 $top.tosha1 insert 0 $newid
2964 $top.tosha1 conf -state readonly
2965 grid $top.to $top.tosha1 -sticky w
2966 entry $top.tohead -width 60 -relief flat
2967 $top.tohead insert 0 $newhead
2968 $top.tohead conf -state readonly
2969 grid x $top.tohead -sticky w
2970 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2971 grid $top.rev x -pady 10
2972 label $top.flab -text "Output file:"
2973 entry $top.fname -width 60
2974 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2976 grid $top.flab $top.fname -sticky w
2978 button $top.buts.gen -text "Generate" -command mkpatchgo
2979 button $top.buts.can -text "Cancel" -command mkpatchcan
2980 grid $top.buts.gen $top.buts.can
2981 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2982 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2983 grid $top.buts - -pady 10 -sticky ew
2987 proc mkpatchrev {} {
2990 set oldid [$patchtop.fromsha1 get]
2991 set oldhead [$patchtop.fromhead get]
2992 set newid [$patchtop.tosha1 get]
2993 set newhead [$patchtop.tohead get]
2994 foreach e [list fromsha1 fromhead tosha1 tohead] \
2995 v [list $newid $newhead $oldid $oldhead] {
2996 $patchtop.$e conf -state normal
2997 $patchtop.$e delete 0 end
2998 $patchtop.$e insert 0 $v
2999 $patchtop.$e conf -state readonly
3006 set oldid [$patchtop.fromsha1 get]
3007 set newid [$patchtop.tosha1 get]
3008 set fname [$patchtop.fname get]
3009 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3010 error_popup "Error creating patch: $err"
3012 catch {destroy $patchtop}
3016 proc mkpatchcan {} {
3019 catch {destroy $patchtop}
3024 global rowmenuid mktagtop commitinfo
3028 catch {destroy $top}
3030 label $top.title -text "Create tag"
3031 grid $top.title - -pady 10
3032 label $top.id -text "ID:"
3033 entry $top.sha1 -width 40 -relief flat
3034 $top.sha1 insert 0 $rowmenuid
3035 $top.sha1 conf -state readonly
3036 grid $top.id $top.sha1 -sticky w
3037 entry $top.head -width 60 -relief flat
3038 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3039 $top.head conf -state readonly
3040 grid x $top.head -sticky w
3041 label $top.tlab -text "Tag name:"
3042 entry $top.tag -width 60
3043 grid $top.tlab $top.tag -sticky w
3045 button $top.buts.gen -text "Create" -command mktaggo
3046 button $top.buts.can -text "Cancel" -command mktagcan
3047 grid $top.buts.gen $top.buts.can
3048 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3049 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3050 grid $top.buts - -pady 10 -sticky ew
3055 global mktagtop env tagids idtags
3056 global idpos idline linehtag canv selectedline
3058 set id [$mktagtop.sha1 get]
3059 set tag [$mktagtop.tag get]
3061 error_popup "No tag name specified"
3064 if {[info exists tagids($tag)]} {
3065 error_popup "Tag \"$tag\" already exists"
3070 set fname [file join $dir "refs/tags" $tag]
3071 set f [open $fname w]
3075 error_popup "Error creating tag: $err"
3079 set tagids($tag) $id
3080 lappend idtags($id) $tag
3081 $canv delete tag.$id
3082 set xt [eval drawtags $id $idpos($id)]
3083 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3084 if {[info exists selectedline] && $selectedline == $idline($id)} {
3085 selectline $selectedline 0
3092 catch {destroy $mktagtop}
3101 proc writecommit {} {
3102 global rowmenuid wrcomtop commitinfo wrcomcmd
3104 set top .writecommit
3106 catch {destroy $top}
3108 label $top.title -text "Write commit to file"
3109 grid $top.title - -pady 10
3110 label $top.id -text "ID:"
3111 entry $top.sha1 -width 40 -relief flat
3112 $top.sha1 insert 0 $rowmenuid
3113 $top.sha1 conf -state readonly
3114 grid $top.id $top.sha1 -sticky w
3115 entry $top.head -width 60 -relief flat
3116 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3117 $top.head conf -state readonly
3118 grid x $top.head -sticky w
3119 label $top.clab -text "Command:"
3120 entry $top.cmd -width 60 -textvariable wrcomcmd
3121 grid $top.clab $top.cmd -sticky w -pady 10
3122 label $top.flab -text "Output file:"
3123 entry $top.fname -width 60
3124 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3125 grid $top.flab $top.fname -sticky w
3127 button $top.buts.gen -text "Write" -command wrcomgo
3128 button $top.buts.can -text "Cancel" -command wrcomcan
3129 grid $top.buts.gen $top.buts.can
3130 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3131 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3132 grid $top.buts - -pady 10 -sticky ew
3139 set id [$wrcomtop.sha1 get]
3140 set cmd "echo $id | [$wrcomtop.cmd get]"
3141 set fname [$wrcomtop.fname get]
3142 if {[catch {exec sh -c $cmd >$fname &} err]} {
3143 error_popup "Error writing commit: $err"
3145 catch {destroy $wrcomtop}
3152 catch {destroy $wrcomtop}
3165 set diffopts "-U 5 -p"
3166 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3168 set mainfont {Helvetica 9}
3169 set textfont {Courier 9}
3170 set findmergefiles 0
3174 set colors {green red blue magenta darkgrey brown orange}
3176 catch {source ~/.gitk}
3178 set namefont $mainfont
3180 lappend namefont bold
3185 switch -regexp -- $arg {
3187 "^-b" { set boldnames 1 }
3188 "^-d" { set datemode 1 }
3190 lappend revtreeargs $arg
3205 getcommits $revtreeargs