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
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]
35 set parse_args [concat --default HEAD $rargs]
36 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
38 # if git-rev-parse failed for some reason...
42 set parsed_args $rargs
45 set commfd [open "|git-rev-list --header --topo-order $parsed_args" r]
47 puts stderr "Error executing git-rev-list: $err"
51 fconfigure $commfd -blocking 0 -translation lf
52 fileevent $commfd readable "getcommitlines $commfd"
54 $canv create text 3 3 -anchor nw -text "Reading commits..." \
55 -font $mainfont -tags textitems
56 . config -cursor watch
60 proc getcommitlines {commfd} {
61 global commits parents cdate children nchildren
62 global commitlisted phase commitinfo nextupdate
63 global stopped redisplaying leftover
65 set stuff [read $commfd]
67 if {![eof $commfd]} return
68 # set it blocking so we wait for the process to terminate
69 fconfigure $commfd -blocking 1
70 if {![catch {close $commfd} err]} {
71 after idle finishcommits
74 if {[string range $err 0 4] == "usage"} {
76 {Gitk: error reading commits: bad arguments to git-rev-list.
77 (Note: arguments to gitk are passed to git-rev-list
78 to allow selection of commits to be displayed.)}
80 set err "Error reading commits: $err"
87 set i [string first "\0" $stuff $start]
89 append leftover [string range $stuff $start end]
92 set cmit [string range $stuff $start [expr {$i - 1}]]
94 set cmit "$leftover$cmit"
97 set start [expr {$i + 1}]
98 if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
100 if {[string length $shortcmit] > 80} {
101 set shortcmit "[string range $shortcmit 0 80]..."
103 error_popup "Can't parse git-rev-list output: {$shortcmit}"
106 set cmit [string range $cmit 41 end]
108 set commitlisted($id) 1
109 parsecommit $id $cmit 1
111 if {[clock clicks -milliseconds] >= $nextupdate} {
114 while {$redisplaying} {
118 set phase "getcommits"
119 foreach id $commits {
122 if {[clock clicks -milliseconds] >= $nextupdate} {
132 global commfd nextupdate
135 fileevent $commfd readable {}
137 fileevent $commfd readable "getcommitlines $commfd"
140 proc readcommit {id} {
141 if [catch {set contents [exec git-cat-file commit $id]}] return
142 parsecommit $id $contents 0
145 proc parsecommit {id contents listed} {
146 global commitinfo children nchildren parents nparents cdate ncleft
155 if {![info exists nchildren($id)]} {
162 foreach line [split $contents "\n"] {
167 set tag [lindex $line 0]
168 if {$tag == "parent"} {
169 set p [lindex $line 1]
170 if {![info exists nchildren($p)]} {
175 lappend parents($id) $p
177 # sometimes we get a commit that lists a parent twice...
178 if {$listed && [lsearch -exact $children($p) $id] < 0} {
179 lappend children($p) $id
183 } elseif {$tag == "author"} {
184 set x [expr {[llength $line] - 2}]
185 set audate [lindex $line $x]
186 set auname [lrange $line 1 [expr {$x - 1}]]
187 } elseif {$tag == "committer"} {
188 set x [expr {[llength $line] - 2}]
189 set comdate [lindex $line $x]
190 set comname [lrange $line 1 [expr {$x - 1}]]
194 if {$comment == {}} {
195 set headline [string trim $line]
200 # git-rev-list indents the comment by 4 spaces;
201 # if we got this via git-cat-file, add the indentation
208 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
210 if {$comdate != {}} {
211 set cdate($id) $comdate
212 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
214 set commitinfo($id) [list $headline $auname $audate \
215 $comname $comdate $comment]
219 global tagids idtags headids idheads
220 set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
225 if {[regexp {^[0-9a-f]{40}} $line id]} {
226 set direct [file tail $f]
227 set tagids($direct) $id
228 lappend idtags($id) $direct
229 set contents [split [exec git-cat-file tag $id] "\n"]
233 foreach l $contents {
235 switch -- [lindex $l 0] {
236 "object" {set obj [lindex $l 1]}
237 "type" {set type [lindex $l 1]}
238 "tag" {set tag [string range $l 4 end]}
241 if {$obj != {} && $type == "commit" && $tag != {}} {
242 set tagids($tag) $obj
243 lappend idtags($obj) $tag
249 set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
253 set line [read $fd 40]
254 if {[regexp {^[0-9a-f]{40}} $line id]} {
255 set head [file tail $f]
256 set headids($head) $line
257 lappend idheads($line) $head
264 proc error_popup msg {
268 message $w.m -text $msg -justify center -aspect 400
269 pack $w.m -side top -fill x -padx 20 -pady 20
270 button $w.ok -text OK -command "destroy $w"
271 pack $w.ok -side bottom -fill x
272 bind $w <Visibility> "grab $w; focus $w"
277 global canv canv2 canv3 linespc charspc ctext cflist textfont
278 global findtype findtypemenu findloc findstring fstring geometry
279 global entries sha1entry sha1string sha1but
280 global maincursor textcursor curtextcursor
281 global rowctxmenu gaudydiff mergemax
284 .bar add cascade -label "File" -menu .bar.file
286 .bar.file add command -label "Quit" -command doquit
288 .bar add cascade -label "Help" -menu .bar.help
289 .bar.help add command -label "About gitk" -command about
290 . configure -menu .bar
292 if {![info exists geometry(canv1)]} {
293 set geometry(canv1) [expr 45 * $charspc]
294 set geometry(canv2) [expr 30 * $charspc]
295 set geometry(canv3) [expr 15 * $charspc]
296 set geometry(canvh) [expr 25 * $linespc + 4]
297 set geometry(ctextw) 80
298 set geometry(ctexth) 30
299 set geometry(cflistw) 30
301 panedwindow .ctop -orient vertical
302 if {[info exists geometry(width)]} {
303 .ctop conf -width $geometry(width) -height $geometry(height)
304 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
305 set geometry(ctexth) [expr {($texth - 8) /
306 [font metrics $textfont -linespace]}]
310 pack .ctop.top.bar -side bottom -fill x
311 set cscroll .ctop.top.csb
312 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
313 pack $cscroll -side right -fill y
314 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
315 pack .ctop.top.clist -side top -fill both -expand 1
317 set canv .ctop.top.clist.canv
318 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
320 -yscrollincr $linespc -yscrollcommand "$cscroll set"
321 .ctop.top.clist add $canv
322 set canv2 .ctop.top.clist.canv2
323 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
324 -bg white -bd 0 -yscrollincr $linespc
325 .ctop.top.clist add $canv2
326 set canv3 .ctop.top.clist.canv3
327 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
328 -bg white -bd 0 -yscrollincr $linespc
329 .ctop.top.clist add $canv3
330 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
332 set sha1entry .ctop.top.bar.sha1
333 set entries $sha1entry
334 set sha1but .ctop.top.bar.sha1label
335 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
336 -command gotocommit -width 8
337 $sha1but conf -disabledforeground [$sha1but cget -foreground]
338 pack .ctop.top.bar.sha1label -side left
339 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
340 trace add variable sha1string write sha1change
341 pack $sha1entry -side left -pady 2
343 image create bitmap bm-left -data {
344 #define left_width 16
345 #define left_height 16
346 static unsigned char left_bits[] = {
347 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
348 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
349 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
351 image create bitmap bm-right -data {
352 #define right_width 16
353 #define right_height 16
354 static unsigned char right_bits[] = {
355 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
356 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
357 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
359 button .ctop.top.bar.leftbut -image bm-left -command goback \
360 -state disabled -width 26
361 pack .ctop.top.bar.leftbut -side left -fill y
362 button .ctop.top.bar.rightbut -image bm-right -command goforw \
363 -state disabled -width 26
364 pack .ctop.top.bar.rightbut -side left -fill y
366 button .ctop.top.bar.findbut -text "Find" -command dofind
367 pack .ctop.top.bar.findbut -side left
369 set fstring .ctop.top.bar.findstring
370 lappend entries $fstring
371 entry $fstring -width 30 -font $textfont -textvariable findstring
372 pack $fstring -side left -expand 1 -fill x
374 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
375 findtype Exact IgnCase Regexp]
376 set findloc "All fields"
377 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
378 Comments Author Committer Files Pickaxe
379 pack .ctop.top.bar.findloc -side right
380 pack .ctop.top.bar.findtype -side right
381 # for making sure type==Exact whenever loc==Pickaxe
382 trace add variable findloc write findlocchange
384 panedwindow .ctop.cdet -orient horizontal
386 frame .ctop.cdet.left
387 set ctext .ctop.cdet.left.ctext
388 text $ctext -bg white -state disabled -font $textfont \
389 -width $geometry(ctextw) -height $geometry(ctexth) \
390 -yscrollcommand ".ctop.cdet.left.sb set"
391 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
392 pack .ctop.cdet.left.sb -side right -fill y
393 pack $ctext -side left -fill both -expand 1
394 .ctop.cdet add .ctop.cdet.left
396 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
398 $ctext tag conf hunksep -back blue -fore white
399 $ctext tag conf d0 -back "#ff8080"
400 $ctext tag conf d1 -back green
402 $ctext tag conf hunksep -fore blue
403 $ctext tag conf d0 -fore red
404 $ctext tag conf d1 -fore "#00a000"
405 $ctext tag conf m0 -fore red
406 $ctext tag conf m1 -fore blue
407 $ctext tag conf m2 -fore green
408 $ctext tag conf m3 -fore purple
409 $ctext tag conf m4 -fore brown
410 $ctext tag conf mmax -fore darkgrey
412 $ctext tag conf mresult -font [concat $textfont bold]
413 $ctext tag conf msep -font [concat $textfont bold]
414 $ctext tag conf found -back yellow
417 frame .ctop.cdet.right
418 set cflist .ctop.cdet.right.cfiles
419 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
420 -yscrollcommand ".ctop.cdet.right.sb set"
421 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
422 pack .ctop.cdet.right.sb -side right -fill y
423 pack $cflist -side left -fill both -expand 1
424 .ctop.cdet add .ctop.cdet.right
425 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
427 pack .ctop -side top -fill both -expand 1
429 bindall <1> {selcanvline %W %x %y}
430 #bindall <B1-Motion> {selcanvline %W %x %y}
431 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
432 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
433 bindall <2> "allcanvs scan mark 0 %y"
434 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
435 bind . <Key-Up> "selnextline -1"
436 bind . <Key-Down> "selnextline 1"
437 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
438 bind . <Key-Next> "allcanvs yview scroll 1 pages"
439 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
440 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
441 bindkey <Key-space> "$ctext yview scroll 1 pages"
442 bindkey p "selnextline -1"
443 bindkey n "selnextline 1"
444 bindkey b "$ctext yview scroll -1 pages"
445 bindkey d "$ctext yview scroll 18 units"
446 bindkey u "$ctext yview scroll -18 units"
447 bindkey / {findnext 1}
448 bindkey <Key-Return> {findnext 0}
451 bind . <Control-q> doquit
452 bind . <Control-f> dofind
453 bind . <Control-g> {findnext 0}
454 bind . <Control-r> findprev
455 bind . <Control-equal> {incrfont 1}
456 bind . <Control-KP_Add> {incrfont 1}
457 bind . <Control-minus> {incrfont -1}
458 bind . <Control-KP_Subtract> {incrfont -1}
459 bind $cflist <<ListboxSelect>> listboxsel
460 bind . <Destroy> {savestuff %W}
461 bind . <Button-1> "click %W"
462 bind $fstring <Key-Return> dofind
463 bind $sha1entry <Key-Return> gotocommit
464 bind $sha1entry <<PasteSelection>> clearsha1
466 set maincursor [. cget -cursor]
467 set textcursor [$ctext cget -cursor]
468 set curtextcursor $textcursor
470 set rowctxmenu .rowctxmenu
471 menu $rowctxmenu -tearoff 0
472 $rowctxmenu add command -label "Diff this -> selected" \
473 -command {diffvssel 0}
474 $rowctxmenu add command -label "Diff selected -> this" \
475 -command {diffvssel 1}
476 $rowctxmenu add command -label "Make patch" -command mkpatch
477 $rowctxmenu add command -label "Create tag" -command mktag
478 $rowctxmenu add command -label "Write commit to file" -command writecommit
481 # when we make a key binding for the toplevel, make sure
482 # it doesn't get triggered when that key is pressed in the
483 # find string entry widget.
484 proc bindkey {ev script} {
487 set escript [bind Entry $ev]
488 if {$escript == {}} {
489 set escript [bind Entry <Key>]
492 bind $e $ev "$escript; break"
496 # set the focus back to the toplevel for any click outside
507 global canv canv2 canv3 ctext cflist mainfont textfont
508 global stuffsaved findmergefiles gaudydiff maxgraphpct
510 if {$stuffsaved} return
511 if {![winfo viewable .]} return
513 set f [open "~/.gitk-new" w]
514 puts $f [list set mainfont $mainfont]
515 puts $f [list set textfont $textfont]
516 puts $f [list set findmergefiles $findmergefiles]
517 puts $f [list set gaudydiff $gaudydiff]
518 puts $f [list set maxgraphpct $maxgraphpct]
519 puts $f "set geometry(width) [winfo width .ctop]"
520 puts $f "set geometry(height) [winfo height .ctop]"
521 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
522 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
523 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
524 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
525 set wid [expr {([winfo width $ctext] - 8) \
526 / [font measure $textfont "0"]}]
527 puts $f "set geometry(ctextw) $wid"
528 set wid [expr {([winfo width $cflist] - 11) \
529 / [font measure [$cflist cget -font] "0"]}]
530 puts $f "set geometry(cflistw) $wid"
532 file rename -force "~/.gitk-new" "~/.gitk"
537 proc resizeclistpanes {win w} {
539 if [info exists oldwidth($win)] {
540 set s0 [$win sash coord 0]
541 set s1 [$win sash coord 1]
543 set sash0 [expr {int($w/2 - 2)}]
544 set sash1 [expr {int($w*5/6 - 2)}]
546 set factor [expr {1.0 * $w / $oldwidth($win)}]
547 set sash0 [expr {int($factor * [lindex $s0 0])}]
548 set sash1 [expr {int($factor * [lindex $s1 0])}]
552 if {$sash1 < $sash0 + 20} {
553 set sash1 [expr $sash0 + 20]
555 if {$sash1 > $w - 10} {
556 set sash1 [expr $w - 10]
557 if {$sash0 > $sash1 - 20} {
558 set sash0 [expr $sash1 - 20]
562 $win sash place 0 $sash0 [lindex $s0 1]
563 $win sash place 1 $sash1 [lindex $s1 1]
565 set oldwidth($win) $w
568 proc resizecdetpanes {win w} {
570 if [info exists oldwidth($win)] {
571 set s0 [$win sash coord 0]
573 set sash0 [expr {int($w*3/4 - 2)}]
575 set factor [expr {1.0 * $w / $oldwidth($win)}]
576 set sash0 [expr {int($factor * [lindex $s0 0])}]
580 if {$sash0 > $w - 15} {
581 set sash0 [expr $w - 15]
584 $win sash place 0 $sash0 [lindex $s0 1]
586 set oldwidth($win) $w
590 global canv canv2 canv3
596 proc bindall {event action} {
597 global canv canv2 canv3
598 bind $canv $event $action
599 bind $canv2 $event $action
600 bind $canv3 $event $action
605 if {[winfo exists $w]} {
610 wm title $w "About gitk"
614 Copyright © 2005 Paul Mackerras
616 Use and redistribute under the terms of the GNU General Public License} \
617 -justify center -aspect 400
618 pack $w.m -side top -fill x -padx 20 -pady 20
619 button $w.ok -text Close -command "destroy $w"
620 pack $w.ok -side bottom
623 proc assigncolor {id} {
624 global commitinfo colormap commcolors colors nextcolor
625 global parents nparents children nchildren
626 global cornercrossings crossings
628 if [info exists colormap($id)] return
629 set ncolors [llength $colors]
630 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
631 set child [lindex $children($id) 0]
632 if {[info exists colormap($child)]
633 && $nparents($child) == 1} {
634 set colormap($id) $colormap($child)
639 if {[info exists cornercrossings($id)]} {
640 foreach x $cornercrossings($id) {
641 if {[info exists colormap($x)]
642 && [lsearch -exact $badcolors $colormap($x)] < 0} {
643 lappend badcolors $colormap($x)
646 if {[llength $badcolors] >= $ncolors} {
650 set origbad $badcolors
651 if {[llength $badcolors] < $ncolors - 1} {
652 if {[info exists crossings($id)]} {
653 foreach x $crossings($id) {
654 if {[info exists colormap($x)]
655 && [lsearch -exact $badcolors $colormap($x)] < 0} {
656 lappend badcolors $colormap($x)
659 if {[llength $badcolors] >= $ncolors} {
660 set badcolors $origbad
663 set origbad $badcolors
665 if {[llength $badcolors] < $ncolors - 1} {
666 foreach child $children($id) {
667 if {[info exists colormap($child)]
668 && [lsearch -exact $badcolors $colormap($child)] < 0} {
669 lappend badcolors $colormap($child)
671 if {[info exists parents($child)]} {
672 foreach p $parents($child) {
673 if {[info exists colormap($p)]
674 && [lsearch -exact $badcolors $colormap($p)] < 0} {
675 lappend badcolors $colormap($p)
680 if {[llength $badcolors] >= $ncolors} {
681 set badcolors $origbad
684 for {set i 0} {$i <= $ncolors} {incr i} {
685 set c [lindex $colors $nextcolor]
686 if {[incr nextcolor] >= $ncolors} {
689 if {[lsearch -exact $badcolors $c]} break
695 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
696 global mainline sidelines
697 global nchildren ncleft
704 set lthickness [expr {int($linespc / 9) + 1}]
705 catch {unset mainline}
706 catch {unset sidelines}
707 foreach id [array names nchildren] {
708 set ncleft($id) $nchildren($id)
712 proc bindline {t id} {
715 $canv bind $t <Enter> "lineenter %x %y $id"
716 $canv bind $t <Motion> "linemotion %x %y $id"
717 $canv bind $t <Leave> "lineleave $id"
718 $canv bind $t <Button-1> "lineclick %x %y $id"
721 proc drawcommitline {level} {
722 global parents children nparents nchildren todo
723 global canv canv2 canv3 mainfont namefont canvy linespc
724 global lineid linehtag linentag linedtag commitinfo
725 global colormap numcommits currentparents dupparents
726 global oldlevel oldnlines oldtodo
727 global idtags idline idheads
728 global lineno lthickness mainline sidelines
729 global commitlisted rowtextx idpos
733 set id [lindex $todo $level]
734 set lineid($lineno) $id
735 set idline($id) $lineno
736 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
737 if {![info exists commitinfo($id)]} {
739 if {![info exists commitinfo($id)]} {
740 set commitinfo($id) {"No commit information available"}
745 set currentparents {}
747 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
748 foreach p $parents($id) {
749 if {[lsearch -exact $currentparents $p] < 0} {
750 lappend currentparents $p
752 # remember that this parent was listed twice
753 lappend dupparents $p
757 set x [xcoord $level $level $lineno]
759 set canvy [expr $canvy + $linespc]
760 allcanvs conf -scrollregion \
761 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
762 if {[info exists mainline($id)]} {
763 lappend mainline($id) $x $y1
764 set t [$canv create line $mainline($id) \
765 -width $lthickness -fill $colormap($id)]
769 if {[info exists sidelines($id)]} {
770 foreach ls $sidelines($id) {
771 set coords [lindex $ls 0]
772 set thick [lindex $ls 1]
773 set t [$canv create line $coords -fill $colormap($id) \
774 -width [expr {$thick * $lthickness}]]
779 set orad [expr {$linespc / 3}]
780 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
781 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
782 -fill $ofill -outline black -width 1]
784 $canv bind $t <1> {selcanvline {} %x %y}
785 set xt [xcoord [llength $todo] $level $lineno]
786 if {[llength $currentparents] > 2} {
787 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
789 set rowtextx($lineno) $xt
790 set idpos($id) [list $x $xt $y1]
791 if {[info exists idtags($id)] || [info exists idheads($id)]} {
792 set xt [drawtags $id $x $xt $y1]
794 set headline [lindex $commitinfo($id) 0]
795 set name [lindex $commitinfo($id) 1]
796 set date [lindex $commitinfo($id) 2]
797 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
798 -text $headline -font $mainfont ]
799 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
800 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
801 -text $name -font $namefont]
802 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
803 -text $date -font $mainfont]
806 proc drawtags {id x xt y1} {
807 global idtags idheads
808 global linespc lthickness
813 if {[info exists idtags($id)]} {
814 set marks $idtags($id)
815 set ntags [llength $marks]
817 if {[info exists idheads($id)]} {
818 set marks [concat $marks $idheads($id)]
824 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
825 set yt [expr $y1 - 0.5 * $linespc]
826 set yb [expr $yt + $linespc - 1]
830 set wid [font measure $mainfont $tag]
833 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
835 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
836 -width $lthickness -fill black -tags tag.$id]
838 foreach tag $marks x $xvals wid $wvals {
839 set xl [expr $x + $delta]
840 set xr [expr $x + $delta + $wid + $lthickness]
841 if {[incr ntags -1] >= 0} {
843 $canv create polygon $x [expr $yt + $delta] $xl $yt\
844 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
845 -width 1 -outline black -fill yellow -tags tag.$id
848 set xl [expr $xl - $delta/2]
849 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
850 -width 1 -outline black -fill green -tags tag.$id
852 $canv create text $xl $y1 -anchor w -text $tag \
853 -font $mainfont -tags tag.$id
858 proc updatetodo {level noshortcut} {
859 global currentparents ncleft todo
860 global mainline oldlevel oldtodo oldnlines
861 global canvy linespc mainline
862 global commitinfo lineno xspc1
866 set oldnlines [llength $todo]
867 if {!$noshortcut && [llength $currentparents] == 1} {
868 set p [lindex $currentparents 0]
869 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
871 set x [xcoord $level $level $lineno]
872 set y [expr $canvy - $linespc]
873 set mainline($p) [list $x $y]
874 set todo [lreplace $todo $level $level $p]
875 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
880 set todo [lreplace $todo $level $level]
882 foreach p $currentparents {
884 set k [lsearch -exact $todo $p]
886 set todo [linsert $todo $i $p]
893 proc notecrossings {id lo hi corner} {
894 global oldtodo crossings cornercrossings
896 for {set i $lo} {[incr i] < $hi} {} {
897 set p [lindex $oldtodo $i]
898 if {$p == {}} continue
900 if {![info exists cornercrossings($id)]
901 || [lsearch -exact $cornercrossings($id) $p] < 0} {
902 lappend cornercrossings($id) $p
904 if {![info exists cornercrossings($p)]
905 || [lsearch -exact $cornercrossings($p) $id] < 0} {
906 lappend cornercrossings($p) $id
909 if {![info exists crossings($id)]
910 || [lsearch -exact $crossings($id) $p] < 0} {
911 lappend crossings($id) $p
913 if {![info exists crossings($p)]
914 || [lsearch -exact $crossings($p) $id] < 0} {
915 lappend crossings($p) $id
921 proc xcoord {i level ln} {
922 global canvx0 xspc1 xspc2
924 set x [expr {$canvx0 + $i * $xspc1($ln)}]
925 if {$i > 0 && $i == $level} {
926 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
927 } elseif {$i > $level} {
928 set x [expr {$x + $xspc2 - $xspc1($ln)}]
933 proc drawslants {level} {
934 global canv mainline sidelines canvx0 canvy xspc1 xspc2 lthickness
935 global oldlevel oldtodo todo currentparents dupparents
936 global lthickness linespc canvy colormap lineno geometry
939 # decide on the line spacing for the next line
940 set lj [expr {$lineno + 1}]
941 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
942 set n [llength $todo]
943 if {$n <= 1 || $canvx0 + $n * $xspc2 <= $maxw} {
944 set xspc1($lj) $xspc2
946 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($n - 1)}]
947 if {$xspc1($lj) < $lthickness} {
948 set xspc1($lj) $lthickness
952 set y1 [expr $canvy - $linespc]
955 foreach id $oldtodo {
957 if {$id == {}} continue
958 set xi [xcoord $i $oldlevel $lineno]
959 if {$i == $oldlevel} {
960 foreach p $currentparents {
961 set j [lsearch -exact $todo $p]
962 set coords [list $xi $y1]
963 set xj [xcoord $j $level $lj]
964 if {$xj < $xi - $linespc} {
965 lappend coords [expr {$xj + $linespc}] $y1
966 notecrossings $p $j $i [expr {$j + 1}]
967 } elseif {$xj > $xi + $linespc} {
968 lappend coords [expr {$xj - $linespc}] $y1
969 notecrossings $p $i $j [expr {$j - 1}]
971 if {[lsearch -exact $dupparents $p] >= 0} {
972 # draw a double-width line to indicate the doubled parent
973 lappend coords $xj $y2
974 lappend sidelines($p) [list $coords 2]
975 if {![info exists mainline($p)]} {
976 set mainline($p) [list $xj $y2]
979 # normal case, no parent duplicated
981 set dx [expr {abs($xi - $xj)}]
982 if {0 && $dx < $linespc} {
983 set yb [expr {$y1 + $dx}]
985 if {![info exists mainline($p)]} {
987 lappend coords $xj $yb
989 set mainline($p) $coords
991 lappend coords $xj $yb
993 lappend coords $xj $y2
995 lappend sidelines($p) [list $coords 1]
1001 if {[lindex $todo $i] != $id} {
1002 set j [lsearch -exact $todo $id]
1004 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1005 || ($oldlevel <= $i && $i <= $level)
1006 || ($level <= $i && $i <= $oldlevel)} {
1007 set xj [xcoord $j $level $lj]
1008 set dx [expr {abs($xi - $xj)}]
1010 if {0 && $dx < $linespc} {
1011 set yb [expr {$y1 + $dx}]
1013 lappend mainline($id) $xi $y1 $xj $yb
1019 proc decidenext {{noread 0}} {
1020 global parents children nchildren ncleft todo
1021 global canv canv2 canv3 mainfont namefont canvy linespc
1022 global datemode cdate
1024 global currentparents oldlevel oldnlines oldtodo
1025 global lineno lthickness
1027 # remove the null entry if present
1028 set nullentry [lsearch -exact $todo {}]
1029 if {$nullentry >= 0} {
1030 set todo [lreplace $todo $nullentry $nullentry]
1033 # choose which one to do next time around
1034 set todol [llength $todo]
1037 for {set k $todol} {[incr k -1] >= 0} {} {
1038 set p [lindex $todo $k]
1039 if {$ncleft($p) == 0} {
1041 if {![info exists commitinfo($p)]} {
1047 if {$latest == {} || $cdate($p) > $latest} {
1049 set latest $cdate($p)
1059 puts "ERROR: none of the pending commits can be done yet:"
1061 puts " $p ($ncleft($p))"
1067 # If we are reducing, put in a null entry
1068 if {$todol < $oldnlines} {
1069 if {$nullentry >= 0} {
1072 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1082 set todo [linsert $todo $i {}]
1091 proc drawcommit {id} {
1092 global phase todo nchildren datemode nextupdate
1095 if {$phase != "incrdraw"} {
1098 set startcommits $id
1101 updatetodo 0 $datemode
1103 if {$nchildren($id) == 0} {
1105 lappend startcommits $id
1107 set level [decidenext 1]
1108 if {$level == {} || $id != [lindex $todo $level]} {
1113 drawcommitline $level
1114 if {[updatetodo $level $datemode]} {
1115 set level [decidenext 1]
1116 if {$level == {}} break
1118 set id [lindex $todo $level]
1119 if {![info exists commitlisted($id)]} {
1122 if {[clock clicks -milliseconds] >= $nextupdate} {
1130 proc finishcommits {} {
1133 global canv mainfont ctext maincursor textcursor
1135 if {$phase != "incrdraw"} {
1137 $canv create text 3 3 -anchor nw -text "No commits selected" \
1138 -font $mainfont -tags textitems
1141 set level [decidenext]
1143 drawrest $level [llength $startcommits]
1145 . config -cursor $maincursor
1146 settextcursor $textcursor
1149 # Don't change the text pane cursor if it is currently the hand cursor,
1150 # showing that we are over a sha1 ID link.
1151 proc settextcursor {c} {
1152 global ctext curtextcursor
1154 if {[$ctext cget -cursor] == $curtextcursor} {
1155 $ctext config -cursor $c
1157 set curtextcursor $c
1161 global nextupdate startmsecs startcommits todo
1163 if {$startcommits == {}} return
1164 set startmsecs [clock clicks -milliseconds]
1165 set nextupdate [expr $startmsecs + 100]
1167 set todo [lindex $startcommits 0]
1171 proc drawrest {level startix} {
1172 global phase stopped redisplaying selectedline
1173 global datemode currentparents todo
1175 global nextupdate startmsecs startcommits idline
1179 set startid [lindex $startcommits $startix]
1181 if {$startid != {}} {
1182 set startline $idline($startid)
1186 drawcommitline $level
1187 set hard [updatetodo $level $datemode]
1188 if {$numcommits == $startline} {
1189 lappend todo $startid
1192 set startid [lindex $startcommits $startix]
1194 if {$startid != {}} {
1195 set startline $idline($startid)
1199 set level [decidenext]
1200 if {$level < 0} break
1203 if {[clock clicks -milliseconds] >= $nextupdate} {
1210 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1211 #puts "overall $drawmsecs ms for $numcommits commits"
1212 if {$redisplaying} {
1213 if {$stopped == 0 && [info exists selectedline]} {
1214 selectline $selectedline 0
1216 if {$stopped == 1} {
1218 after idle drawgraph
1225 proc findmatches {f} {
1226 global findtype foundstring foundstrlen
1227 if {$findtype == "Regexp"} {
1228 set matches [regexp -indices -all -inline $foundstring $f]
1230 if {$findtype == "IgnCase"} {
1231 set str [string tolower $f]
1237 while {[set j [string first $foundstring $str $i]] >= 0} {
1238 lappend matches [list $j [expr $j+$foundstrlen-1]]
1239 set i [expr $j + $foundstrlen]
1246 global findtype findloc findstring markedmatches commitinfo
1247 global numcommits lineid linehtag linentag linedtag
1248 global mainfont namefont canv canv2 canv3 selectedline
1249 global matchinglines foundstring foundstrlen
1254 set matchinglines {}
1255 if {$findloc == "Pickaxe"} {
1259 if {$findtype == "IgnCase"} {
1260 set foundstring [string tolower $findstring]
1262 set foundstring $findstring
1264 set foundstrlen [string length $findstring]
1265 if {$foundstrlen == 0} return
1266 if {$findloc == "Files"} {
1270 if {![info exists selectedline]} {
1273 set oldsel $selectedline
1276 set fldtypes {Headline Author Date Committer CDate Comment}
1277 for {set l 0} {$l < $numcommits} {incr l} {
1279 set info $commitinfo($id)
1281 foreach f $info ty $fldtypes {
1282 if {$findloc != "All fields" && $findloc != $ty} {
1285 set matches [findmatches $f]
1286 if {$matches == {}} continue
1288 if {$ty == "Headline"} {
1289 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1290 } elseif {$ty == "Author"} {
1291 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1292 } elseif {$ty == "Date"} {
1293 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1297 lappend matchinglines $l
1298 if {!$didsel && $l > $oldsel} {
1304 if {$matchinglines == {}} {
1306 } elseif {!$didsel} {
1307 findselectline [lindex $matchinglines 0]
1311 proc findselectline {l} {
1312 global findloc commentend ctext
1314 if {$findloc == "All fields" || $findloc == "Comments"} {
1315 # highlight the matches in the comments
1316 set f [$ctext get 1.0 $commentend]
1317 set matches [findmatches $f]
1318 foreach match $matches {
1319 set start [lindex $match 0]
1320 set end [expr [lindex $match 1] + 1]
1321 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1326 proc findnext {restart} {
1327 global matchinglines selectedline
1328 if {![info exists matchinglines]} {
1334 if {![info exists selectedline]} return
1335 foreach l $matchinglines {
1336 if {$l > $selectedline} {
1345 global matchinglines selectedline
1346 if {![info exists matchinglines]} {
1350 if {![info exists selectedline]} return
1352 foreach l $matchinglines {
1353 if {$l >= $selectedline} break
1357 findselectline $prev
1363 proc findlocchange {name ix op} {
1364 global findloc findtype findtypemenu
1365 if {$findloc == "Pickaxe"} {
1371 $findtypemenu entryconf 1 -state $state
1372 $findtypemenu entryconf 2 -state $state
1375 proc stopfindproc {{done 0}} {
1376 global findprocpid findprocfile findids
1377 global ctext findoldcursor phase maincursor textcursor
1378 global findinprogress
1380 catch {unset findids}
1381 if {[info exists findprocpid]} {
1383 catch {exec kill $findprocpid}
1385 catch {close $findprocfile}
1388 if {[info exists findinprogress]} {
1389 unset findinprogress
1390 if {$phase != "incrdraw"} {
1391 . config -cursor $maincursor
1392 settextcursor $textcursor
1397 proc findpatches {} {
1398 global findstring selectedline numcommits
1399 global findprocpid findprocfile
1400 global finddidsel ctext lineid findinprogress
1401 global findinsertpos
1403 if {$numcommits == 0} return
1405 # make a list of all the ids to search, starting at the one
1406 # after the selected line (if any)
1407 if {[info exists selectedline]} {
1413 for {set i 0} {$i < $numcommits} {incr i} {
1414 if {[incr l] >= $numcommits} {
1417 append inputids $lineid($l) "\n"
1421 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1424 error_popup "Error starting search process: $err"
1428 set findinsertpos end
1430 set findprocpid [pid $f]
1431 fconfigure $f -blocking 0
1432 fileevent $f readable readfindproc
1434 . config -cursor watch
1436 set findinprogress 1
1439 proc readfindproc {} {
1440 global findprocfile finddidsel
1441 global idline matchinglines findinsertpos
1443 set n [gets $findprocfile line]
1445 if {[eof $findprocfile]} {
1453 if {![regexp {^[0-9a-f]{40}} $line id]} {
1454 error_popup "Can't parse git-diff-tree output: $line"
1458 if {![info exists idline($id)]} {
1459 puts stderr "spurious id: $id"
1466 proc insertmatch {l id} {
1467 global matchinglines findinsertpos finddidsel
1469 if {$findinsertpos == "end"} {
1470 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1471 set matchinglines [linsert $matchinglines 0 $l]
1474 lappend matchinglines $l
1477 set matchinglines [linsert $matchinglines $findinsertpos $l]
1488 global selectedline numcommits lineid ctext
1489 global ffileline finddidsel parents nparents
1490 global findinprogress findstartline findinsertpos
1491 global treediffs fdiffids fdiffsneeded fdiffpos
1492 global findmergefiles
1494 if {$numcommits == 0} return
1496 if {[info exists selectedline]} {
1497 set l [expr {$selectedline + 1}]
1502 set findstartline $l
1507 if {$findmergefiles || $nparents($id) == 1} {
1508 foreach p $parents($id) {
1509 if {![info exists treediffs([list $id $p])]} {
1510 append diffsneeded "$id $p\n"
1511 lappend fdiffsneeded [list $id $p]
1515 if {[incr l] >= $numcommits} {
1518 if {$l == $findstartline} break
1521 # start off a git-diff-tree process if needed
1522 if {$diffsneeded ne {}} {
1524 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1526 error_popup "Error starting search process: $err"
1529 catch {unset fdiffids}
1531 fconfigure $df -blocking 0
1532 fileevent $df readable [list readfilediffs $df]
1536 set findinsertpos end
1538 set p [lindex $parents($id) 0]
1539 . config -cursor watch
1541 set findinprogress 1
1542 findcont [list $id $p]
1546 proc readfilediffs {df} {
1547 global findids fdiffids fdiffs
1549 set n [gets $df line]
1553 if {[catch {close $df} err]} {
1556 error_popup "Error in git-diff-tree: $err"
1557 } elseif {[info exists findids]} {
1561 error_popup "Couldn't find diffs for {$ids}"
1566 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1567 # start of a new string of diffs
1569 set fdiffids [list $id $p]
1571 } elseif {[string match ":*" $line]} {
1572 lappend fdiffs [lindex $line 5]
1576 proc donefilediff {} {
1577 global fdiffids fdiffs treediffs findids
1578 global fdiffsneeded fdiffpos
1580 if {[info exists fdiffids]} {
1581 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1582 && $fdiffpos < [llength $fdiffsneeded]} {
1583 # git-diff-tree doesn't output anything for a commit
1584 # which doesn't change anything
1585 set nullids [lindex $fdiffsneeded $fdiffpos]
1586 set treediffs($nullids) {}
1587 if {[info exists findids] && $nullids eq $findids} {
1595 if {![info exists treediffs($fdiffids)]} {
1596 set treediffs($fdiffids) $fdiffs
1598 if {[info exists findids] && $fdiffids eq $findids} {
1605 proc findcont {ids} {
1606 global findids treediffs parents nparents
1607 global ffileline findstartline finddidsel
1608 global lineid numcommits matchinglines findinprogress
1609 global findmergefiles
1611 set id [lindex $ids 0]
1612 set p [lindex $ids 1]
1613 set pi [lsearch -exact $parents($id) $p]
1616 if {$findmergefiles || $nparents($id) == 1} {
1617 if {![info exists treediffs($ids)]} {
1623 foreach f $treediffs($ids) {
1624 set x [findmatches $f]
1632 set pi $nparents($id)
1635 set pi $nparents($id)
1637 if {[incr pi] >= $nparents($id)} {
1639 if {[incr l] >= $numcommits} {
1642 if {$l == $findstartline} break
1645 set p [lindex $parents($id) $pi]
1646 set ids [list $id $p]
1654 # mark a commit as matching by putting a yellow background
1655 # behind the headline
1656 proc markheadline {l id} {
1657 global canv mainfont linehtag commitinfo
1659 set bbox [$canv bbox $linehtag($l)]
1660 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1664 # mark the bits of a headline, author or date that match a find string
1665 proc markmatches {canv l str tag matches font} {
1666 set bbox [$canv bbox $tag]
1667 set x0 [lindex $bbox 0]
1668 set y0 [lindex $bbox 1]
1669 set y1 [lindex $bbox 3]
1670 foreach match $matches {
1671 set start [lindex $match 0]
1672 set end [lindex $match 1]
1673 if {$start > $end} continue
1674 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1675 set xlen [font measure $font [string range $str 0 [expr $end]]]
1676 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1677 -outline {} -tags matches -fill yellow]
1682 proc unmarkmatches {} {
1683 global matchinglines findids
1684 allcanvs delete matches
1685 catch {unset matchinglines}
1686 catch {unset findids}
1689 proc selcanvline {w x y} {
1690 global canv canvy0 ctext linespc selectedline
1691 global lineid linehtag linentag linedtag rowtextx
1692 set ymax [lindex [$canv cget -scrollregion] 3]
1693 if {$ymax == {}} return
1694 set yfrac [lindex [$canv yview] 0]
1695 set y [expr {$y + $yfrac * $ymax}]
1696 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1701 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1707 proc selectline {l isnew} {
1708 global canv canv2 canv3 ctext commitinfo selectedline
1709 global lineid linehtag linentag linedtag
1710 global canvy0 linespc parents nparents
1711 global cflist currentid sha1entry
1712 global commentend idtags idline
1713 global history historyindex
1716 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1718 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1719 -tags secsel -fill [$canv cget -selectbackground]]
1721 $canv2 delete secsel
1722 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1723 -tags secsel -fill [$canv2 cget -selectbackground]]
1725 $canv3 delete secsel
1726 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1727 -tags secsel -fill [$canv3 cget -selectbackground]]
1729 set y [expr {$canvy0 + $l * $linespc}]
1730 set ymax [lindex [$canv cget -scrollregion] 3]
1731 set ytop [expr {$y - $linespc - 1}]
1732 set ybot [expr {$y + $linespc + 1}]
1733 set wnow [$canv yview]
1734 set wtop [expr [lindex $wnow 0] * $ymax]
1735 set wbot [expr [lindex $wnow 1] * $ymax]
1736 set wh [expr {$wbot - $wtop}]
1738 if {$ytop < $wtop} {
1739 if {$ybot < $wtop} {
1740 set newtop [expr {$y - $wh / 2.0}]
1743 if {$newtop > $wtop - $linespc} {
1744 set newtop [expr {$wtop - $linespc}]
1747 } elseif {$ybot > $wbot} {
1748 if {$ytop > $wbot} {
1749 set newtop [expr {$y - $wh / 2.0}]
1751 set newtop [expr {$ybot - $wh}]
1752 if {$newtop < $wtop + $linespc} {
1753 set newtop [expr {$wtop + $linespc}]
1757 if {$newtop != $wtop} {
1761 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1764 if {$isnew && (![info exists selectedline] || $selectedline != $l)} {
1765 if {$historyindex < [llength $history]} {
1766 set history [lreplace $history $historyindex end $l]
1771 if {$historyindex > 1} {
1772 .ctop.top.bar.leftbut conf -state normal
1774 .ctop.top.bar.leftbut conf -state disabled
1776 .ctop.top.bar.rightbut conf -state disabled
1783 $sha1entry delete 0 end
1784 $sha1entry insert 0 $id
1785 $sha1entry selection from 0
1786 $sha1entry selection to end
1788 $ctext conf -state normal
1789 $ctext delete 0.0 end
1790 $ctext mark set fmark.0 0.0
1791 $ctext mark gravity fmark.0 left
1792 set info $commitinfo($id)
1793 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1794 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1795 if {[info exists idtags($id)]} {
1796 $ctext insert end "Tags:"
1797 foreach tag $idtags($id) {
1798 $ctext insert end " $tag"
1800 $ctext insert end "\n"
1803 set commentstart [$ctext index "end - 1c"]
1805 foreach p $parents($id) {
1807 if {[info exists commitinfo($p)]} {
1808 set l [lindex $commitinfo($p) 0]
1809 if {[string length $l] > 32} {
1810 set l "[string range $l 0 28] ..."
1813 append comment "Parent: $p ($l)\n"
1816 append comment [lindex $info 5]
1817 $ctext insert end $comment
1818 $ctext insert end "\n"
1820 # make anything that looks like a SHA1 ID be a clickable link
1821 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
1826 set linkid [string range $comment $s $e]
1827 if {![info exists idline($linkid)]} continue
1829 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
1830 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
1831 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
1834 $ctext tag conf link -foreground blue -underline 1
1835 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
1836 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
1838 $ctext tag delete Comments
1839 $ctext tag remove found 1.0 end
1840 $ctext conf -state disabled
1841 set commentend [$ctext index "end - 1c"]
1843 $cflist delete 0 end
1844 $cflist insert end "Comments"
1845 if {$nparents($id) == 1} {
1846 startdiff [concat $id $parents($id)]
1847 } elseif {$nparents($id) > 1} {
1852 proc selnextline {dir} {
1854 if {![info exists selectedline]} return
1855 set l [expr $selectedline + $dir]
1861 global history historyindex
1863 if {$historyindex > 1} {
1864 incr historyindex -1
1865 selectline [lindex $history [expr {$historyindex - 1}]] 0
1866 .ctop.top.bar.rightbut conf -state normal
1868 if {$historyindex <= 1} {
1869 .ctop.top.bar.leftbut conf -state disabled
1874 global history historyindex
1876 if {$historyindex < [llength $history]} {
1877 set l [lindex $history $historyindex]
1880 .ctop.top.bar.leftbut conf -state normal
1882 if {$historyindex >= [llength $history]} {
1883 .ctop.top.bar.rightbut conf -state disabled
1887 proc mergediff {id} {
1888 global parents diffmergeid diffmergegca mergefilelist diffpindex
1892 set diffmergegca [findgca $parents($id)]
1893 if {[info exists mergefilelist($id)]} {
1894 if {$mergefilelist($id) ne {}} {
1902 proc findgca {ids} {
1909 set gca [exec git-merge-base $gca $id]
1918 proc contmergediff {ids} {
1919 global diffmergeid diffpindex parents nparents diffmergegca
1920 global treediffs mergefilelist diffids treepending
1922 # diff the child against each of the parents, and diff
1923 # each of the parents against the GCA.
1925 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
1926 set ids [list [lindex $ids 1] $diffmergegca]
1928 if {[incr diffpindex] >= $nparents($diffmergeid)} break
1929 set p [lindex $parents($diffmergeid) $diffpindex]
1930 set ids [list $diffmergeid $p]
1932 if {![info exists treediffs($ids)]} {
1934 if {![info exists treepending]} {
1941 # If a file in some parent is different from the child and also
1942 # different from the GCA, then it's interesting.
1943 # If we don't have a GCA, then a file is interesting if it is
1944 # different from the child in all the parents.
1945 if {$diffmergegca ne {}} {
1947 foreach p $parents($diffmergeid) {
1948 set gcadiffs $treediffs([list $p $diffmergegca])
1949 foreach f $treediffs([list $diffmergeid $p]) {
1950 if {[lsearch -exact $files $f] < 0
1951 && [lsearch -exact $gcadiffs $f] >= 0} {
1956 set files [lsort $files]
1958 set p [lindex $parents($diffmergeid) 0]
1959 set files $treediffs([list $diffmergeid $p])
1960 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
1961 set p [lindex $parents($diffmergeid) $i]
1962 set df $treediffs([list $diffmergeid $p])
1965 if {[lsearch -exact $df $f] >= 0} {
1973 set mergefilelist($diffmergeid) $files
1979 proc showmergediff {} {
1980 global cflist diffmergeid mergefilelist parents
1981 global diffopts diffinhunk currentfile currenthunk filelines
1982 global diffblocked groupfilelast mergefds groupfilenum grouphunks
1984 set files $mergefilelist($diffmergeid)
1986 $cflist insert end $f
1988 set env(GIT_DIFF_OPTS) $diffopts
1990 catch {unset currentfile}
1991 catch {unset currenthunk}
1992 catch {unset filelines}
1993 catch {unset groupfilenum}
1994 catch {unset grouphunks}
1995 set groupfilelast -1
1996 foreach p $parents($diffmergeid) {
1997 set cmd [list | git-diff-tree -p $p $diffmergeid]
1998 set cmd [concat $cmd $mergefilelist($diffmergeid)]
1999 if {[catch {set f [open $cmd r]} err]} {
2000 error_popup "Error getting diffs: $err"
2007 set ids [list $diffmergeid $p]
2008 set mergefds($ids) $f
2009 set diffinhunk($ids) 0
2010 set diffblocked($ids) 0
2011 fconfigure $f -blocking 0
2012 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2016 proc getmergediffline {f ids id} {
2017 global diffmergeid diffinhunk diffoldlines diffnewlines
2018 global currentfile currenthunk
2019 global diffoldstart diffnewstart diffoldlno diffnewlno
2020 global diffblocked mergefilelist
2021 global noldlines nnewlines difflcounts filelines
2023 set n [gets $f line]
2025 if {![eof $f]} return
2028 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2035 if {$diffinhunk($ids) != 0} {
2036 set fi $currentfile($ids)
2037 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2038 # continuing an existing hunk
2039 set line [string range $line 1 end]
2040 set p [lindex $ids 1]
2041 if {$match eq "-" || $match eq " "} {
2042 set filelines($p,$fi,$diffoldlno($ids)) $line
2043 incr diffoldlno($ids)
2045 if {$match eq "+" || $match eq " "} {
2046 set filelines($id,$fi,$diffnewlno($ids)) $line
2047 incr diffnewlno($ids)
2049 if {$match eq " "} {
2050 if {$diffinhunk($ids) == 2} {
2051 lappend difflcounts($ids) \
2052 [list $noldlines($ids) $nnewlines($ids)]
2053 set noldlines($ids) 0
2054 set diffinhunk($ids) 1
2056 incr noldlines($ids)
2057 } elseif {$match eq "-" || $match eq "+"} {
2058 if {$diffinhunk($ids) == 1} {
2059 lappend difflcounts($ids) [list $noldlines($ids)]
2060 set noldlines($ids) 0
2061 set nnewlines($ids) 0
2062 set diffinhunk($ids) 2
2064 if {$match eq "-"} {
2065 incr noldlines($ids)
2067 incr nnewlines($ids)
2070 # and if it's \ No newline at end of line, then what?
2074 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2075 lappend difflcounts($ids) [list $noldlines($ids)]
2076 } elseif {$diffinhunk($ids) == 2
2077 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2078 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2080 set currenthunk($ids) [list $currentfile($ids) \
2081 $diffoldstart($ids) $diffnewstart($ids) \
2082 $diffoldlno($ids) $diffnewlno($ids) \
2084 set diffinhunk($ids) 0
2085 # -1 = need to block, 0 = unblocked, 1 = is blocked
2086 set diffblocked($ids) -1
2088 if {$diffblocked($ids) == -1} {
2089 fileevent $f readable {}
2090 set diffblocked($ids) 1
2096 if {!$diffblocked($ids)} {
2098 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2099 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2102 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2103 # start of a new file
2104 set currentfile($ids) \
2105 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2106 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2107 $line match f1l f1c f2l f2c rest]} {
2108 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2109 # start of a new hunk
2110 if {$f1l == 0 && $f1c == 0} {
2113 if {$f2l == 0 && $f2c == 0} {
2116 set diffinhunk($ids) 1
2117 set diffoldstart($ids) $f1l
2118 set diffnewstart($ids) $f2l
2119 set diffoldlno($ids) $f1l
2120 set diffnewlno($ids) $f2l
2121 set difflcounts($ids) {}
2122 set noldlines($ids) 0
2123 set nnewlines($ids) 0
2128 proc processhunks {} {
2129 global diffmergeid parents nparents currenthunk
2130 global mergefilelist diffblocked mergefds
2131 global grouphunks grouplinestart grouplineend groupfilenum
2133 set nfiles [llength $mergefilelist($diffmergeid)]
2137 # look for the earliest hunk
2138 foreach p $parents($diffmergeid) {
2139 set ids [list $diffmergeid $p]
2140 if {![info exists currenthunk($ids)]} return
2141 set i [lindex $currenthunk($ids) 0]
2142 set l [lindex $currenthunk($ids) 2]
2143 if {$i < $fi || ($i == $fi && $l < $lno)} {
2150 if {$fi < $nfiles} {
2151 set ids [list $diffmergeid $pi]
2152 set hunk $currenthunk($ids)
2153 unset currenthunk($ids)
2154 if {$diffblocked($ids) > 0} {
2155 fileevent $mergefds($ids) readable \
2156 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2158 set diffblocked($ids) 0
2160 if {[info exists groupfilenum] && $groupfilenum == $fi
2161 && $lno <= $grouplineend} {
2162 # add this hunk to the pending group
2163 lappend grouphunks($pi) $hunk
2164 set endln [lindex $hunk 4]
2165 if {$endln > $grouplineend} {
2166 set grouplineend $endln
2172 # succeeding stuff doesn't belong in this group, so
2173 # process the group now
2174 if {[info exists groupfilenum]} {
2180 if {$fi >= $nfiles} break
2183 set groupfilenum $fi
2184 set grouphunks($pi) [list $hunk]
2185 set grouplinestart $lno
2186 set grouplineend [lindex $hunk 4]
2190 proc processgroup {} {
2191 global groupfilelast groupfilenum difffilestart
2192 global mergefilelist diffmergeid ctext filelines
2193 global parents diffmergeid diffoffset
2194 global grouphunks grouplinestart grouplineend nparents
2197 $ctext conf -state normal
2200 if {$groupfilelast != $f} {
2201 $ctext insert end "\n"
2202 set here [$ctext index "end - 1c"]
2203 set difffilestart($f) $here
2204 set mark fmark.[expr {$f + 1}]
2205 $ctext mark set $mark $here
2206 $ctext mark gravity $mark left
2207 set header [lindex $mergefilelist($id) $f]
2208 set l [expr {(78 - [string length $header]) / 2}]
2209 set pad [string range "----------------------------------------" 1 $l]
2210 $ctext insert end "$pad $header $pad\n" filesep
2211 set groupfilelast $f
2212 foreach p $parents($id) {
2213 set diffoffset($p) 0
2217 $ctext insert end "@@" msep
2218 set nlines [expr {$grouplineend - $grouplinestart}]
2221 foreach p $parents($id) {
2222 set startline [expr {$grouplinestart + $diffoffset($p)}]
2224 set nl $grouplinestart
2225 if {[info exists grouphunks($p)]} {
2226 foreach h $grouphunks($p) {
2229 for {} {$nl < $l} {incr nl} {
2230 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2234 foreach chunk [lindex $h 5] {
2235 if {[llength $chunk] == 2} {
2236 set olc [lindex $chunk 0]
2237 set nlc [lindex $chunk 1]
2238 set nnl [expr {$nl + $nlc}]
2239 lappend events [list $nl $nnl $pnum $olc $nlc]
2243 incr ol [lindex $chunk 0]
2244 incr nl [lindex $chunk 0]
2249 if {$nl < $grouplineend} {
2250 for {} {$nl < $grouplineend} {incr nl} {
2251 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2255 set nlines [expr {$ol - $startline}]
2256 $ctext insert end " -$startline,$nlines" msep
2260 set nlines [expr {$grouplineend - $grouplinestart}]
2261 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2263 set events [lsort -integer -index 0 $events]
2264 set nevents [llength $events]
2265 set nmerge $nparents($diffmergeid)
2266 set l $grouplinestart
2267 for {set i 0} {$i < $nevents} {set i $j} {
2268 set nl [lindex $events $i 0]
2270 $ctext insert end " $filelines($id,$f,$l)\n"
2273 set e [lindex $events $i]
2274 set enl [lindex $e 1]
2278 set pnum [lindex $e 2]
2279 set olc [lindex $e 3]
2280 set nlc [lindex $e 4]
2281 if {![info exists delta($pnum)]} {
2282 set delta($pnum) [expr {$olc - $nlc}]
2283 lappend active $pnum
2285 incr delta($pnum) [expr {$olc - $nlc}]
2287 if {[incr j] >= $nevents} break
2288 set e [lindex $events $j]
2289 if {[lindex $e 0] >= $enl} break
2290 if {[lindex $e 1] > $enl} {
2291 set enl [lindex $e 1]
2294 set nlc [expr {$enl - $l}]
2297 if {[llength $active] == $nmerge - 1} {
2298 # no diff for one of the parents, i.e. it's identical
2299 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2300 if {![info exists delta($pnum)]} {
2301 if {$pnum < $mergemax} {
2309 } elseif {[llength $active] == $nmerge} {
2310 # all parents are different, see if one is very similar
2312 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2313 set sim [similarity $pnum $l $nlc $f \
2314 [lrange $events $i [expr {$j-1}]]]
2315 if {$sim > $bestsim} {
2321 lappend ncol m$bestpn
2325 foreach p $parents($id) {
2327 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2328 set olc [expr {$nlc + $delta($pnum)}]
2329 set ol [expr {$l + $diffoffset($p)}]
2330 incr diffoffset($p) $delta($pnum)
2332 for {} {$olc > 0} {incr olc -1} {
2333 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2337 set endl [expr {$l + $nlc}]
2339 # show this pretty much as a normal diff
2340 set p [lindex $parents($id) $bestpn]
2341 set ol [expr {$l + $diffoffset($p)}]
2342 incr diffoffset($p) $delta($bestpn)
2343 unset delta($bestpn)
2344 for {set k $i} {$k < $j} {incr k} {
2345 set e [lindex $events $k]
2346 if {[lindex $e 2] != $bestpn} continue
2347 set nl [lindex $e 0]
2348 set ol [expr {$ol + $nl - $l}]
2349 for {} {$l < $nl} {incr l} {
2350 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2353 for {} {$c > 0} {incr c -1} {
2354 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2357 set nl [lindex $e 1]
2358 for {} {$l < $nl} {incr l} {
2359 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2363 for {} {$l < $endl} {incr l} {
2364 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2367 while {$l < $grouplineend} {
2368 $ctext insert end " $filelines($id,$f,$l)\n"
2371 $ctext conf -state disabled
2374 proc similarity {pnum l nlc f events} {
2375 global diffmergeid parents diffoffset filelines
2378 set p [lindex $parents($id) $pnum]
2379 set ol [expr {$l + $diffoffset($p)}]
2380 set endl [expr {$l + $nlc}]
2384 if {[lindex $e 2] != $pnum} continue
2385 set nl [lindex $e 0]
2386 set ol [expr {$ol + $nl - $l}]
2387 for {} {$l < $nl} {incr l} {
2388 incr same [string length $filelines($id,$f,$l)]
2391 set oc [lindex $e 3]
2392 for {} {$oc > 0} {incr oc -1} {
2393 incr diff [string length $filelines($p,$f,$ol)]
2397 set nl [lindex $e 1]
2398 for {} {$l < $nl} {incr l} {
2399 incr diff [string length $filelines($id,$f,$l)]
2403 for {} {$l < $endl} {incr l} {
2404 incr same [string length $filelines($id,$f,$l)]
2410 return [expr {200 * $same / (2 * $same + $diff)}]
2413 proc startdiff {ids} {
2414 global treediffs diffids treepending diffmergeid
2417 catch {unset diffmergeid}
2418 if {![info exists treediffs($ids)]} {
2419 if {![info exists treepending]} {
2427 proc addtocflist {ids} {
2428 global treediffs cflist
2429 foreach f $treediffs($ids) {
2430 $cflist insert end $f
2435 proc gettreediffs {ids} {
2436 global treediff parents treepending
2437 set treepending $ids
2439 set id [lindex $ids 0]
2440 set p [lindex $ids 1]
2441 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2442 fconfigure $gdtf -blocking 0
2443 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2446 proc gettreediffline {gdtf ids} {
2447 global treediff treediffs treepending diffids diffmergeid
2449 set n [gets $gdtf line]
2451 if {![eof $gdtf]} return
2453 set treediffs($ids) $treediff
2455 if {$ids != $diffids} {
2456 gettreediffs $diffids
2458 if {[info exists diffmergeid]} {
2466 set file [lindex $line 5]
2467 lappend treediff $file
2470 proc getblobdiffs {ids} {
2471 global diffopts blobdifffd diffids env curdifftag curtagstart
2472 global difffilestart nextupdate diffinhdr treediffs
2474 set id [lindex $ids 0]
2475 set p [lindex $ids 1]
2476 set env(GIT_DIFF_OPTS) $diffopts
2477 set cmd [list | git-diff-tree -r -p -C $p $id]
2478 if {[catch {set bdf [open $cmd r]} err]} {
2479 puts "error getting diffs: $err"
2483 fconfigure $bdf -blocking 0
2484 set blobdifffd($ids) $bdf
2485 set curdifftag Comments
2487 catch {unset difffilestart}
2488 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2489 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2492 proc getblobdiffline {bdf ids} {
2493 global diffids blobdifffd ctext curdifftag curtagstart
2494 global diffnexthead diffnextnote difffilestart
2495 global nextupdate diffinhdr treediffs
2498 set n [gets $bdf line]
2502 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2503 $ctext tag add $curdifftag $curtagstart end
2508 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2511 $ctext conf -state normal
2512 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2513 # start of a new file
2514 $ctext insert end "\n"
2515 $ctext tag add $curdifftag $curtagstart end
2516 set curtagstart [$ctext index "end - 1c"]
2518 set here [$ctext index "end - 1c"]
2519 set i [lsearch -exact $treediffs($diffids) $fname]
2521 set difffilestart($i) $here
2523 $ctext mark set fmark.$i $here
2524 $ctext mark gravity fmark.$i left
2526 if {$newname != $fname} {
2527 set i [lsearch -exact $treediffs($diffids) $newname]
2529 set difffilestart($i) $here
2531 $ctext mark set fmark.$i $here
2532 $ctext mark gravity fmark.$i left
2535 set curdifftag "f:$fname"
2536 $ctext tag delete $curdifftag
2537 set l [expr {(78 - [string length $header]) / 2}]
2538 set pad [string range "----------------------------------------" 1 $l]
2539 $ctext insert end "$pad $header $pad\n" filesep
2541 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2543 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2544 $line match f1l f1c f2l f2c rest]} {
2546 $ctext insert end "\t" hunksep
2547 $ctext insert end " $f1l " d0 " $f2l " d1
2548 $ctext insert end " $rest \n" hunksep
2550 $ctext insert end "$line\n" hunksep
2554 set x [string range $line 0 0]
2555 if {$x == "-" || $x == "+"} {
2556 set tag [expr {$x == "+"}]
2558 set line [string range $line 1 end]
2560 $ctext insert end "$line\n" d$tag
2561 } elseif {$x == " "} {
2563 set line [string range $line 1 end]
2565 $ctext insert end "$line\n"
2566 } elseif {$diffinhdr || $x == "\\"} {
2567 # e.g. "\ No newline at end of file"
2568 $ctext insert end "$line\n" filesep
2570 # Something else we don't recognize
2571 if {$curdifftag != "Comments"} {
2572 $ctext insert end "\n"
2573 $ctext tag add $curdifftag $curtagstart end
2574 set curtagstart [$ctext index "end - 1c"]
2575 set curdifftag Comments
2577 $ctext insert end "$line\n" filesep
2580 $ctext conf -state disabled
2581 if {[clock clicks -milliseconds] >= $nextupdate} {
2583 fileevent $bdf readable {}
2585 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2590 global difffilestart ctext
2591 set here [$ctext index @0,0]
2592 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2593 if {[$ctext compare $difffilestart($i) > $here]} {
2594 if {![info exists pos]
2595 || [$ctext compare $difffilestart($i) < $pos]} {
2596 set pos $difffilestart($i)
2600 if {[info exists pos]} {
2605 proc listboxsel {} {
2606 global ctext cflist currentid
2607 if {![info exists currentid]} return
2608 set sel [lsort [$cflist curselection]]
2609 if {$sel eq {}} return
2610 set first [lindex $sel 0]
2611 catch {$ctext yview fmark.$first}
2615 global linespc charspc canvx0 canvy0 mainfont
2618 set linespc [font metrics $mainfont -linespace]
2619 set charspc [font measure $mainfont "m"]
2620 set canvy0 [expr 3 + 0.5 * $linespc]
2621 set canvx0 [expr 3 + 0.5 * $linespc]
2622 set xspc1(0) $linespc
2627 global selectedline stopped redisplaying phase
2628 if {$stopped > 1} return
2629 if {$phase == "getcommits"} return
2631 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2638 proc incrfont {inc} {
2639 global mainfont namefont textfont selectedline ctext canv phase
2640 global stopped entries
2642 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2643 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2644 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2646 $ctext conf -font $textfont
2647 $ctext tag conf filesep -font [concat $textfont bold]
2648 foreach e $entries {
2649 $e conf -font $mainfont
2651 if {$phase == "getcommits"} {
2652 $canv itemconf textitems -font $mainfont
2658 global sha1entry sha1string
2659 if {[string length $sha1string] == 40} {
2660 $sha1entry delete 0 end
2664 proc sha1change {n1 n2 op} {
2665 global sha1string currentid sha1but
2666 if {$sha1string == {}
2667 || ([info exists currentid] && $sha1string == $currentid)} {
2672 if {[$sha1but cget -state] == $state} return
2673 if {$state == "normal"} {
2674 $sha1but conf -state normal -relief raised -text "Goto: "
2676 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2680 proc gotocommit {} {
2681 global sha1string currentid idline tagids
2682 global lineid numcommits
2684 if {$sha1string == {}
2685 || ([info exists currentid] && $sha1string == $currentid)} return
2686 if {[info exists tagids($sha1string)]} {
2687 set id $tagids($sha1string)
2689 set id [string tolower $sha1string]
2690 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2692 for {set l 0} {$l < $numcommits} {incr l} {
2693 if {[string match $id* $lineid($l)]} {
2694 lappend matches $lineid($l)
2697 if {$matches ne {}} {
2698 if {[llength $matches] > 1} {
2699 error_popup "Short SHA1 id $id is ambiguous"
2702 set id [lindex $matches 0]
2706 if {[info exists idline($id)]} {
2707 selectline $idline($id) 1
2710 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2715 error_popup "$type $sha1string is not known"
2718 proc lineenter {x y id} {
2719 global hoverx hovery hoverid hovertimer
2720 global commitinfo canv
2722 if {![info exists commitinfo($id)]} return
2726 if {[info exists hovertimer]} {
2727 after cancel $hovertimer
2729 set hovertimer [after 500 linehover]
2733 proc linemotion {x y id} {
2734 global hoverx hovery hoverid hovertimer
2736 if {[info exists hoverid] && $id == $hoverid} {
2739 if {[info exists hovertimer]} {
2740 after cancel $hovertimer
2742 set hovertimer [after 500 linehover]
2746 proc lineleave {id} {
2747 global hoverid hovertimer canv
2749 if {[info exists hoverid] && $id == $hoverid} {
2751 if {[info exists hovertimer]} {
2752 after cancel $hovertimer
2760 global hoverx hovery hoverid hovertimer
2761 global canv linespc lthickness
2762 global commitinfo mainfont
2764 set text [lindex $commitinfo($hoverid) 0]
2765 set ymax [lindex [$canv cget -scrollregion] 3]
2766 if {$ymax == {}} return
2767 set yfrac [lindex [$canv yview] 0]
2768 set x [expr {$hoverx + 2 * $linespc}]
2769 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2770 set x0 [expr {$x - 2 * $lthickness}]
2771 set y0 [expr {$y - 2 * $lthickness}]
2772 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2773 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2774 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2775 -fill \#ffff80 -outline black -width 1 -tags hover]
2777 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2781 proc lineclick {x y id} {
2782 global ctext commitinfo children cflist canv
2786 # fill the details pane with info about this line
2787 $ctext conf -state normal
2788 $ctext delete 0.0 end
2789 $ctext insert end "Parent:\n "
2790 catch {destroy $ctext.$id}
2791 button $ctext.$id -text "Go:" -command "selbyid $id" \
2793 $ctext window create end -window $ctext.$id -align center
2794 set info $commitinfo($id)
2795 $ctext insert end "\t[lindex $info 0]\n"
2796 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2797 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2798 $ctext insert end "\tID:\t$id\n"
2799 if {[info exists children($id)]} {
2800 $ctext insert end "\nChildren:"
2801 foreach child $children($id) {
2802 $ctext insert end "\n "
2803 catch {destroy $ctext.$child}
2804 button $ctext.$child -text "Go:" -command "selbyid $child" \
2806 $ctext window create end -window $ctext.$child -align center
2807 set info $commitinfo($child)
2808 $ctext insert end "\t[lindex $info 0]"
2811 $ctext conf -state disabled
2813 $cflist delete 0 end
2818 if {[info exists idline($id)]} {
2819 selectline $idline($id) 1
2825 if {![info exists startmstime]} {
2826 set startmstime [clock clicks -milliseconds]
2828 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2831 proc rowmenu {x y id} {
2832 global rowctxmenu idline selectedline rowmenuid
2834 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2839 $rowctxmenu entryconfigure 0 -state $state
2840 $rowctxmenu entryconfigure 1 -state $state
2841 $rowctxmenu entryconfigure 2 -state $state
2843 tk_popup $rowctxmenu $x $y
2846 proc diffvssel {dirn} {
2847 global rowmenuid selectedline lineid
2851 if {![info exists selectedline]} return
2853 set oldid $lineid($selectedline)
2854 set newid $rowmenuid
2856 set oldid $rowmenuid
2857 set newid $lineid($selectedline)
2859 $ctext conf -state normal
2860 $ctext delete 0.0 end
2861 $ctext mark set fmark.0 0.0
2862 $ctext mark gravity fmark.0 left
2863 $cflist delete 0 end
2864 $cflist insert end "Top"
2865 $ctext insert end "From $oldid\n "
2866 $ctext insert end [lindex $commitinfo($oldid) 0]
2867 $ctext insert end "\n\nTo $newid\n "
2868 $ctext insert end [lindex $commitinfo($newid) 0]
2869 $ctext insert end "\n"
2870 $ctext conf -state disabled
2871 $ctext tag delete Comments
2872 $ctext tag remove found 1.0 end
2873 startdiff [list $newid $oldid]
2877 global rowmenuid currentid commitinfo patchtop patchnum
2879 if {![info exists currentid]} return
2880 set oldid $currentid
2881 set oldhead [lindex $commitinfo($oldid) 0]
2882 set newid $rowmenuid
2883 set newhead [lindex $commitinfo($newid) 0]
2886 catch {destroy $top}
2888 label $top.title -text "Generate patch"
2889 grid $top.title - -pady 10
2890 label $top.from -text "From:"
2891 entry $top.fromsha1 -width 40 -relief flat
2892 $top.fromsha1 insert 0 $oldid
2893 $top.fromsha1 conf -state readonly
2894 grid $top.from $top.fromsha1 -sticky w
2895 entry $top.fromhead -width 60 -relief flat
2896 $top.fromhead insert 0 $oldhead
2897 $top.fromhead conf -state readonly
2898 grid x $top.fromhead -sticky w
2899 label $top.to -text "To:"
2900 entry $top.tosha1 -width 40 -relief flat
2901 $top.tosha1 insert 0 $newid
2902 $top.tosha1 conf -state readonly
2903 grid $top.to $top.tosha1 -sticky w
2904 entry $top.tohead -width 60 -relief flat
2905 $top.tohead insert 0 $newhead
2906 $top.tohead conf -state readonly
2907 grid x $top.tohead -sticky w
2908 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2909 grid $top.rev x -pady 10
2910 label $top.flab -text "Output file:"
2911 entry $top.fname -width 60
2912 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2914 grid $top.flab $top.fname -sticky w
2916 button $top.buts.gen -text "Generate" -command mkpatchgo
2917 button $top.buts.can -text "Cancel" -command mkpatchcan
2918 grid $top.buts.gen $top.buts.can
2919 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2920 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2921 grid $top.buts - -pady 10 -sticky ew
2925 proc mkpatchrev {} {
2928 set oldid [$patchtop.fromsha1 get]
2929 set oldhead [$patchtop.fromhead get]
2930 set newid [$patchtop.tosha1 get]
2931 set newhead [$patchtop.tohead get]
2932 foreach e [list fromsha1 fromhead tosha1 tohead] \
2933 v [list $newid $newhead $oldid $oldhead] {
2934 $patchtop.$e conf -state normal
2935 $patchtop.$e delete 0 end
2936 $patchtop.$e insert 0 $v
2937 $patchtop.$e conf -state readonly
2944 set oldid [$patchtop.fromsha1 get]
2945 set newid [$patchtop.tosha1 get]
2946 set fname [$patchtop.fname get]
2947 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2948 error_popup "Error creating patch: $err"
2950 catch {destroy $patchtop}
2954 proc mkpatchcan {} {
2957 catch {destroy $patchtop}
2962 global rowmenuid mktagtop commitinfo
2966 catch {destroy $top}
2968 label $top.title -text "Create tag"
2969 grid $top.title - -pady 10
2970 label $top.id -text "ID:"
2971 entry $top.sha1 -width 40 -relief flat
2972 $top.sha1 insert 0 $rowmenuid
2973 $top.sha1 conf -state readonly
2974 grid $top.id $top.sha1 -sticky w
2975 entry $top.head -width 60 -relief flat
2976 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2977 $top.head conf -state readonly
2978 grid x $top.head -sticky w
2979 label $top.tlab -text "Tag name:"
2980 entry $top.tag -width 60
2981 grid $top.tlab $top.tag -sticky w
2983 button $top.buts.gen -text "Create" -command mktaggo
2984 button $top.buts.can -text "Cancel" -command mktagcan
2985 grid $top.buts.gen $top.buts.can
2986 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2987 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2988 grid $top.buts - -pady 10 -sticky ew
2993 global mktagtop env tagids idtags
2994 global idpos idline linehtag canv selectedline
2996 set id [$mktagtop.sha1 get]
2997 set tag [$mktagtop.tag get]
2999 error_popup "No tag name specified"
3002 if {[info exists tagids($tag)]} {
3003 error_popup "Tag \"$tag\" already exists"
3008 set fname [file join $dir "refs/tags" $tag]
3009 set f [open $fname w]
3013 error_popup "Error creating tag: $err"
3017 set tagids($tag) $id
3018 lappend idtags($id) $tag
3019 $canv delete tag.$id
3020 set xt [eval drawtags $id $idpos($id)]
3021 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3022 if {[info exists selectedline] && $selectedline == $idline($id)} {
3023 selectline $selectedline 0
3030 catch {destroy $mktagtop}
3039 proc writecommit {} {
3040 global rowmenuid wrcomtop commitinfo wrcomcmd
3042 set top .writecommit
3044 catch {destroy $top}
3046 label $top.title -text "Write commit to file"
3047 grid $top.title - -pady 10
3048 label $top.id -text "ID:"
3049 entry $top.sha1 -width 40 -relief flat
3050 $top.sha1 insert 0 $rowmenuid
3051 $top.sha1 conf -state readonly
3052 grid $top.id $top.sha1 -sticky w
3053 entry $top.head -width 60 -relief flat
3054 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3055 $top.head conf -state readonly
3056 grid x $top.head -sticky w
3057 label $top.clab -text "Command:"
3058 entry $top.cmd -width 60 -textvariable wrcomcmd
3059 grid $top.clab $top.cmd -sticky w -pady 10
3060 label $top.flab -text "Output file:"
3061 entry $top.fname -width 60
3062 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3063 grid $top.flab $top.fname -sticky w
3065 button $top.buts.gen -text "Write" -command wrcomgo
3066 button $top.buts.can -text "Cancel" -command wrcomcan
3067 grid $top.buts.gen $top.buts.can
3068 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3069 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3070 grid $top.buts - -pady 10 -sticky ew
3077 set id [$wrcomtop.sha1 get]
3078 set cmd "echo $id | [$wrcomtop.cmd get]"
3079 set fname [$wrcomtop.fname get]
3080 if {[catch {exec sh -c $cmd >$fname &} err]} {
3081 error_popup "Error writing commit: $err"
3083 catch {destroy $wrcomtop}
3090 catch {destroy $wrcomtop}
3103 set diffopts "-U 5 -p"
3104 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3106 set mainfont {Helvetica 9}
3107 set textfont {Courier 9}
3108 set findmergefiles 0
3112 set colors {green red blue magenta darkgrey brown orange}
3114 catch {source ~/.gitk}
3116 set namefont $mainfont
3118 lappend namefont bold
3123 switch -regexp -- $arg {
3125 "^-b" { set boldnames 1 }
3126 "^-d" { set datemode 1 }
3128 lappend revtreeargs $arg
3143 getcommits $revtreeargs