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
168 if {![info exists nchildren($id)]} {
176 if {[info exists grafts($id)]} {
178 set parents($id) $grafts($id)
179 set nparents($id) [llength $grafts($id)]
181 foreach p $grafts($id) {
182 if {![info exists nchildren($p)]} {
183 set children($p) [list $id]
186 } elseif {[lsearch -exact $children($p) $id] < 0} {
187 lappend children($p) $id
194 foreach line [split $contents "\n"] {
199 set tag [lindex $line 0]
200 if {$tag == "parent" && !$grafted} {
201 set p [lindex $line 1]
202 if {![info exists nchildren($p)]} {
207 lappend parents($id) $p
209 # sometimes we get a commit that lists a parent twice...
210 if {$listed && [lsearch -exact $children($p) $id] < 0} {
211 lappend children($p) $id
215 } elseif {$tag == "author"} {
216 set x [expr {[llength $line] - 2}]
217 set audate [lindex $line $x]
218 set auname [lrange $line 1 [expr {$x - 1}]]
219 } elseif {$tag == "committer"} {
220 set x [expr {[llength $line] - 2}]
221 set comdate [lindex $line $x]
222 set comname [lrange $line 1 [expr {$x - 1}]]
226 if {$comment == {}} {
227 set headline [string trim $line]
232 # git-rev-list indents the comment by 4 spaces;
233 # if we got this via git-cat-file, add the indentation
240 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
242 if {$comdate != {}} {
243 set cdate($id) $comdate
244 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
246 set commitinfo($id) [list $headline $auname $audate \
247 $comname $comdate $comment]
251 global tagids idtags headids idheads
252 set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
257 if {[regexp {^[0-9a-f]{40}} $line id]} {
258 set direct [file tail $f]
259 set tagids($direct) $id
260 lappend idtags($id) $direct
261 set contents [split [exec git-cat-file tag $id] "\n"]
265 foreach l $contents {
267 switch -- [lindex $l 0] {
268 "object" {set obj [lindex $l 1]}
269 "type" {set type [lindex $l 1]}
270 "tag" {set tag [string range $l 4 end]}
273 if {$obj != {} && $type == "commit" && $tag != {}} {
274 set tagids($tag) $obj
275 lappend idtags($obj) $tag
281 set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
285 set line [read $fd 40]
286 if {[regexp {^[0-9a-f]{40}} $line id]} {
287 set head [file tail $f]
288 set headids($head) $line
289 lappend idheads($line) $head
299 set graftfile info/grafts
300 if {[info exists env(GIT_GRAFT_FILE)]} {
301 set graftfile $env(GIT_GRAFT_FILE)
303 set fd [open [gitdir]/$graftfile r]
304 while {[gets $fd line] >= 0} {
305 if {[string match "#*" $line]} continue
308 if {![regexp {^[0-9a-f]{40}$} $x]} {
314 set id [lindex $line 0]
315 set grafts($id) [lrange $line 1 end]
322 proc error_popup msg {
326 message $w.m -text $msg -justify center -aspect 400
327 pack $w.m -side top -fill x -padx 20 -pady 20
328 button $w.ok -text OK -command "destroy $w"
329 pack $w.ok -side bottom -fill x
330 bind $w <Visibility> "grab $w; focus $w"
335 global canv canv2 canv3 linespc charspc ctext cflist textfont
336 global findtype findtypemenu findloc findstring fstring geometry
337 global entries sha1entry sha1string sha1but
338 global maincursor textcursor curtextcursor
339 global rowctxmenu gaudydiff mergemax
342 .bar add cascade -label "File" -menu .bar.file
344 .bar.file add command -label "Quit" -command doquit
346 .bar add cascade -label "Help" -menu .bar.help
347 .bar.help add command -label "About gitk" -command about
348 . configure -menu .bar
350 if {![info exists geometry(canv1)]} {
351 set geometry(canv1) [expr 45 * $charspc]
352 set geometry(canv2) [expr 30 * $charspc]
353 set geometry(canv3) [expr 15 * $charspc]
354 set geometry(canvh) [expr 25 * $linespc + 4]
355 set geometry(ctextw) 80
356 set geometry(ctexth) 30
357 set geometry(cflistw) 30
359 panedwindow .ctop -orient vertical
360 if {[info exists geometry(width)]} {
361 .ctop conf -width $geometry(width) -height $geometry(height)
362 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
363 set geometry(ctexth) [expr {($texth - 8) /
364 [font metrics $textfont -linespace]}]
368 pack .ctop.top.bar -side bottom -fill x
369 set cscroll .ctop.top.csb
370 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
371 pack $cscroll -side right -fill y
372 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
373 pack .ctop.top.clist -side top -fill both -expand 1
375 set canv .ctop.top.clist.canv
376 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
378 -yscrollincr $linespc -yscrollcommand "$cscroll set"
379 .ctop.top.clist add $canv
380 set canv2 .ctop.top.clist.canv2
381 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
382 -bg white -bd 0 -yscrollincr $linespc
383 .ctop.top.clist add $canv2
384 set canv3 .ctop.top.clist.canv3
385 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
386 -bg white -bd 0 -yscrollincr $linespc
387 .ctop.top.clist add $canv3
388 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
390 set sha1entry .ctop.top.bar.sha1
391 set entries $sha1entry
392 set sha1but .ctop.top.bar.sha1label
393 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
394 -command gotocommit -width 8
395 $sha1but conf -disabledforeground [$sha1but cget -foreground]
396 pack .ctop.top.bar.sha1label -side left
397 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
398 trace add variable sha1string write sha1change
399 pack $sha1entry -side left -pady 2
401 image create bitmap bm-left -data {
402 #define left_width 16
403 #define left_height 16
404 static unsigned char left_bits[] = {
405 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
406 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
407 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
409 image create bitmap bm-right -data {
410 #define right_width 16
411 #define right_height 16
412 static unsigned char right_bits[] = {
413 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
414 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
415 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
417 button .ctop.top.bar.leftbut -image bm-left -command goback \
418 -state disabled -width 26
419 pack .ctop.top.bar.leftbut -side left -fill y
420 button .ctop.top.bar.rightbut -image bm-right -command goforw \
421 -state disabled -width 26
422 pack .ctop.top.bar.rightbut -side left -fill y
424 button .ctop.top.bar.findbut -text "Find" -command dofind
425 pack .ctop.top.bar.findbut -side left
427 set fstring .ctop.top.bar.findstring
428 lappend entries $fstring
429 entry $fstring -width 30 -font $textfont -textvariable findstring
430 pack $fstring -side left -expand 1 -fill x
432 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
433 findtype Exact IgnCase Regexp]
434 set findloc "All fields"
435 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
436 Comments Author Committer Files Pickaxe
437 pack .ctop.top.bar.findloc -side right
438 pack .ctop.top.bar.findtype -side right
439 # for making sure type==Exact whenever loc==Pickaxe
440 trace add variable findloc write findlocchange
442 panedwindow .ctop.cdet -orient horizontal
444 frame .ctop.cdet.left
445 set ctext .ctop.cdet.left.ctext
446 text $ctext -bg white -state disabled -font $textfont \
447 -width $geometry(ctextw) -height $geometry(ctexth) \
448 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
449 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
450 pack .ctop.cdet.left.sb -side right -fill y
451 pack $ctext -side left -fill both -expand 1
452 .ctop.cdet add .ctop.cdet.left
454 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
456 $ctext tag conf hunksep -back blue -fore white
457 $ctext tag conf d0 -back "#ff8080"
458 $ctext tag conf d1 -back green
460 $ctext tag conf hunksep -fore blue
461 $ctext tag conf d0 -fore red
462 $ctext tag conf d1 -fore "#00a000"
463 $ctext tag conf m0 -fore red
464 $ctext tag conf m1 -fore blue
465 $ctext tag conf m2 -fore green
466 $ctext tag conf m3 -fore purple
467 $ctext tag conf m4 -fore brown
468 $ctext tag conf mmax -fore darkgrey
470 $ctext tag conf mresult -font [concat $textfont bold]
471 $ctext tag conf msep -font [concat $textfont bold]
472 $ctext tag conf found -back yellow
475 frame .ctop.cdet.right
476 set cflist .ctop.cdet.right.cfiles
477 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
478 -yscrollcommand ".ctop.cdet.right.sb set"
479 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
480 pack .ctop.cdet.right.sb -side right -fill y
481 pack $cflist -side left -fill both -expand 1
482 .ctop.cdet add .ctop.cdet.right
483 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
485 pack .ctop -side top -fill both -expand 1
487 bindall <1> {selcanvline %W %x %y}
488 #bindall <B1-Motion> {selcanvline %W %x %y}
489 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
490 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
491 bindall <2> "allcanvs scan mark 0 %y"
492 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
493 bind . <Key-Up> "selnextline -1"
494 bind . <Key-Down> "selnextline 1"
495 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
496 bind . <Key-Next> "allcanvs yview scroll 1 pages"
497 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
498 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
499 bindkey <Key-space> "$ctext yview scroll 1 pages"
500 bindkey p "selnextline -1"
501 bindkey n "selnextline 1"
502 bindkey b "$ctext yview scroll -1 pages"
503 bindkey d "$ctext yview scroll 18 units"
504 bindkey u "$ctext yview scroll -18 units"
505 bindkey / {findnext 1}
506 bindkey <Key-Return> {findnext 0}
509 bind . <Control-q> doquit
510 bind . <Control-f> dofind
511 bind . <Control-g> {findnext 0}
512 bind . <Control-r> findprev
513 bind . <Control-equal> {incrfont 1}
514 bind . <Control-KP_Add> {incrfont 1}
515 bind . <Control-minus> {incrfont -1}
516 bind . <Control-KP_Subtract> {incrfont -1}
517 bind $cflist <<ListboxSelect>> listboxsel
518 bind . <Destroy> {savestuff %W}
519 bind . <Button-1> "click %W"
520 bind $fstring <Key-Return> dofind
521 bind $sha1entry <Key-Return> gotocommit
522 bind $sha1entry <<PasteSelection>> clearsha1
524 set maincursor [. cget -cursor]
525 set textcursor [$ctext cget -cursor]
526 set curtextcursor $textcursor
528 set rowctxmenu .rowctxmenu
529 menu $rowctxmenu -tearoff 0
530 $rowctxmenu add command -label "Diff this -> selected" \
531 -command {diffvssel 0}
532 $rowctxmenu add command -label "Diff selected -> this" \
533 -command {diffvssel 1}
534 $rowctxmenu add command -label "Make patch" -command mkpatch
535 $rowctxmenu add command -label "Create tag" -command mktag
536 $rowctxmenu add command -label "Write commit to file" -command writecommit
539 # when we make a key binding for the toplevel, make sure
540 # it doesn't get triggered when that key is pressed in the
541 # find string entry widget.
542 proc bindkey {ev script} {
545 set escript [bind Entry $ev]
546 if {$escript == {}} {
547 set escript [bind Entry <Key>]
550 bind $e $ev "$escript; break"
554 # set the focus back to the toplevel for any click outside
565 global canv canv2 canv3 ctext cflist mainfont textfont
566 global stuffsaved findmergefiles gaudydiff maxgraphpct
568 if {$stuffsaved} return
569 if {![winfo viewable .]} return
571 set f [open "~/.gitk-new" w]
572 puts $f [list set mainfont $mainfont]
573 puts $f [list set textfont $textfont]
574 puts $f [list set findmergefiles $findmergefiles]
575 puts $f [list set gaudydiff $gaudydiff]
576 puts $f [list set maxgraphpct $maxgraphpct]
577 puts $f "set geometry(width) [winfo width .ctop]"
578 puts $f "set geometry(height) [winfo height .ctop]"
579 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
580 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
581 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
582 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
583 set wid [expr {([winfo width $ctext] - 8) \
584 / [font measure $textfont "0"]}]
585 puts $f "set geometry(ctextw) $wid"
586 set wid [expr {([winfo width $cflist] - 11) \
587 / [font measure [$cflist cget -font] "0"]}]
588 puts $f "set geometry(cflistw) $wid"
590 file rename -force "~/.gitk-new" "~/.gitk"
595 proc resizeclistpanes {win w} {
597 if [info exists oldwidth($win)] {
598 set s0 [$win sash coord 0]
599 set s1 [$win sash coord 1]
601 set sash0 [expr {int($w/2 - 2)}]
602 set sash1 [expr {int($w*5/6 - 2)}]
604 set factor [expr {1.0 * $w / $oldwidth($win)}]
605 set sash0 [expr {int($factor * [lindex $s0 0])}]
606 set sash1 [expr {int($factor * [lindex $s1 0])}]
610 if {$sash1 < $sash0 + 20} {
611 set sash1 [expr $sash0 + 20]
613 if {$sash1 > $w - 10} {
614 set sash1 [expr $w - 10]
615 if {$sash0 > $sash1 - 20} {
616 set sash0 [expr $sash1 - 20]
620 $win sash place 0 $sash0 [lindex $s0 1]
621 $win sash place 1 $sash1 [lindex $s1 1]
623 set oldwidth($win) $w
626 proc resizecdetpanes {win w} {
628 if [info exists oldwidth($win)] {
629 set s0 [$win sash coord 0]
631 set sash0 [expr {int($w*3/4 - 2)}]
633 set factor [expr {1.0 * $w / $oldwidth($win)}]
634 set sash0 [expr {int($factor * [lindex $s0 0])}]
638 if {$sash0 > $w - 15} {
639 set sash0 [expr $w - 15]
642 $win sash place 0 $sash0 [lindex $s0 1]
644 set oldwidth($win) $w
648 global canv canv2 canv3
654 proc bindall {event action} {
655 global canv canv2 canv3
656 bind $canv $event $action
657 bind $canv2 $event $action
658 bind $canv3 $event $action
663 if {[winfo exists $w]} {
668 wm title $w "About gitk"
672 Copyright © 2005 Paul Mackerras
674 Use and redistribute under the terms of the GNU General Public License} \
675 -justify center -aspect 400
676 pack $w.m -side top -fill x -padx 20 -pady 20
677 button $w.ok -text Close -command "destroy $w"
678 pack $w.ok -side bottom
681 proc assigncolor {id} {
682 global commitinfo colormap commcolors colors nextcolor
683 global parents nparents children nchildren
684 global cornercrossings crossings
686 if [info exists colormap($id)] return
687 set ncolors [llength $colors]
688 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
689 set child [lindex $children($id) 0]
690 if {[info exists colormap($child)]
691 && $nparents($child) == 1} {
692 set colormap($id) $colormap($child)
697 if {[info exists cornercrossings($id)]} {
698 foreach x $cornercrossings($id) {
699 if {[info exists colormap($x)]
700 && [lsearch -exact $badcolors $colormap($x)] < 0} {
701 lappend badcolors $colormap($x)
704 if {[llength $badcolors] >= $ncolors} {
708 set origbad $badcolors
709 if {[llength $badcolors] < $ncolors - 1} {
710 if {[info exists crossings($id)]} {
711 foreach x $crossings($id) {
712 if {[info exists colormap($x)]
713 && [lsearch -exact $badcolors $colormap($x)] < 0} {
714 lappend badcolors $colormap($x)
717 if {[llength $badcolors] >= $ncolors} {
718 set badcolors $origbad
721 set origbad $badcolors
723 if {[llength $badcolors] < $ncolors - 1} {
724 foreach child $children($id) {
725 if {[info exists colormap($child)]
726 && [lsearch -exact $badcolors $colormap($child)] < 0} {
727 lappend badcolors $colormap($child)
729 if {[info exists parents($child)]} {
730 foreach p $parents($child) {
731 if {[info exists colormap($p)]
732 && [lsearch -exact $badcolors $colormap($p)] < 0} {
733 lappend badcolors $colormap($p)
738 if {[llength $badcolors] >= $ncolors} {
739 set badcolors $origbad
742 for {set i 0} {$i <= $ncolors} {incr i} {
743 set c [lindex $colors $nextcolor]
744 if {[incr nextcolor] >= $ncolors} {
747 if {[lsearch -exact $badcolors $c]} break
753 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
754 global mainline sidelines
755 global nchildren ncleft
762 set lthickness [expr {int($linespc / 9) + 1}]
763 catch {unset mainline}
764 catch {unset sidelines}
765 foreach id [array names nchildren] {
766 set ncleft($id) $nchildren($id)
770 proc bindline {t id} {
773 $canv bind $t <Enter> "lineenter %x %y $id"
774 $canv bind $t <Motion> "linemotion %x %y $id"
775 $canv bind $t <Leave> "lineleave $id"
776 $canv bind $t <Button-1> "lineclick %x %y $id 1"
779 proc drawcommitline {level} {
780 global parents children nparents nchildren todo
781 global canv canv2 canv3 mainfont namefont canvy linespc
782 global lineid linehtag linentag linedtag commitinfo
783 global colormap numcommits currentparents dupparents
784 global oldlevel oldnlines oldtodo
785 global idtags idline idheads
786 global lineno lthickness mainline sidelines
787 global commitlisted rowtextx idpos
791 set id [lindex $todo $level]
792 set lineid($lineno) $id
793 set idline($id) $lineno
794 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
795 if {![info exists commitinfo($id)]} {
797 if {![info exists commitinfo($id)]} {
798 set commitinfo($id) {"No commit information available"}
803 set currentparents {}
805 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
806 foreach p $parents($id) {
807 if {[lsearch -exact $currentparents $p] < 0} {
808 lappend currentparents $p
810 # remember that this parent was listed twice
811 lappend dupparents $p
815 set x [xcoord $level $level $lineno]
817 set canvy [expr $canvy + $linespc]
818 allcanvs conf -scrollregion \
819 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
820 if {[info exists mainline($id)]} {
821 lappend mainline($id) $x $y1
822 set t [$canv create line $mainline($id) \
823 -width $lthickness -fill $colormap($id)]
827 if {[info exists sidelines($id)]} {
828 foreach ls $sidelines($id) {
829 set coords [lindex $ls 0]
830 set thick [lindex $ls 1]
831 set t [$canv create line $coords -fill $colormap($id) \
832 -width [expr {$thick * $lthickness}]]
837 set orad [expr {$linespc / 3}]
838 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
839 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
840 -fill $ofill -outline black -width 1]
842 $canv bind $t <1> {selcanvline {} %x %y}
843 set xt [xcoord [llength $todo] $level $lineno]
844 if {[llength $currentparents] > 2} {
845 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
847 set rowtextx($lineno) $xt
848 set idpos($id) [list $x $xt $y1]
849 if {[info exists idtags($id)] || [info exists idheads($id)]} {
850 set xt [drawtags $id $x $xt $y1]
852 set headline [lindex $commitinfo($id) 0]
853 set name [lindex $commitinfo($id) 1]
854 set date [lindex $commitinfo($id) 2]
855 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
856 -text $headline -font $mainfont ]
857 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
858 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
859 -text $name -font $namefont]
860 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
861 -text $date -font $mainfont]
864 proc drawtags {id x xt y1} {
865 global idtags idheads
866 global linespc lthickness
871 if {[info exists idtags($id)]} {
872 set marks $idtags($id)
873 set ntags [llength $marks]
875 if {[info exists idheads($id)]} {
876 set marks [concat $marks $idheads($id)]
882 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
883 set yt [expr $y1 - 0.5 * $linespc]
884 set yb [expr $yt + $linespc - 1]
888 set wid [font measure $mainfont $tag]
891 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
893 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
894 -width $lthickness -fill black -tags tag.$id]
896 foreach tag $marks x $xvals wid $wvals {
897 set xl [expr $x + $delta]
898 set xr [expr $x + $delta + $wid + $lthickness]
899 if {[incr ntags -1] >= 0} {
901 $canv create polygon $x [expr $yt + $delta] $xl $yt\
902 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
903 -width 1 -outline black -fill yellow -tags tag.$id
906 set xl [expr $xl - $delta/2]
907 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
908 -width 1 -outline black -fill green -tags tag.$id
910 $canv create text $xl $y1 -anchor w -text $tag \
911 -font $mainfont -tags tag.$id
916 proc updatetodo {level noshortcut} {
917 global currentparents ncleft todo
918 global mainline oldlevel oldtodo oldnlines
919 global canvy linespc mainline
920 global commitinfo lineno xspc1
924 set oldnlines [llength $todo]
925 if {!$noshortcut && [llength $currentparents] == 1} {
926 set p [lindex $currentparents 0]
927 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
929 set x [xcoord $level $level $lineno]
930 set y [expr $canvy - $linespc]
931 set mainline($p) [list $x $y]
932 set todo [lreplace $todo $level $level $p]
933 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
938 set todo [lreplace $todo $level $level]
940 foreach p $currentparents {
942 set k [lsearch -exact $todo $p]
944 set todo [linsert $todo $i $p]
951 proc notecrossings {id lo hi corner} {
952 global oldtodo crossings cornercrossings
954 for {set i $lo} {[incr i] < $hi} {} {
955 set p [lindex $oldtodo $i]
956 if {$p == {}} continue
958 if {![info exists cornercrossings($id)]
959 || [lsearch -exact $cornercrossings($id) $p] < 0} {
960 lappend cornercrossings($id) $p
962 if {![info exists cornercrossings($p)]
963 || [lsearch -exact $cornercrossings($p) $id] < 0} {
964 lappend cornercrossings($p) $id
967 if {![info exists crossings($id)]
968 || [lsearch -exact $crossings($id) $p] < 0} {
969 lappend crossings($id) $p
971 if {![info exists crossings($p)]
972 || [lsearch -exact $crossings($p) $id] < 0} {
973 lappend crossings($p) $id
979 proc xcoord {i level ln} {
980 global canvx0 xspc1 xspc2
982 set x [expr {$canvx0 + $i * $xspc1($ln)}]
983 if {$i > 0 && $i == $level} {
984 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
985 } elseif {$i > $level} {
986 set x [expr {$x + $xspc2 - $xspc1($ln)}]
991 proc drawslants {level} {
992 global canv mainline sidelines canvx0 canvy xspc1 xspc2 lthickness
993 global oldlevel oldtodo todo currentparents dupparents
994 global lthickness linespc canvy colormap lineno geometry
997 # decide on the line spacing for the next line
998 set lj [expr {$lineno + 1}]
999 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1000 set n [llength $todo]
1001 if {$n <= 1 || $canvx0 + $n * $xspc2 <= $maxw} {
1002 set xspc1($lj) $xspc2
1004 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($n - 1)}]
1005 if {$xspc1($lj) < $lthickness} {
1006 set xspc1($lj) $lthickness
1010 set y1 [expr $canvy - $linespc]
1013 foreach id $oldtodo {
1015 if {$id == {}} continue
1016 set xi [xcoord $i $oldlevel $lineno]
1017 if {$i == $oldlevel} {
1018 foreach p $currentparents {
1019 set j [lsearch -exact $todo $p]
1020 set coords [list $xi $y1]
1021 set xj [xcoord $j $level $lj]
1022 if {$xj < $xi - $linespc} {
1023 lappend coords [expr {$xj + $linespc}] $y1
1024 notecrossings $p $j $i [expr {$j + 1}]
1025 } elseif {$xj > $xi + $linespc} {
1026 lappend coords [expr {$xj - $linespc}] $y1
1027 notecrossings $p $i $j [expr {$j - 1}]
1029 if {[lsearch -exact $dupparents $p] >= 0} {
1030 # draw a double-width line to indicate the doubled parent
1031 lappend coords $xj $y2
1032 lappend sidelines($p) [list $coords 2]
1033 if {![info exists mainline($p)]} {
1034 set mainline($p) [list $xj $y2]
1037 # normal case, no parent duplicated
1039 set dx [expr {abs($xi - $xj)}]
1040 if {0 && $dx < $linespc} {
1041 set yb [expr {$y1 + $dx}]
1043 if {![info exists mainline($p)]} {
1045 lappend coords $xj $yb
1047 set mainline($p) $coords
1049 lappend coords $xj $yb
1051 lappend coords $xj $y2
1053 lappend sidelines($p) [list $coords 1]
1059 if {[lindex $todo $i] != $id} {
1060 set j [lsearch -exact $todo $id]
1062 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1063 || ($oldlevel <= $i && $i <= $level)
1064 || ($level <= $i && $i <= $oldlevel)} {
1065 set xj [xcoord $j $level $lj]
1066 set dx [expr {abs($xi - $xj)}]
1068 if {0 && $dx < $linespc} {
1069 set yb [expr {$y1 + $dx}]
1071 lappend mainline($id) $xi $y1 $xj $yb
1077 proc decidenext {{noread 0}} {
1078 global parents children nchildren ncleft todo
1079 global canv canv2 canv3 mainfont namefont canvy linespc
1080 global datemode cdate
1082 global currentparents oldlevel oldnlines oldtodo
1083 global lineno lthickness
1085 # remove the null entry if present
1086 set nullentry [lsearch -exact $todo {}]
1087 if {$nullentry >= 0} {
1088 set todo [lreplace $todo $nullentry $nullentry]
1091 # choose which one to do next time around
1092 set todol [llength $todo]
1095 for {set k $todol} {[incr k -1] >= 0} {} {
1096 set p [lindex $todo $k]
1097 if {$ncleft($p) == 0} {
1099 if {![info exists commitinfo($p)]} {
1105 if {$latest == {} || $cdate($p) > $latest} {
1107 set latest $cdate($p)
1117 puts "ERROR: none of the pending commits can be done yet:"
1119 puts " $p ($ncleft($p))"
1125 # If we are reducing, put in a null entry
1126 if {$todol < $oldnlines} {
1127 if {$nullentry >= 0} {
1130 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1140 set todo [linsert $todo $i {}]
1149 proc drawcommit {id} {
1150 global phase todo nchildren datemode nextupdate
1151 global startcommits numcommits ncmupdate
1153 if {$phase != "incrdraw"} {
1156 set startcommits $id
1159 updatetodo 0 $datemode
1161 if {$nchildren($id) == 0} {
1163 lappend startcommits $id
1165 set level [decidenext 1]
1166 if {$level == {} || $id != [lindex $todo $level]} {
1171 drawcommitline $level
1172 if {[updatetodo $level $datemode]} {
1173 set level [decidenext 1]
1174 if {$level == {}} break
1176 set id [lindex $todo $level]
1177 if {![info exists commitlisted($id)]} {
1180 if {[clock clicks -milliseconds] >= $nextupdate
1181 && $numcommits >= $ncmupdate} {
1189 proc finishcommits {} {
1192 global canv mainfont ctext maincursor textcursor
1194 if {$phase != "incrdraw"} {
1196 $canv create text 3 3 -anchor nw -text "No commits selected" \
1197 -font $mainfont -tags textitems
1200 set level [decidenext]
1202 drawrest $level [llength $startcommits]
1204 . config -cursor $maincursor
1205 settextcursor $textcursor
1208 # Don't change the text pane cursor if it is currently the hand cursor,
1209 # showing that we are over a sha1 ID link.
1210 proc settextcursor {c} {
1211 global ctext curtextcursor
1213 if {[$ctext cget -cursor] == $curtextcursor} {
1214 $ctext config -cursor $c
1216 set curtextcursor $c
1220 global nextupdate startmsecs startcommits todo ncmupdate
1222 if {$startcommits == {}} return
1223 set startmsecs [clock clicks -milliseconds]
1224 set nextupdate [expr $startmsecs + 100]
1227 set todo [lindex $startcommits 0]
1231 proc drawrest {level startix} {
1232 global phase stopped redisplaying selectedline
1233 global datemode currentparents todo
1234 global numcommits ncmupdate
1235 global nextupdate startmsecs startcommits idline
1239 set startid [lindex $startcommits $startix]
1241 if {$startid != {}} {
1242 set startline $idline($startid)
1246 drawcommitline $level
1247 set hard [updatetodo $level $datemode]
1248 if {$numcommits == $startline} {
1249 lappend todo $startid
1252 set startid [lindex $startcommits $startix]
1254 if {$startid != {}} {
1255 set startline $idline($startid)
1259 set level [decidenext]
1260 if {$level < 0} break
1263 if {[clock clicks -milliseconds] >= $nextupdate
1264 && $numcommits >= $ncmupdate} {
1270 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1271 #puts "overall $drawmsecs ms for $numcommits commits"
1272 if {$redisplaying} {
1273 if {$stopped == 0 && [info exists selectedline]} {
1274 selectline $selectedline 0
1276 if {$stopped == 1} {
1278 after idle drawgraph
1285 proc findmatches {f} {
1286 global findtype foundstring foundstrlen
1287 if {$findtype == "Regexp"} {
1288 set matches [regexp -indices -all -inline $foundstring $f]
1290 if {$findtype == "IgnCase"} {
1291 set str [string tolower $f]
1297 while {[set j [string first $foundstring $str $i]] >= 0} {
1298 lappend matches [list $j [expr $j+$foundstrlen-1]]
1299 set i [expr $j + $foundstrlen]
1306 global findtype findloc findstring markedmatches commitinfo
1307 global numcommits lineid linehtag linentag linedtag
1308 global mainfont namefont canv canv2 canv3 selectedline
1309 global matchinglines foundstring foundstrlen
1314 set matchinglines {}
1315 if {$findloc == "Pickaxe"} {
1319 if {$findtype == "IgnCase"} {
1320 set foundstring [string tolower $findstring]
1322 set foundstring $findstring
1324 set foundstrlen [string length $findstring]
1325 if {$foundstrlen == 0} return
1326 if {$findloc == "Files"} {
1330 if {![info exists selectedline]} {
1333 set oldsel $selectedline
1336 set fldtypes {Headline Author Date Committer CDate Comment}
1337 for {set l 0} {$l < $numcommits} {incr l} {
1339 set info $commitinfo($id)
1341 foreach f $info ty $fldtypes {
1342 if {$findloc != "All fields" && $findloc != $ty} {
1345 set matches [findmatches $f]
1346 if {$matches == {}} continue
1348 if {$ty == "Headline"} {
1349 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1350 } elseif {$ty == "Author"} {
1351 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1352 } elseif {$ty == "Date"} {
1353 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1357 lappend matchinglines $l
1358 if {!$didsel && $l > $oldsel} {
1364 if {$matchinglines == {}} {
1366 } elseif {!$didsel} {
1367 findselectline [lindex $matchinglines 0]
1371 proc findselectline {l} {
1372 global findloc commentend ctext
1374 if {$findloc == "All fields" || $findloc == "Comments"} {
1375 # highlight the matches in the comments
1376 set f [$ctext get 1.0 $commentend]
1377 set matches [findmatches $f]
1378 foreach match $matches {
1379 set start [lindex $match 0]
1380 set end [expr [lindex $match 1] + 1]
1381 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1386 proc findnext {restart} {
1387 global matchinglines selectedline
1388 if {![info exists matchinglines]} {
1394 if {![info exists selectedline]} return
1395 foreach l $matchinglines {
1396 if {$l > $selectedline} {
1405 global matchinglines selectedline
1406 if {![info exists matchinglines]} {
1410 if {![info exists selectedline]} return
1412 foreach l $matchinglines {
1413 if {$l >= $selectedline} break
1417 findselectline $prev
1423 proc findlocchange {name ix op} {
1424 global findloc findtype findtypemenu
1425 if {$findloc == "Pickaxe"} {
1431 $findtypemenu entryconf 1 -state $state
1432 $findtypemenu entryconf 2 -state $state
1435 proc stopfindproc {{done 0}} {
1436 global findprocpid findprocfile findids
1437 global ctext findoldcursor phase maincursor textcursor
1438 global findinprogress
1440 catch {unset findids}
1441 if {[info exists findprocpid]} {
1443 catch {exec kill $findprocpid}
1445 catch {close $findprocfile}
1448 if {[info exists findinprogress]} {
1449 unset findinprogress
1450 if {$phase != "incrdraw"} {
1451 . config -cursor $maincursor
1452 settextcursor $textcursor
1457 proc findpatches {} {
1458 global findstring selectedline numcommits
1459 global findprocpid findprocfile
1460 global finddidsel ctext lineid findinprogress
1461 global findinsertpos
1463 if {$numcommits == 0} return
1465 # make a list of all the ids to search, starting at the one
1466 # after the selected line (if any)
1467 if {[info exists selectedline]} {
1473 for {set i 0} {$i < $numcommits} {incr i} {
1474 if {[incr l] >= $numcommits} {
1477 append inputids $lineid($l) "\n"
1481 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1484 error_popup "Error starting search process: $err"
1488 set findinsertpos end
1490 set findprocpid [pid $f]
1491 fconfigure $f -blocking 0
1492 fileevent $f readable readfindproc
1494 . config -cursor watch
1496 set findinprogress 1
1499 proc readfindproc {} {
1500 global findprocfile finddidsel
1501 global idline matchinglines findinsertpos
1503 set n [gets $findprocfile line]
1505 if {[eof $findprocfile]} {
1513 if {![regexp {^[0-9a-f]{40}} $line id]} {
1514 error_popup "Can't parse git-diff-tree output: $line"
1518 if {![info exists idline($id)]} {
1519 puts stderr "spurious id: $id"
1526 proc insertmatch {l id} {
1527 global matchinglines findinsertpos finddidsel
1529 if {$findinsertpos == "end"} {
1530 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1531 set matchinglines [linsert $matchinglines 0 $l]
1534 lappend matchinglines $l
1537 set matchinglines [linsert $matchinglines $findinsertpos $l]
1548 global selectedline numcommits lineid ctext
1549 global ffileline finddidsel parents nparents
1550 global findinprogress findstartline findinsertpos
1551 global treediffs fdiffids fdiffsneeded fdiffpos
1552 global findmergefiles
1554 if {$numcommits == 0} return
1556 if {[info exists selectedline]} {
1557 set l [expr {$selectedline + 1}]
1562 set findstartline $l
1567 if {$findmergefiles || $nparents($id) == 1} {
1568 foreach p $parents($id) {
1569 if {![info exists treediffs([list $id $p])]} {
1570 append diffsneeded "$id $p\n"
1571 lappend fdiffsneeded [list $id $p]
1575 if {[incr l] >= $numcommits} {
1578 if {$l == $findstartline} break
1581 # start off a git-diff-tree process if needed
1582 if {$diffsneeded ne {}} {
1584 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1586 error_popup "Error starting search process: $err"
1589 catch {unset fdiffids}
1591 fconfigure $df -blocking 0
1592 fileevent $df readable [list readfilediffs $df]
1596 set findinsertpos end
1598 set p [lindex $parents($id) 0]
1599 . config -cursor watch
1601 set findinprogress 1
1602 findcont [list $id $p]
1606 proc readfilediffs {df} {
1607 global findids fdiffids fdiffs
1609 set n [gets $df line]
1613 if {[catch {close $df} err]} {
1616 error_popup "Error in git-diff-tree: $err"
1617 } elseif {[info exists findids]} {
1621 error_popup "Couldn't find diffs for {$ids}"
1626 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1627 # start of a new string of diffs
1629 set fdiffids [list $id $p]
1631 } elseif {[string match ":*" $line]} {
1632 lappend fdiffs [lindex $line 5]
1636 proc donefilediff {} {
1637 global fdiffids fdiffs treediffs findids
1638 global fdiffsneeded fdiffpos
1640 if {[info exists fdiffids]} {
1641 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1642 && $fdiffpos < [llength $fdiffsneeded]} {
1643 # git-diff-tree doesn't output anything for a commit
1644 # which doesn't change anything
1645 set nullids [lindex $fdiffsneeded $fdiffpos]
1646 set treediffs($nullids) {}
1647 if {[info exists findids] && $nullids eq $findids} {
1655 if {![info exists treediffs($fdiffids)]} {
1656 set treediffs($fdiffids) $fdiffs
1658 if {[info exists findids] && $fdiffids eq $findids} {
1665 proc findcont {ids} {
1666 global findids treediffs parents nparents
1667 global ffileline findstartline finddidsel
1668 global lineid numcommits matchinglines findinprogress
1669 global findmergefiles
1671 set id [lindex $ids 0]
1672 set p [lindex $ids 1]
1673 set pi [lsearch -exact $parents($id) $p]
1676 if {$findmergefiles || $nparents($id) == 1} {
1677 if {![info exists treediffs($ids)]} {
1683 foreach f $treediffs($ids) {
1684 set x [findmatches $f]
1692 set pi $nparents($id)
1695 set pi $nparents($id)
1697 if {[incr pi] >= $nparents($id)} {
1699 if {[incr l] >= $numcommits} {
1702 if {$l == $findstartline} break
1705 set p [lindex $parents($id) $pi]
1706 set ids [list $id $p]
1714 # mark a commit as matching by putting a yellow background
1715 # behind the headline
1716 proc markheadline {l id} {
1717 global canv mainfont linehtag commitinfo
1719 set bbox [$canv bbox $linehtag($l)]
1720 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1724 # mark the bits of a headline, author or date that match a find string
1725 proc markmatches {canv l str tag matches font} {
1726 set bbox [$canv bbox $tag]
1727 set x0 [lindex $bbox 0]
1728 set y0 [lindex $bbox 1]
1729 set y1 [lindex $bbox 3]
1730 foreach match $matches {
1731 set start [lindex $match 0]
1732 set end [lindex $match 1]
1733 if {$start > $end} continue
1734 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1735 set xlen [font measure $font [string range $str 0 [expr $end]]]
1736 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1737 -outline {} -tags matches -fill yellow]
1742 proc unmarkmatches {} {
1743 global matchinglines findids
1744 allcanvs delete matches
1745 catch {unset matchinglines}
1746 catch {unset findids}
1749 proc selcanvline {w x y} {
1750 global canv canvy0 ctext linespc
1751 global lineid linehtag linentag linedtag rowtextx
1752 set ymax [lindex [$canv cget -scrollregion] 3]
1753 if {$ymax == {}} return
1754 set yfrac [lindex [$canv yview] 0]
1755 set y [expr {$y + $yfrac * $ymax}]
1756 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1761 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1767 proc commit_descriptor {p} {
1770 if {[info exists commitinfo($p)]} {
1771 set l [lindex $commitinfo($p) 0]
1776 proc selectline {l isnew} {
1777 global canv canv2 canv3 ctext commitinfo selectedline
1778 global lineid linehtag linentag linedtag
1779 global canvy0 linespc parents nparents children nchildren
1780 global cflist currentid sha1entry
1781 global commentend idtags idline
1784 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1786 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1787 -tags secsel -fill [$canv cget -selectbackground]]
1789 $canv2 delete secsel
1790 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1791 -tags secsel -fill [$canv2 cget -selectbackground]]
1793 $canv3 delete secsel
1794 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1795 -tags secsel -fill [$canv3 cget -selectbackground]]
1797 set y [expr {$canvy0 + $l * $linespc}]
1798 set ymax [lindex [$canv cget -scrollregion] 3]
1799 set ytop [expr {$y - $linespc - 1}]
1800 set ybot [expr {$y + $linespc + 1}]
1801 set wnow [$canv yview]
1802 set wtop [expr [lindex $wnow 0] * $ymax]
1803 set wbot [expr [lindex $wnow 1] * $ymax]
1804 set wh [expr {$wbot - $wtop}]
1806 if {$ytop < $wtop} {
1807 if {$ybot < $wtop} {
1808 set newtop [expr {$y - $wh / 2.0}]
1811 if {$newtop > $wtop - $linespc} {
1812 set newtop [expr {$wtop - $linespc}]
1815 } elseif {$ybot > $wbot} {
1816 if {$ytop > $wbot} {
1817 set newtop [expr {$y - $wh / 2.0}]
1819 set newtop [expr {$ybot - $wh}]
1820 if {$newtop < $wtop + $linespc} {
1821 set newtop [expr {$wtop + $linespc}]
1825 if {$newtop != $wtop} {
1829 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1833 addtohistory [list selectline $l 0]
1840 $sha1entry delete 0 end
1841 $sha1entry insert 0 $id
1842 $sha1entry selection from 0
1843 $sha1entry selection to end
1845 $ctext conf -state normal
1846 $ctext delete 0.0 end
1847 $ctext mark set fmark.0 0.0
1848 $ctext mark gravity fmark.0 left
1849 set info $commitinfo($id)
1850 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1851 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1852 if {[info exists idtags($id)]} {
1853 $ctext insert end "Tags:"
1854 foreach tag $idtags($id) {
1855 $ctext insert end " $tag"
1857 $ctext insert end "\n"
1860 set commentstart [$ctext index "end - 1c"]
1862 if {[info exists parents($id)]} {
1863 foreach p $parents($id) {
1864 append comment "Parent: [commit_descriptor $p]\n"
1867 if {[info exists children($id)]} {
1868 foreach c $children($id) {
1869 append comment "Child: [commit_descriptor $c]\n"
1873 append comment [lindex $info 5]
1874 $ctext insert end $comment
1875 $ctext insert end "\n"
1877 # make anything that looks like a SHA1 ID be a clickable link
1878 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
1883 set linkid [string range $comment $s $e]
1884 if {![info exists idline($linkid)]} continue
1886 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
1887 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
1888 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
1891 $ctext tag conf link -foreground blue -underline 1
1892 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
1893 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
1895 $ctext tag delete Comments
1896 $ctext tag remove found 1.0 end
1897 $ctext conf -state disabled
1898 set commentend [$ctext index "end - 1c"]
1900 $cflist delete 0 end
1901 $cflist insert end "Comments"
1902 if {$nparents($id) == 1} {
1903 startdiff [concat $id $parents($id)]
1904 } elseif {$nparents($id) > 1} {
1909 proc selnextline {dir} {
1911 if {![info exists selectedline]} return
1912 set l [expr $selectedline + $dir]
1917 proc unselectline {} {
1920 catch {unset selectedline}
1921 allcanvs delete secsel
1924 proc addtohistory {cmd} {
1925 global history historyindex
1927 if {$historyindex > 0
1928 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
1932 if {$historyindex < [llength $history]} {
1933 set history [lreplace $history $historyindex end $cmd]
1935 lappend history $cmd
1938 if {$historyindex > 1} {
1939 .ctop.top.bar.leftbut conf -state normal
1941 .ctop.top.bar.leftbut conf -state disabled
1943 .ctop.top.bar.rightbut conf -state disabled
1947 global history historyindex
1949 if {$historyindex > 1} {
1950 incr historyindex -1
1951 set cmd [lindex $history [expr {$historyindex - 1}]]
1953 .ctop.top.bar.rightbut conf -state normal
1955 if {$historyindex <= 1} {
1956 .ctop.top.bar.leftbut conf -state disabled
1961 global history historyindex
1963 if {$historyindex < [llength $history]} {
1964 set cmd [lindex $history $historyindex]
1967 .ctop.top.bar.leftbut conf -state normal
1969 if {$historyindex >= [llength $history]} {
1970 .ctop.top.bar.rightbut conf -state disabled
1974 proc mergediff {id} {
1975 global parents diffmergeid diffmergegca mergefilelist diffpindex
1979 set diffmergegca [findgca $parents($id)]
1980 if {[info exists mergefilelist($id)]} {
1981 if {$mergefilelist($id) ne {}} {
1989 proc findgca {ids} {
1996 set gca [exec git-merge-base $gca $id]
2005 proc contmergediff {ids} {
2006 global diffmergeid diffpindex parents nparents diffmergegca
2007 global treediffs mergefilelist diffids treepending
2009 # diff the child against each of the parents, and diff
2010 # each of the parents against the GCA.
2012 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2013 set ids [list [lindex $ids 1] $diffmergegca]
2015 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2016 set p [lindex $parents($diffmergeid) $diffpindex]
2017 set ids [list $diffmergeid $p]
2019 if {![info exists treediffs($ids)]} {
2021 if {![info exists treepending]} {
2028 # If a file in some parent is different from the child and also
2029 # different from the GCA, then it's interesting.
2030 # If we don't have a GCA, then a file is interesting if it is
2031 # different from the child in all the parents.
2032 if {$diffmergegca ne {}} {
2034 foreach p $parents($diffmergeid) {
2035 set gcadiffs $treediffs([list $p $diffmergegca])
2036 foreach f $treediffs([list $diffmergeid $p]) {
2037 if {[lsearch -exact $files $f] < 0
2038 && [lsearch -exact $gcadiffs $f] >= 0} {
2043 set files [lsort $files]
2045 set p [lindex $parents($diffmergeid) 0]
2046 set files $treediffs([list $diffmergeid $p])
2047 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2048 set p [lindex $parents($diffmergeid) $i]
2049 set df $treediffs([list $diffmergeid $p])
2052 if {[lsearch -exact $df $f] >= 0} {
2060 set mergefilelist($diffmergeid) $files
2066 proc showmergediff {} {
2067 global cflist diffmergeid mergefilelist parents
2068 global diffopts diffinhunk currentfile currenthunk filelines
2069 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2071 set files $mergefilelist($diffmergeid)
2073 $cflist insert end $f
2075 set env(GIT_DIFF_OPTS) $diffopts
2077 catch {unset currentfile}
2078 catch {unset currenthunk}
2079 catch {unset filelines}
2080 catch {unset groupfilenum}
2081 catch {unset grouphunks}
2082 set groupfilelast -1
2083 foreach p $parents($diffmergeid) {
2084 set cmd [list | git-diff-tree -p $p $diffmergeid]
2085 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2086 if {[catch {set f [open $cmd r]} err]} {
2087 error_popup "Error getting diffs: $err"
2094 set ids [list $diffmergeid $p]
2095 set mergefds($ids) $f
2096 set diffinhunk($ids) 0
2097 set diffblocked($ids) 0
2098 fconfigure $f -blocking 0
2099 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2103 proc getmergediffline {f ids id} {
2104 global diffmergeid diffinhunk diffoldlines diffnewlines
2105 global currentfile currenthunk
2106 global diffoldstart diffnewstart diffoldlno diffnewlno
2107 global diffblocked mergefilelist
2108 global noldlines nnewlines difflcounts filelines
2110 set n [gets $f line]
2112 if {![eof $f]} return
2115 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2122 if {$diffinhunk($ids) != 0} {
2123 set fi $currentfile($ids)
2124 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2125 # continuing an existing hunk
2126 set line [string range $line 1 end]
2127 set p [lindex $ids 1]
2128 if {$match eq "-" || $match eq " "} {
2129 set filelines($p,$fi,$diffoldlno($ids)) $line
2130 incr diffoldlno($ids)
2132 if {$match eq "+" || $match eq " "} {
2133 set filelines($id,$fi,$diffnewlno($ids)) $line
2134 incr diffnewlno($ids)
2136 if {$match eq " "} {
2137 if {$diffinhunk($ids) == 2} {
2138 lappend difflcounts($ids) \
2139 [list $noldlines($ids) $nnewlines($ids)]
2140 set noldlines($ids) 0
2141 set diffinhunk($ids) 1
2143 incr noldlines($ids)
2144 } elseif {$match eq "-" || $match eq "+"} {
2145 if {$diffinhunk($ids) == 1} {
2146 lappend difflcounts($ids) [list $noldlines($ids)]
2147 set noldlines($ids) 0
2148 set nnewlines($ids) 0
2149 set diffinhunk($ids) 2
2151 if {$match eq "-"} {
2152 incr noldlines($ids)
2154 incr nnewlines($ids)
2157 # and if it's \ No newline at end of line, then what?
2161 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2162 lappend difflcounts($ids) [list $noldlines($ids)]
2163 } elseif {$diffinhunk($ids) == 2
2164 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2165 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2167 set currenthunk($ids) [list $currentfile($ids) \
2168 $diffoldstart($ids) $diffnewstart($ids) \
2169 $diffoldlno($ids) $diffnewlno($ids) \
2171 set diffinhunk($ids) 0
2172 # -1 = need to block, 0 = unblocked, 1 = is blocked
2173 set diffblocked($ids) -1
2175 if {$diffblocked($ids) == -1} {
2176 fileevent $f readable {}
2177 set diffblocked($ids) 1
2183 if {!$diffblocked($ids)} {
2185 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2186 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2189 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2190 # start of a new file
2191 set currentfile($ids) \
2192 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2193 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2194 $line match f1l f1c f2l f2c rest]} {
2195 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2196 # start of a new hunk
2197 if {$f1l == 0 && $f1c == 0} {
2200 if {$f2l == 0 && $f2c == 0} {
2203 set diffinhunk($ids) 1
2204 set diffoldstart($ids) $f1l
2205 set diffnewstart($ids) $f2l
2206 set diffoldlno($ids) $f1l
2207 set diffnewlno($ids) $f2l
2208 set difflcounts($ids) {}
2209 set noldlines($ids) 0
2210 set nnewlines($ids) 0
2215 proc processhunks {} {
2216 global diffmergeid parents nparents currenthunk
2217 global mergefilelist diffblocked mergefds
2218 global grouphunks grouplinestart grouplineend groupfilenum
2220 set nfiles [llength $mergefilelist($diffmergeid)]
2224 # look for the earliest hunk
2225 foreach p $parents($diffmergeid) {
2226 set ids [list $diffmergeid $p]
2227 if {![info exists currenthunk($ids)]} return
2228 set i [lindex $currenthunk($ids) 0]
2229 set l [lindex $currenthunk($ids) 2]
2230 if {$i < $fi || ($i == $fi && $l < $lno)} {
2237 if {$fi < $nfiles} {
2238 set ids [list $diffmergeid $pi]
2239 set hunk $currenthunk($ids)
2240 unset currenthunk($ids)
2241 if {$diffblocked($ids) > 0} {
2242 fileevent $mergefds($ids) readable \
2243 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2245 set diffblocked($ids) 0
2247 if {[info exists groupfilenum] && $groupfilenum == $fi
2248 && $lno <= $grouplineend} {
2249 # add this hunk to the pending group
2250 lappend grouphunks($pi) $hunk
2251 set endln [lindex $hunk 4]
2252 if {$endln > $grouplineend} {
2253 set grouplineend $endln
2259 # succeeding stuff doesn't belong in this group, so
2260 # process the group now
2261 if {[info exists groupfilenum]} {
2267 if {$fi >= $nfiles} break
2270 set groupfilenum $fi
2271 set grouphunks($pi) [list $hunk]
2272 set grouplinestart $lno
2273 set grouplineend [lindex $hunk 4]
2277 proc processgroup {} {
2278 global groupfilelast groupfilenum difffilestart
2279 global mergefilelist diffmergeid ctext filelines
2280 global parents diffmergeid diffoffset
2281 global grouphunks grouplinestart grouplineend nparents
2284 $ctext conf -state normal
2287 if {$groupfilelast != $f} {
2288 $ctext insert end "\n"
2289 set here [$ctext index "end - 1c"]
2290 set difffilestart($f) $here
2291 set mark fmark.[expr {$f + 1}]
2292 $ctext mark set $mark $here
2293 $ctext mark gravity $mark left
2294 set header [lindex $mergefilelist($id) $f]
2295 set l [expr {(78 - [string length $header]) / 2}]
2296 set pad [string range "----------------------------------------" 1 $l]
2297 $ctext insert end "$pad $header $pad\n" filesep
2298 set groupfilelast $f
2299 foreach p $parents($id) {
2300 set diffoffset($p) 0
2304 $ctext insert end "@@" msep
2305 set nlines [expr {$grouplineend - $grouplinestart}]
2308 foreach p $parents($id) {
2309 set startline [expr {$grouplinestart + $diffoffset($p)}]
2311 set nl $grouplinestart
2312 if {[info exists grouphunks($p)]} {
2313 foreach h $grouphunks($p) {
2316 for {} {$nl < $l} {incr nl} {
2317 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2321 foreach chunk [lindex $h 5] {
2322 if {[llength $chunk] == 2} {
2323 set olc [lindex $chunk 0]
2324 set nlc [lindex $chunk 1]
2325 set nnl [expr {$nl + $nlc}]
2326 lappend events [list $nl $nnl $pnum $olc $nlc]
2330 incr ol [lindex $chunk 0]
2331 incr nl [lindex $chunk 0]
2336 if {$nl < $grouplineend} {
2337 for {} {$nl < $grouplineend} {incr nl} {
2338 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2342 set nlines [expr {$ol - $startline}]
2343 $ctext insert end " -$startline,$nlines" msep
2347 set nlines [expr {$grouplineend - $grouplinestart}]
2348 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2350 set events [lsort -integer -index 0 $events]
2351 set nevents [llength $events]
2352 set nmerge $nparents($diffmergeid)
2353 set l $grouplinestart
2354 for {set i 0} {$i < $nevents} {set i $j} {
2355 set nl [lindex $events $i 0]
2357 $ctext insert end " $filelines($id,$f,$l)\n"
2360 set e [lindex $events $i]
2361 set enl [lindex $e 1]
2365 set pnum [lindex $e 2]
2366 set olc [lindex $e 3]
2367 set nlc [lindex $e 4]
2368 if {![info exists delta($pnum)]} {
2369 set delta($pnum) [expr {$olc - $nlc}]
2370 lappend active $pnum
2372 incr delta($pnum) [expr {$olc - $nlc}]
2374 if {[incr j] >= $nevents} break
2375 set e [lindex $events $j]
2376 if {[lindex $e 0] >= $enl} break
2377 if {[lindex $e 1] > $enl} {
2378 set enl [lindex $e 1]
2381 set nlc [expr {$enl - $l}]
2384 if {[llength $active] == $nmerge - 1} {
2385 # no diff for one of the parents, i.e. it's identical
2386 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2387 if {![info exists delta($pnum)]} {
2388 if {$pnum < $mergemax} {
2396 } elseif {[llength $active] == $nmerge} {
2397 # all parents are different, see if one is very similar
2399 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2400 set sim [similarity $pnum $l $nlc $f \
2401 [lrange $events $i [expr {$j-1}]]]
2402 if {$sim > $bestsim} {
2408 lappend ncol m$bestpn
2412 foreach p $parents($id) {
2414 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2415 set olc [expr {$nlc + $delta($pnum)}]
2416 set ol [expr {$l + $diffoffset($p)}]
2417 incr diffoffset($p) $delta($pnum)
2419 for {} {$olc > 0} {incr olc -1} {
2420 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2424 set endl [expr {$l + $nlc}]
2426 # show this pretty much as a normal diff
2427 set p [lindex $parents($id) $bestpn]
2428 set ol [expr {$l + $diffoffset($p)}]
2429 incr diffoffset($p) $delta($bestpn)
2430 unset delta($bestpn)
2431 for {set k $i} {$k < $j} {incr k} {
2432 set e [lindex $events $k]
2433 if {[lindex $e 2] != $bestpn} continue
2434 set nl [lindex $e 0]
2435 set ol [expr {$ol + $nl - $l}]
2436 for {} {$l < $nl} {incr l} {
2437 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2440 for {} {$c > 0} {incr c -1} {
2441 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2444 set nl [lindex $e 1]
2445 for {} {$l < $nl} {incr l} {
2446 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2450 for {} {$l < $endl} {incr l} {
2451 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2454 while {$l < $grouplineend} {
2455 $ctext insert end " $filelines($id,$f,$l)\n"
2458 $ctext conf -state disabled
2461 proc similarity {pnum l nlc f events} {
2462 global diffmergeid parents diffoffset filelines
2465 set p [lindex $parents($id) $pnum]
2466 set ol [expr {$l + $diffoffset($p)}]
2467 set endl [expr {$l + $nlc}]
2471 if {[lindex $e 2] != $pnum} continue
2472 set nl [lindex $e 0]
2473 set ol [expr {$ol + $nl - $l}]
2474 for {} {$l < $nl} {incr l} {
2475 incr same [string length $filelines($id,$f,$l)]
2478 set oc [lindex $e 3]
2479 for {} {$oc > 0} {incr oc -1} {
2480 incr diff [string length $filelines($p,$f,$ol)]
2484 set nl [lindex $e 1]
2485 for {} {$l < $nl} {incr l} {
2486 incr diff [string length $filelines($id,$f,$l)]
2490 for {} {$l < $endl} {incr l} {
2491 incr same [string length $filelines($id,$f,$l)]
2497 return [expr {200 * $same / (2 * $same + $diff)}]
2500 proc startdiff {ids} {
2501 global treediffs diffids treepending diffmergeid
2504 catch {unset diffmergeid}
2505 if {![info exists treediffs($ids)]} {
2506 if {![info exists treepending]} {
2514 proc addtocflist {ids} {
2515 global treediffs cflist
2516 foreach f $treediffs($ids) {
2517 $cflist insert end $f
2522 proc gettreediffs {ids} {
2523 global treediff parents treepending
2524 set treepending $ids
2526 set id [lindex $ids 0]
2527 set p [lindex $ids 1]
2528 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2529 fconfigure $gdtf -blocking 0
2530 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2533 proc gettreediffline {gdtf ids} {
2534 global treediff treediffs treepending diffids diffmergeid
2536 set n [gets $gdtf line]
2538 if {![eof $gdtf]} return
2540 set treediffs($ids) $treediff
2542 if {$ids != $diffids} {
2543 gettreediffs $diffids
2545 if {[info exists diffmergeid]} {
2553 set file [lindex $line 5]
2554 lappend treediff $file
2557 proc getblobdiffs {ids} {
2558 global diffopts blobdifffd diffids env curdifftag curtagstart
2559 global difffilestart nextupdate diffinhdr treediffs
2561 set id [lindex $ids 0]
2562 set p [lindex $ids 1]
2563 set env(GIT_DIFF_OPTS) $diffopts
2564 set cmd [list | git-diff-tree -r -p -C $p $id]
2565 if {[catch {set bdf [open $cmd r]} err]} {
2566 puts "error getting diffs: $err"
2570 fconfigure $bdf -blocking 0
2571 set blobdifffd($ids) $bdf
2572 set curdifftag Comments
2574 catch {unset difffilestart}
2575 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2576 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2579 proc getblobdiffline {bdf ids} {
2580 global diffids blobdifffd ctext curdifftag curtagstart
2581 global diffnexthead diffnextnote difffilestart
2582 global nextupdate diffinhdr treediffs
2585 set n [gets $bdf line]
2589 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2590 $ctext tag add $curdifftag $curtagstart end
2595 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2598 $ctext conf -state normal
2599 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2600 # start of a new file
2601 $ctext insert end "\n"
2602 $ctext tag add $curdifftag $curtagstart end
2603 set curtagstart [$ctext index "end - 1c"]
2605 set here [$ctext index "end - 1c"]
2606 set i [lsearch -exact $treediffs($diffids) $fname]
2608 set difffilestart($i) $here
2610 $ctext mark set fmark.$i $here
2611 $ctext mark gravity fmark.$i left
2613 if {$newname != $fname} {
2614 set i [lsearch -exact $treediffs($diffids) $newname]
2616 set difffilestart($i) $here
2618 $ctext mark set fmark.$i $here
2619 $ctext mark gravity fmark.$i left
2622 set curdifftag "f:$fname"
2623 $ctext tag delete $curdifftag
2624 set l [expr {(78 - [string length $header]) / 2}]
2625 set pad [string range "----------------------------------------" 1 $l]
2626 $ctext insert end "$pad $header $pad\n" filesep
2628 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2630 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2631 $line match f1l f1c f2l f2c rest]} {
2633 $ctext insert end "\t" hunksep
2634 $ctext insert end " $f1l " d0 " $f2l " d1
2635 $ctext insert end " $rest \n" hunksep
2637 $ctext insert end "$line\n" hunksep
2641 set x [string range $line 0 0]
2642 if {$x == "-" || $x == "+"} {
2643 set tag [expr {$x == "+"}]
2645 set line [string range $line 1 end]
2647 $ctext insert end "$line\n" d$tag
2648 } elseif {$x == " "} {
2650 set line [string range $line 1 end]
2652 $ctext insert end "$line\n"
2653 } elseif {$diffinhdr || $x == "\\"} {
2654 # e.g. "\ No newline at end of file"
2655 $ctext insert end "$line\n" filesep
2657 # Something else we don't recognize
2658 if {$curdifftag != "Comments"} {
2659 $ctext insert end "\n"
2660 $ctext tag add $curdifftag $curtagstart end
2661 set curtagstart [$ctext index "end - 1c"]
2662 set curdifftag Comments
2664 $ctext insert end "$line\n" filesep
2667 $ctext conf -state disabled
2668 if {[clock clicks -milliseconds] >= $nextupdate} {
2670 fileevent $bdf readable {}
2672 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2677 global difffilestart ctext
2678 set here [$ctext index @0,0]
2679 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2680 if {[$ctext compare $difffilestart($i) > $here]} {
2681 if {![info exists pos]
2682 || [$ctext compare $difffilestart($i) < $pos]} {
2683 set pos $difffilestart($i)
2687 if {[info exists pos]} {
2692 proc listboxsel {} {
2693 global ctext cflist currentid
2694 if {![info exists currentid]} return
2695 set sel [lsort [$cflist curselection]]
2696 if {$sel eq {}} return
2697 set first [lindex $sel 0]
2698 catch {$ctext yview fmark.$first}
2702 global linespc charspc canvx0 canvy0 mainfont
2705 set linespc [font metrics $mainfont -linespace]
2706 set charspc [font measure $mainfont "m"]
2707 set canvy0 [expr 3 + 0.5 * $linespc]
2708 set canvx0 [expr 3 + 0.5 * $linespc]
2709 set xspc1(0) $linespc
2714 global stopped redisplaying phase
2715 if {$stopped > 1} return
2716 if {$phase == "getcommits"} return
2718 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2725 proc incrfont {inc} {
2726 global mainfont namefont textfont ctext canv phase
2727 global stopped entries
2729 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2730 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2731 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2733 $ctext conf -font $textfont
2734 $ctext tag conf filesep -font [concat $textfont bold]
2735 foreach e $entries {
2736 $e conf -font $mainfont
2738 if {$phase == "getcommits"} {
2739 $canv itemconf textitems -font $mainfont
2745 global sha1entry sha1string
2746 if {[string length $sha1string] == 40} {
2747 $sha1entry delete 0 end
2751 proc sha1change {n1 n2 op} {
2752 global sha1string currentid sha1but
2753 if {$sha1string == {}
2754 || ([info exists currentid] && $sha1string == $currentid)} {
2759 if {[$sha1but cget -state] == $state} return
2760 if {$state == "normal"} {
2761 $sha1but conf -state normal -relief raised -text "Goto: "
2763 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2767 proc gotocommit {} {
2768 global sha1string currentid idline tagids
2769 global lineid numcommits
2771 if {$sha1string == {}
2772 || ([info exists currentid] && $sha1string == $currentid)} return
2773 if {[info exists tagids($sha1string)]} {
2774 set id $tagids($sha1string)
2776 set id [string tolower $sha1string]
2777 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2779 for {set l 0} {$l < $numcommits} {incr l} {
2780 if {[string match $id* $lineid($l)]} {
2781 lappend matches $lineid($l)
2784 if {$matches ne {}} {
2785 if {[llength $matches] > 1} {
2786 error_popup "Short SHA1 id $id is ambiguous"
2789 set id [lindex $matches 0]
2793 if {[info exists idline($id)]} {
2794 selectline $idline($id) 1
2797 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2802 error_popup "$type $sha1string is not known"
2805 proc lineenter {x y id} {
2806 global hoverx hovery hoverid hovertimer
2807 global commitinfo canv
2809 if {![info exists commitinfo($id)]} return
2813 if {[info exists hovertimer]} {
2814 after cancel $hovertimer
2816 set hovertimer [after 500 linehover]
2820 proc linemotion {x y id} {
2821 global hoverx hovery hoverid hovertimer
2823 if {[info exists hoverid] && $id == $hoverid} {
2826 if {[info exists hovertimer]} {
2827 after cancel $hovertimer
2829 set hovertimer [after 500 linehover]
2833 proc lineleave {id} {
2834 global hoverid hovertimer canv
2836 if {[info exists hoverid] && $id == $hoverid} {
2838 if {[info exists hovertimer]} {
2839 after cancel $hovertimer
2847 global hoverx hovery hoverid hovertimer
2848 global canv linespc lthickness
2849 global commitinfo mainfont
2851 set text [lindex $commitinfo($hoverid) 0]
2852 set ymax [lindex [$canv cget -scrollregion] 3]
2853 if {$ymax == {}} return
2854 set yfrac [lindex [$canv yview] 0]
2855 set x [expr {$hoverx + 2 * $linespc}]
2856 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2857 set x0 [expr {$x - 2 * $lthickness}]
2858 set y0 [expr {$y - 2 * $lthickness}]
2859 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2860 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2861 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2862 -fill \#ffff80 -outline black -width 1 -tags hover]
2864 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2868 proc lineclick {x y id isnew} {
2869 global ctext commitinfo children cflist canv
2874 addtohistory [list lineclick $x $x $id 0]
2877 # fill the details pane with info about this line
2878 $ctext conf -state normal
2879 $ctext delete 0.0 end
2880 $ctext tag conf link -foreground blue -underline 1
2881 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2882 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2883 $ctext insert end "Parent:\t"
2884 $ctext insert end $id [list link link0]
2885 $ctext tag bind link0 <1> [list selbyid $id]
2886 set info $commitinfo($id)
2887 $ctext insert end "\n\t[lindex $info 0]\n"
2888 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2889 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2890 if {[info exists children($id)]} {
2891 $ctext insert end "\nChildren:"
2893 foreach child $children($id) {
2895 set info $commitinfo($child)
2896 $ctext insert end "\n\t"
2897 $ctext insert end $child [list link link$i]
2898 $ctext tag bind link$i <1> [list selbyid $child]
2899 $ctext insert end "\n\t[lindex $info 0]"
2900 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
2901 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
2904 $ctext conf -state disabled
2906 $cflist delete 0 end
2911 if {[info exists idline($id)]} {
2912 selectline $idline($id) 1
2918 if {![info exists startmstime]} {
2919 set startmstime [clock clicks -milliseconds]
2921 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2924 proc rowmenu {x y id} {
2925 global rowctxmenu idline selectedline rowmenuid
2927 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2932 $rowctxmenu entryconfigure 0 -state $state
2933 $rowctxmenu entryconfigure 1 -state $state
2934 $rowctxmenu entryconfigure 2 -state $state
2936 tk_popup $rowctxmenu $x $y
2939 proc diffvssel {dirn} {
2940 global rowmenuid selectedline lineid
2942 if {![info exists selectedline]} return
2944 set oldid $lineid($selectedline)
2945 set newid $rowmenuid
2947 set oldid $rowmenuid
2948 set newid $lineid($selectedline)
2950 addtohistory [list doseldiff $oldid $newid]
2951 doseldiff $oldid $newid
2954 proc doseldiff {oldid newid} {
2958 $ctext conf -state normal
2959 $ctext delete 0.0 end
2960 $ctext mark set fmark.0 0.0
2961 $ctext mark gravity fmark.0 left
2962 $cflist delete 0 end
2963 $cflist insert end "Top"
2964 $ctext insert end "From "
2965 $ctext tag conf link -foreground blue -underline 1
2966 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2967 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2968 $ctext tag bind link0 <1> [list selbyid $oldid]
2969 $ctext insert end $oldid [list link link0]
2970 $ctext insert end "\n "
2971 $ctext insert end [lindex $commitinfo($oldid) 0]
2972 $ctext insert end "\n\nTo "
2973 $ctext tag bind link1 <1> [list selbyid $newid]
2974 $ctext insert end $newid [list link link1]
2975 $ctext insert end "\n "
2976 $ctext insert end [lindex $commitinfo($newid) 0]
2977 $ctext insert end "\n"
2978 $ctext conf -state disabled
2979 $ctext tag delete Comments
2980 $ctext tag remove found 1.0 end
2981 startdiff [list $newid $oldid]
2985 global rowmenuid currentid commitinfo patchtop patchnum
2987 if {![info exists currentid]} return
2988 set oldid $currentid
2989 set oldhead [lindex $commitinfo($oldid) 0]
2990 set newid $rowmenuid
2991 set newhead [lindex $commitinfo($newid) 0]
2994 catch {destroy $top}
2996 label $top.title -text "Generate patch"
2997 grid $top.title - -pady 10
2998 label $top.from -text "From:"
2999 entry $top.fromsha1 -width 40 -relief flat
3000 $top.fromsha1 insert 0 $oldid
3001 $top.fromsha1 conf -state readonly
3002 grid $top.from $top.fromsha1 -sticky w
3003 entry $top.fromhead -width 60 -relief flat
3004 $top.fromhead insert 0 $oldhead
3005 $top.fromhead conf -state readonly
3006 grid x $top.fromhead -sticky w
3007 label $top.to -text "To:"
3008 entry $top.tosha1 -width 40 -relief flat
3009 $top.tosha1 insert 0 $newid
3010 $top.tosha1 conf -state readonly
3011 grid $top.to $top.tosha1 -sticky w
3012 entry $top.tohead -width 60 -relief flat
3013 $top.tohead insert 0 $newhead
3014 $top.tohead conf -state readonly
3015 grid x $top.tohead -sticky w
3016 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3017 grid $top.rev x -pady 10
3018 label $top.flab -text "Output file:"
3019 entry $top.fname -width 60
3020 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3022 grid $top.flab $top.fname -sticky w
3024 button $top.buts.gen -text "Generate" -command mkpatchgo
3025 button $top.buts.can -text "Cancel" -command mkpatchcan
3026 grid $top.buts.gen $top.buts.can
3027 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3028 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3029 grid $top.buts - -pady 10 -sticky ew
3033 proc mkpatchrev {} {
3036 set oldid [$patchtop.fromsha1 get]
3037 set oldhead [$patchtop.fromhead get]
3038 set newid [$patchtop.tosha1 get]
3039 set newhead [$patchtop.tohead get]
3040 foreach e [list fromsha1 fromhead tosha1 tohead] \
3041 v [list $newid $newhead $oldid $oldhead] {
3042 $patchtop.$e conf -state normal
3043 $patchtop.$e delete 0 end
3044 $patchtop.$e insert 0 $v
3045 $patchtop.$e conf -state readonly
3052 set oldid [$patchtop.fromsha1 get]
3053 set newid [$patchtop.tosha1 get]
3054 set fname [$patchtop.fname get]
3055 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3056 error_popup "Error creating patch: $err"
3058 catch {destroy $patchtop}
3062 proc mkpatchcan {} {
3065 catch {destroy $patchtop}
3070 global rowmenuid mktagtop commitinfo
3074 catch {destroy $top}
3076 label $top.title -text "Create tag"
3077 grid $top.title - -pady 10
3078 label $top.id -text "ID:"
3079 entry $top.sha1 -width 40 -relief flat
3080 $top.sha1 insert 0 $rowmenuid
3081 $top.sha1 conf -state readonly
3082 grid $top.id $top.sha1 -sticky w
3083 entry $top.head -width 60 -relief flat
3084 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3085 $top.head conf -state readonly
3086 grid x $top.head -sticky w
3087 label $top.tlab -text "Tag name:"
3088 entry $top.tag -width 60
3089 grid $top.tlab $top.tag -sticky w
3091 button $top.buts.gen -text "Create" -command mktaggo
3092 button $top.buts.can -text "Cancel" -command mktagcan
3093 grid $top.buts.gen $top.buts.can
3094 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3095 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3096 grid $top.buts - -pady 10 -sticky ew
3101 global mktagtop env tagids idtags
3102 global idpos idline linehtag canv selectedline
3104 set id [$mktagtop.sha1 get]
3105 set tag [$mktagtop.tag get]
3107 error_popup "No tag name specified"
3110 if {[info exists tagids($tag)]} {
3111 error_popup "Tag \"$tag\" already exists"
3116 set fname [file join $dir "refs/tags" $tag]
3117 set f [open $fname w]
3121 error_popup "Error creating tag: $err"
3125 set tagids($tag) $id
3126 lappend idtags($id) $tag
3127 $canv delete tag.$id
3128 set xt [eval drawtags $id $idpos($id)]
3129 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3130 if {[info exists selectedline] && $selectedline == $idline($id)} {
3131 selectline $selectedline 0
3138 catch {destroy $mktagtop}
3147 proc writecommit {} {
3148 global rowmenuid wrcomtop commitinfo wrcomcmd
3150 set top .writecommit
3152 catch {destroy $top}
3154 label $top.title -text "Write commit to file"
3155 grid $top.title - -pady 10
3156 label $top.id -text "ID:"
3157 entry $top.sha1 -width 40 -relief flat
3158 $top.sha1 insert 0 $rowmenuid
3159 $top.sha1 conf -state readonly
3160 grid $top.id $top.sha1 -sticky w
3161 entry $top.head -width 60 -relief flat
3162 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3163 $top.head conf -state readonly
3164 grid x $top.head -sticky w
3165 label $top.clab -text "Command:"
3166 entry $top.cmd -width 60 -textvariable wrcomcmd
3167 grid $top.clab $top.cmd -sticky w -pady 10
3168 label $top.flab -text "Output file:"
3169 entry $top.fname -width 60
3170 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3171 grid $top.flab $top.fname -sticky w
3173 button $top.buts.gen -text "Write" -command wrcomgo
3174 button $top.buts.can -text "Cancel" -command wrcomcan
3175 grid $top.buts.gen $top.buts.can
3176 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3177 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3178 grid $top.buts - -pady 10 -sticky ew
3185 set id [$wrcomtop.sha1 get]
3186 set cmd "echo $id | [$wrcomtop.cmd get]"
3187 set fname [$wrcomtop.fname get]
3188 if {[catch {exec sh -c $cmd >$fname &} err]} {
3189 error_popup "Error writing commit: $err"
3191 catch {destroy $wrcomtop}
3198 catch {destroy $wrcomtop}
3211 set diffopts "-U 5 -p"
3212 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3214 set mainfont {Helvetica 9}
3215 set textfont {Courier 9}
3216 set findmergefiles 0
3220 set colors {green red blue magenta darkgrey brown orange}
3222 catch {source ~/.gitk}
3224 set namefont $mainfont
3226 lappend namefont bold
3231 switch -regexp -- $arg {
3233 "^-b" { set boldnames 1 }
3234 "^-d" { set datemode 1 }
3236 lappend revtreeargs $arg
3252 getcommits $revtreeargs