[PATCH] list shortlog items in commit order
[git/fastimport.git] / gitk
blobefdb0a7f613d9f8715d32bf6545ed656ef4f1f1b
1 #!/bin/sh
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.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return ".git"
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...
25 set gitdir [gitdir]
26 if {![file isdirectory $gitdir]} {
27 error_popup "Cannot find the git directory \"$gitdir\"."
28 exit 1
30 set commits {}
31 set phase getcommits
32 set startmsecs [clock clicks -milliseconds]
33 set nextupdate [expr $startmsecs + 100]
34 if [catch {
35 set parse_args [concat --default HEAD $rargs]
36 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
37 }] {
38 # if git-rev-parse failed for some reason...
39 if {$rargs == {}} {
40 set rargs HEAD
42 set parsed_args $rargs
44 if [catch {
45 set commfd [open "|git-rev-list --header --topo-order $parsed_args" r]
46 } err] {
47 puts stderr "Error executing git-rev-list: $err"
48 exit 1
50 set leftover {}
51 fconfigure $commfd -blocking 0 -translation binary
52 fileevent $commfd readable "getcommitlines $commfd"
53 $canv delete all
54 $canv create text 3 3 -anchor nw -text "Reading commits..." \
55 -font $mainfont -tags textitems
56 . config -cursor watch
57 $ctext 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]
66 if {$stuff == {}} {
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
72 return
74 if {[string range $err 0 4] == "usage"} {
75 set err \
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.)}
79 } else {
80 set err "Error reading commits: $err"
82 error_popup $err
83 exit 1
85 set start 0
86 while 1 {
87 set i [string first "\0" $stuff $start]
88 if {$i < 0} {
89 append leftover [string range $stuff $start end]
90 return
92 set cmit [string range $stuff $start [expr {$i - 1}]]
93 if {$start == 0} {
94 set cmit "$leftover$cmit"
95 set leftover {}
97 set start [expr {$i + 1}]
98 if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
99 set shortcmit $cmit
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}"
104 exit 1
106 set cmit [string range $cmit 41 end]
107 lappend commits $id
108 set commitlisted($id) 1
109 parsecommit $id $cmit 1
110 drawcommit $id
111 if {[clock clicks -milliseconds] >= $nextupdate} {
112 doupdate
114 while {$redisplaying} {
115 set redisplaying 0
116 if {$stopped == 1} {
117 set stopped 0
118 set phase "getcommits"
119 foreach id $commits {
120 drawcommit $id
121 if {$stopped} break
122 if {[clock clicks -milliseconds] >= $nextupdate} {
123 doupdate
131 proc doupdate {} {
132 global commfd nextupdate
134 incr nextupdate 100
135 fileevent $commfd readable {}
136 update
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
148 set inhdr 1
149 set comment {}
150 set headline {}
151 set auname {}
152 set audate {}
153 set comname {}
154 set comdate {}
155 if {![info exists nchildren($id)]} {
156 set children($id) {}
157 set nchildren($id) 0
158 set ncleft($id) 0
160 set parents($id) {}
161 set nparents($id) 0
162 foreach line [split $contents "\n"] {
163 if {$inhdr} {
164 if {$line == {}} {
165 set inhdr 0
166 } else {
167 set tag [lindex $line 0]
168 if {$tag == "parent"} {
169 set p [lindex $line 1]
170 if {![info exists nchildren($p)]} {
171 set children($p) {}
172 set nchildren($p) 0
173 set ncleft($p) 0
175 lappend parents($id) $p
176 incr nparents($id)
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
180 incr nchildren($p)
181 incr ncleft($p)
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}]]
193 } else {
194 if {$comment == {}} {
195 set headline [string trim $line]
196 } else {
197 append comment "\n"
199 if {!$listed} {
200 # git-rev-list indents the comment by 4 spaces;
201 # if we got this via git-cat-file, add the indentation
202 append comment " "
204 append comment $line
207 if {$audate != {}} {
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]
218 proc readrefs {} {
219 global tagids idtags headids idheads
220 set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
221 foreach f $tags {
222 catch {
223 set fd [open $f r]
224 set line [read $fd]
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"]
230 set obj {}
231 set type {}
232 set tag {}
233 foreach l $contents {
234 if {$l == {}} break
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
246 close $fd
249 set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
250 foreach f $heads {
251 catch {
252 set fd [open $f r]
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
259 close $fd
264 proc error_popup msg {
265 set w .error
266 toplevel $w
267 wm transient $w .
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"
273 tkwait window $w
276 proc makewindow {} {
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
281 global rowctxmenu gaudydiff mergemax
283 menu .bar
284 .bar add cascade -label "File" -menu .bar.file
285 menu .bar.file
286 .bar.file add command -label "Quit" -command doquit
287 menu .bar.help
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]}]
308 frame .ctop.top
309 frame .ctop.top.bar
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
316 .ctop add .ctop.top
317 set canv .ctop.top.clist.canv
318 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
319 -bg white -bd 0 \
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
342 button .ctop.top.bar.findbut -text "Find" -command dofind
343 pack .ctop.top.bar.findbut -side left
344 set findstring {}
345 set fstring .ctop.top.bar.findstring
346 lappend entries $fstring
347 entry $fstring -width 30 -font $textfont -textvariable findstring
348 pack $fstring -side left -expand 1 -fill x
349 set findtype Exact
350 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
351 findtype Exact IgnCase Regexp]
352 set findloc "All fields"
353 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
354 Comments Author Committer Files Pickaxe
355 pack .ctop.top.bar.findloc -side right
356 pack .ctop.top.bar.findtype -side right
357 # for making sure type==Exact whenever loc==Pickaxe
358 trace add variable findloc write findlocchange
360 panedwindow .ctop.cdet -orient horizontal
361 .ctop add .ctop.cdet
362 frame .ctop.cdet.left
363 set ctext .ctop.cdet.left.ctext
364 text $ctext -bg white -state disabled -font $textfont \
365 -width $geometry(ctextw) -height $geometry(ctexth) \
366 -yscrollcommand ".ctop.cdet.left.sb set"
367 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
368 pack .ctop.cdet.left.sb -side right -fill y
369 pack $ctext -side left -fill both -expand 1
370 .ctop.cdet add .ctop.cdet.left
372 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
373 if {$gaudydiff} {
374 $ctext tag conf hunksep -back blue -fore white
375 $ctext tag conf d0 -back "#ff8080"
376 $ctext tag conf d1 -back green
377 } else {
378 $ctext tag conf hunksep -fore blue
379 $ctext tag conf d0 -fore red
380 $ctext tag conf d1 -fore "#00a000"
381 $ctext tag conf m0 -fore red
382 $ctext tag conf m1 -fore blue
383 $ctext tag conf m2 -fore green
384 $ctext tag conf m3 -fore purple
385 $ctext tag conf m4 -fore brown
386 $ctext tag conf mmax -fore darkgrey
387 set mergemax 5
388 $ctext tag conf mresult -font [concat $textfont bold]
389 $ctext tag conf msep -font [concat $textfont bold]
390 $ctext tag conf found -back yellow
393 frame .ctop.cdet.right
394 set cflist .ctop.cdet.right.cfiles
395 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
396 -yscrollcommand ".ctop.cdet.right.sb set"
397 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
398 pack .ctop.cdet.right.sb -side right -fill y
399 pack $cflist -side left -fill both -expand 1
400 .ctop.cdet add .ctop.cdet.right
401 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
403 pack .ctop -side top -fill both -expand 1
405 bindall <1> {selcanvline %W %x %y}
406 #bindall <B1-Motion> {selcanvline %W %x %y}
407 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
408 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
409 bindall <2> "allcanvs scan mark 0 %y"
410 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
411 bind . <Key-Up> "selnextline -1"
412 bind . <Key-Down> "selnextline 1"
413 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
414 bind . <Key-Next> "allcanvs yview scroll 1 pages"
415 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
416 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
417 bindkey <Key-space> "$ctext yview scroll 1 pages"
418 bindkey p "selnextline -1"
419 bindkey n "selnextline 1"
420 bindkey b "$ctext yview scroll -1 pages"
421 bindkey d "$ctext yview scroll 18 units"
422 bindkey u "$ctext yview scroll -18 units"
423 bindkey / {findnext 1}
424 bindkey <Key-Return> {findnext 0}
425 bindkey ? findprev
426 bindkey f nextfile
427 bind . <Control-q> doquit
428 bind . <Control-f> dofind
429 bind . <Control-g> {findnext 0}
430 bind . <Control-r> findprev
431 bind . <Control-equal> {incrfont 1}
432 bind . <Control-KP_Add> {incrfont 1}
433 bind . <Control-minus> {incrfont -1}
434 bind . <Control-KP_Subtract> {incrfont -1}
435 bind $cflist <<ListboxSelect>> listboxsel
436 bind . <Destroy> {savestuff %W}
437 bind . <Button-1> "click %W"
438 bind $fstring <Key-Return> dofind
439 bind $sha1entry <Key-Return> gotocommit
440 bind $sha1entry <<PasteSelection>> clearsha1
442 set maincursor [. cget -cursor]
443 set textcursor [$ctext cget -cursor]
445 set rowctxmenu .rowctxmenu
446 menu $rowctxmenu -tearoff 0
447 $rowctxmenu add command -label "Diff this -> selected" \
448 -command {diffvssel 0}
449 $rowctxmenu add command -label "Diff selected -> this" \
450 -command {diffvssel 1}
451 $rowctxmenu add command -label "Make patch" -command mkpatch
452 $rowctxmenu add command -label "Create tag" -command mktag
453 $rowctxmenu add command -label "Write commit to file" -command writecommit
456 # when we make a key binding for the toplevel, make sure
457 # it doesn't get triggered when that key is pressed in the
458 # find string entry widget.
459 proc bindkey {ev script} {
460 global entries
461 bind . $ev $script
462 set escript [bind Entry $ev]
463 if {$escript == {}} {
464 set escript [bind Entry <Key>]
466 foreach e $entries {
467 bind $e $ev "$escript; break"
471 # set the focus back to the toplevel for any click outside
472 # the entry widgets
473 proc click {w} {
474 global entries
475 foreach e $entries {
476 if {$w == $e} return
478 focus .
481 proc savestuff {w} {
482 global canv canv2 canv3 ctext cflist mainfont textfont
483 global stuffsaved findmergefiles gaudydiff
485 if {$stuffsaved} return
486 if {![winfo viewable .]} return
487 catch {
488 set f [open "~/.gitk-new" w]
489 puts $f [list set mainfont $mainfont]
490 puts $f [list set textfont $textfont]
491 puts $f [list set findmergefiles $findmergefiles]
492 puts $f [list set gaudydiff $gaudydiff]
493 puts $f "set geometry(width) [winfo width .ctop]"
494 puts $f "set geometry(height) [winfo height .ctop]"
495 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
496 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
497 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
498 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
499 set wid [expr {([winfo width $ctext] - 8) \
500 / [font measure $textfont "0"]}]
501 puts $f "set geometry(ctextw) $wid"
502 set wid [expr {([winfo width $cflist] - 11) \
503 / [font measure [$cflist cget -font] "0"]}]
504 puts $f "set geometry(cflistw) $wid"
505 close $f
506 file rename -force "~/.gitk-new" "~/.gitk"
508 set stuffsaved 1
511 proc resizeclistpanes {win w} {
512 global oldwidth
513 if [info exists oldwidth($win)] {
514 set s0 [$win sash coord 0]
515 set s1 [$win sash coord 1]
516 if {$w < 60} {
517 set sash0 [expr {int($w/2 - 2)}]
518 set sash1 [expr {int($w*5/6 - 2)}]
519 } else {
520 set factor [expr {1.0 * $w / $oldwidth($win)}]
521 set sash0 [expr {int($factor * [lindex $s0 0])}]
522 set sash1 [expr {int($factor * [lindex $s1 0])}]
523 if {$sash0 < 30} {
524 set sash0 30
526 if {$sash1 < $sash0 + 20} {
527 set sash1 [expr $sash0 + 20]
529 if {$sash1 > $w - 10} {
530 set sash1 [expr $w - 10]
531 if {$sash0 > $sash1 - 20} {
532 set sash0 [expr $sash1 - 20]
536 $win sash place 0 $sash0 [lindex $s0 1]
537 $win sash place 1 $sash1 [lindex $s1 1]
539 set oldwidth($win) $w
542 proc resizecdetpanes {win w} {
543 global oldwidth
544 if [info exists oldwidth($win)] {
545 set s0 [$win sash coord 0]
546 if {$w < 60} {
547 set sash0 [expr {int($w*3/4 - 2)}]
548 } else {
549 set factor [expr {1.0 * $w / $oldwidth($win)}]
550 set sash0 [expr {int($factor * [lindex $s0 0])}]
551 if {$sash0 < 45} {
552 set sash0 45
554 if {$sash0 > $w - 15} {
555 set sash0 [expr $w - 15]
558 $win sash place 0 $sash0 [lindex $s0 1]
560 set oldwidth($win) $w
563 proc allcanvs args {
564 global canv canv2 canv3
565 eval $canv $args
566 eval $canv2 $args
567 eval $canv3 $args
570 proc bindall {event action} {
571 global canv canv2 canv3
572 bind $canv $event $action
573 bind $canv2 $event $action
574 bind $canv3 $event $action
577 proc about {} {
578 set w .about
579 if {[winfo exists $w]} {
580 raise $w
581 return
583 toplevel $w
584 wm title $w "About gitk"
585 message $w.m -text {
586 Gitk version 1.2
588 Copyright © 2005 Paul Mackerras
590 Use and redistribute under the terms of the GNU General Public License} \
591 -justify center -aspect 400
592 pack $w.m -side top -fill x -padx 20 -pady 20
593 button $w.ok -text Close -command "destroy $w"
594 pack $w.ok -side bottom
597 proc assigncolor {id} {
598 global commitinfo colormap commcolors colors nextcolor
599 global parents nparents children nchildren
600 global cornercrossings crossings
602 if [info exists colormap($id)] return
603 set ncolors [llength $colors]
604 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
605 set child [lindex $children($id) 0]
606 if {[info exists colormap($child)]
607 && $nparents($child) == 1} {
608 set colormap($id) $colormap($child)
609 return
612 set badcolors {}
613 if {[info exists cornercrossings($id)]} {
614 foreach x $cornercrossings($id) {
615 if {[info exists colormap($x)]
616 && [lsearch -exact $badcolors $colormap($x)] < 0} {
617 lappend badcolors $colormap($x)
620 if {[llength $badcolors] >= $ncolors} {
621 set badcolors {}
624 set origbad $badcolors
625 if {[llength $badcolors] < $ncolors - 1} {
626 if {[info exists crossings($id)]} {
627 foreach x $crossings($id) {
628 if {[info exists colormap($x)]
629 && [lsearch -exact $badcolors $colormap($x)] < 0} {
630 lappend badcolors $colormap($x)
633 if {[llength $badcolors] >= $ncolors} {
634 set badcolors $origbad
637 set origbad $badcolors
639 if {[llength $badcolors] < $ncolors - 1} {
640 foreach child $children($id) {
641 if {[info exists colormap($child)]
642 && [lsearch -exact $badcolors $colormap($child)] < 0} {
643 lappend badcolors $colormap($child)
645 if {[info exists parents($child)]} {
646 foreach p $parents($child) {
647 if {[info exists colormap($p)]
648 && [lsearch -exact $badcolors $colormap($p)] < 0} {
649 lappend badcolors $colormap($p)
654 if {[llength $badcolors] >= $ncolors} {
655 set badcolors $origbad
658 for {set i 0} {$i <= $ncolors} {incr i} {
659 set c [lindex $colors $nextcolor]
660 if {[incr nextcolor] >= $ncolors} {
661 set nextcolor 0
663 if {[lsearch -exact $badcolors $c]} break
665 set colormap($id) $c
668 proc initgraph {} {
669 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
670 global mainline sidelines
671 global nchildren ncleft
673 allcanvs delete all
674 set nextcolor 0
675 set canvy $canvy0
676 set lineno -1
677 set numcommits 0
678 set lthickness [expr {int($linespc / 9) + 1}]
679 catch {unset mainline}
680 catch {unset sidelines}
681 foreach id [array names nchildren] {
682 set ncleft($id) $nchildren($id)
686 proc bindline {t id} {
687 global canv
689 $canv bind $t <Enter> "lineenter %x %y $id"
690 $canv bind $t <Motion> "linemotion %x %y $id"
691 $canv bind $t <Leave> "lineleave $id"
692 $canv bind $t <Button-1> "lineclick %x %y $id"
695 proc drawcommitline {level} {
696 global parents children nparents nchildren todo
697 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
698 global lineid linehtag linentag linedtag commitinfo
699 global colormap numcommits currentparents dupparents
700 global oldlevel oldnlines oldtodo
701 global idtags idline idheads
702 global lineno lthickness mainline sidelines
703 global commitlisted rowtextx idpos
705 incr numcommits
706 incr lineno
707 set id [lindex $todo $level]
708 set lineid($lineno) $id
709 set idline($id) $lineno
710 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
711 if {![info exists commitinfo($id)]} {
712 readcommit $id
713 if {![info exists commitinfo($id)]} {
714 set commitinfo($id) {"No commit information available"}
715 set nparents($id) 0
718 assigncolor $id
719 set currentparents {}
720 set dupparents {}
721 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
722 foreach p $parents($id) {
723 if {[lsearch -exact $currentparents $p] < 0} {
724 lappend currentparents $p
725 } else {
726 # remember that this parent was listed twice
727 lappend dupparents $p
731 set x [expr $canvx0 + $level * $linespc]
732 set y1 $canvy
733 set canvy [expr $canvy + $linespc]
734 allcanvs conf -scrollregion \
735 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
736 if {[info exists mainline($id)]} {
737 lappend mainline($id) $x $y1
738 set t [$canv create line $mainline($id) \
739 -width $lthickness -fill $colormap($id)]
740 $canv lower $t
741 bindline $t $id
743 if {[info exists sidelines($id)]} {
744 foreach ls $sidelines($id) {
745 set coords [lindex $ls 0]
746 set thick [lindex $ls 1]
747 set t [$canv create line $coords -fill $colormap($id) \
748 -width [expr {$thick * $lthickness}]]
749 $canv lower $t
750 bindline $t $id
753 set orad [expr {$linespc / 3}]
754 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
755 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
756 -fill $ofill -outline black -width 1]
757 $canv raise $t
758 $canv bind $t <1> {selcanvline {} %x %y}
759 set xt [expr $canvx0 + [llength $todo] * $linespc]
760 if {[llength $currentparents] > 2} {
761 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
763 set rowtextx($lineno) $xt
764 set idpos($id) [list $x $xt $y1]
765 if {[info exists idtags($id)] || [info exists idheads($id)]} {
766 set xt [drawtags $id $x $xt $y1]
768 set headline [lindex $commitinfo($id) 0]
769 set name [lindex $commitinfo($id) 1]
770 set date [lindex $commitinfo($id) 2]
771 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
772 -text $headline -font $mainfont ]
773 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
774 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
775 -text $name -font $namefont]
776 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
777 -text $date -font $mainfont]
780 proc drawtags {id x xt y1} {
781 global idtags idheads
782 global linespc lthickness
783 global canv mainfont
785 set marks {}
786 set ntags 0
787 if {[info exists idtags($id)]} {
788 set marks $idtags($id)
789 set ntags [llength $marks]
791 if {[info exists idheads($id)]} {
792 set marks [concat $marks $idheads($id)]
794 if {$marks eq {}} {
795 return $xt
798 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
799 set yt [expr $y1 - 0.5 * $linespc]
800 set yb [expr $yt + $linespc - 1]
801 set xvals {}
802 set wvals {}
803 foreach tag $marks {
804 set wid [font measure $mainfont $tag]
805 lappend xvals $xt
806 lappend wvals $wid
807 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
809 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
810 -width $lthickness -fill black -tags tag.$id]
811 $canv lower $t
812 foreach tag $marks x $xvals wid $wvals {
813 set xl [expr $x + $delta]
814 set xr [expr $x + $delta + $wid + $lthickness]
815 if {[incr ntags -1] >= 0} {
816 # draw a tag
817 $canv create polygon $x [expr $yt + $delta] $xl $yt\
818 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
819 -width 1 -outline black -fill yellow -tags tag.$id
820 } else {
821 # draw a head
822 set xl [expr $xl - $delta/2]
823 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
824 -width 1 -outline black -fill green -tags tag.$id
826 $canv create text $xl $y1 -anchor w -text $tag \
827 -font $mainfont -tags tag.$id
829 return $xt
832 proc updatetodo {level noshortcut} {
833 global currentparents ncleft todo
834 global mainline oldlevel oldtodo oldnlines
835 global canvx0 canvy linespc mainline
836 global commitinfo
838 set oldlevel $level
839 set oldtodo $todo
840 set oldnlines [llength $todo]
841 if {!$noshortcut && [llength $currentparents] == 1} {
842 set p [lindex $currentparents 0]
843 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
844 set ncleft($p) 0
845 set x [expr $canvx0 + $level * $linespc]
846 set y [expr $canvy - $linespc]
847 set mainline($p) [list $x $y]
848 set todo [lreplace $todo $level $level $p]
849 return 0
853 set todo [lreplace $todo $level $level]
854 set i $level
855 foreach p $currentparents {
856 incr ncleft($p) -1
857 set k [lsearch -exact $todo $p]
858 if {$k < 0} {
859 set todo [linsert $todo $i $p]
860 incr i
863 return 1
866 proc notecrossings {id lo hi corner} {
867 global oldtodo crossings cornercrossings
869 for {set i $lo} {[incr i] < $hi} {} {
870 set p [lindex $oldtodo $i]
871 if {$p == {}} continue
872 if {$i == $corner} {
873 if {![info exists cornercrossings($id)]
874 || [lsearch -exact $cornercrossings($id) $p] < 0} {
875 lappend cornercrossings($id) $p
877 if {![info exists cornercrossings($p)]
878 || [lsearch -exact $cornercrossings($p) $id] < 0} {
879 lappend cornercrossings($p) $id
881 } else {
882 if {![info exists crossings($id)]
883 || [lsearch -exact $crossings($id) $p] < 0} {
884 lappend crossings($id) $p
886 if {![info exists crossings($p)]
887 || [lsearch -exact $crossings($p) $id] < 0} {
888 lappend crossings($p) $id
894 proc drawslants {} {
895 global canv mainline sidelines canvx0 canvy linespc
896 global oldlevel oldtodo todo currentparents dupparents
897 global lthickness linespc canvy colormap
899 set y1 [expr $canvy - $linespc]
900 set y2 $canvy
901 set i -1
902 foreach id $oldtodo {
903 incr i
904 if {$id == {}} continue
905 set xi [expr {$canvx0 + $i * $linespc}]
906 if {$i == $oldlevel} {
907 foreach p $currentparents {
908 set j [lsearch -exact $todo $p]
909 set coords [list $xi $y1]
910 set xj [expr {$canvx0 + $j * $linespc}]
911 if {$j < $i - 1} {
912 lappend coords [expr $xj + $linespc] $y1
913 notecrossings $p $j $i [expr {$j + 1}]
914 } elseif {$j > $i + 1} {
915 lappend coords [expr $xj - $linespc] $y1
916 notecrossings $p $i $j [expr {$j - 1}]
918 if {[lsearch -exact $dupparents $p] >= 0} {
919 # draw a double-width line to indicate the doubled parent
920 lappend coords $xj $y2
921 lappend sidelines($p) [list $coords 2]
922 if {![info exists mainline($p)]} {
923 set mainline($p) [list $xj $y2]
925 } else {
926 # normal case, no parent duplicated
927 if {![info exists mainline($p)]} {
928 if {$i != $j} {
929 lappend coords $xj $y2
931 set mainline($p) $coords
932 } else {
933 lappend coords $xj $y2
934 lappend sidelines($p) [list $coords 1]
938 } elseif {[lindex $todo $i] != $id} {
939 set j [lsearch -exact $todo $id]
940 set xj [expr {$canvx0 + $j * $linespc}]
941 lappend mainline($id) $xi $y1 $xj $y2
946 proc decidenext {{noread 0}} {
947 global parents children nchildren ncleft todo
948 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
949 global datemode cdate
950 global commitinfo
951 global currentparents oldlevel oldnlines oldtodo
952 global lineno lthickness
954 # remove the null entry if present
955 set nullentry [lsearch -exact $todo {}]
956 if {$nullentry >= 0} {
957 set todo [lreplace $todo $nullentry $nullentry]
960 # choose which one to do next time around
961 set todol [llength $todo]
962 set level -1
963 set latest {}
964 for {set k $todol} {[incr k -1] >= 0} {} {
965 set p [lindex $todo $k]
966 if {$ncleft($p) == 0} {
967 if {$datemode} {
968 if {![info exists commitinfo($p)]} {
969 if {$noread} {
970 return {}
972 readcommit $p
974 if {$latest == {} || $cdate($p) > $latest} {
975 set level $k
976 set latest $cdate($p)
978 } else {
979 set level $k
980 break
984 if {$level < 0} {
985 if {$todo != {}} {
986 puts "ERROR: none of the pending commits can be done yet:"
987 foreach p $todo {
988 puts " $p ($ncleft($p))"
991 return -1
994 # If we are reducing, put in a null entry
995 if {$todol < $oldnlines} {
996 if {$nullentry >= 0} {
997 set i $nullentry
998 while {$i < $todol
999 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1000 incr i
1002 } else {
1003 set i $oldlevel
1004 if {$level >= $i} {
1005 incr i
1008 if {$i < $todol} {
1009 set todo [linsert $todo $i {}]
1010 if {$level >= $i} {
1011 incr level
1015 return $level
1018 proc drawcommit {id} {
1019 global phase todo nchildren datemode nextupdate
1020 global startcommits
1022 if {$phase != "incrdraw"} {
1023 set phase incrdraw
1024 set todo $id
1025 set startcommits $id
1026 initgraph
1027 drawcommitline 0
1028 updatetodo 0 $datemode
1029 } else {
1030 if {$nchildren($id) == 0} {
1031 lappend todo $id
1032 lappend startcommits $id
1034 set level [decidenext 1]
1035 if {$level == {} || $id != [lindex $todo $level]} {
1036 return
1038 while 1 {
1039 drawslants
1040 drawcommitline $level
1041 if {[updatetodo $level $datemode]} {
1042 set level [decidenext 1]
1043 if {$level == {}} break
1045 set id [lindex $todo $level]
1046 if {![info exists commitlisted($id)]} {
1047 break
1049 if {[clock clicks -milliseconds] >= $nextupdate} {
1050 doupdate
1051 if {$stopped} break
1057 proc finishcommits {} {
1058 global phase
1059 global startcommits
1060 global canv mainfont ctext maincursor textcursor
1062 if {$phase != "incrdraw"} {
1063 $canv delete all
1064 $canv create text 3 3 -anchor nw -text "No commits selected" \
1065 -font $mainfont -tags textitems
1066 set phase {}
1067 } else {
1068 drawslants
1069 set level [decidenext]
1070 drawrest $level [llength $startcommits]
1072 . config -cursor $maincursor
1073 $ctext config -cursor $textcursor
1076 proc drawgraph {} {
1077 global nextupdate startmsecs startcommits todo
1079 if {$startcommits == {}} return
1080 set startmsecs [clock clicks -milliseconds]
1081 set nextupdate [expr $startmsecs + 100]
1082 initgraph
1083 set todo [lindex $startcommits 0]
1084 drawrest 0 1
1087 proc drawrest {level startix} {
1088 global phase stopped redisplaying selectedline
1089 global datemode currentparents todo
1090 global numcommits
1091 global nextupdate startmsecs startcommits idline
1093 if {$level >= 0} {
1094 set phase drawgraph
1095 set startid [lindex $startcommits $startix]
1096 set startline -1
1097 if {$startid != {}} {
1098 set startline $idline($startid)
1100 while 1 {
1101 if {$stopped} break
1102 drawcommitline $level
1103 set hard [updatetodo $level $datemode]
1104 if {$numcommits == $startline} {
1105 lappend todo $startid
1106 set hard 1
1107 incr startix
1108 set startid [lindex $startcommits $startix]
1109 set startline -1
1110 if {$startid != {}} {
1111 set startline $idline($startid)
1114 if {$hard} {
1115 set level [decidenext]
1116 if {$level < 0} break
1117 drawslants
1119 if {[clock clicks -milliseconds] >= $nextupdate} {
1120 update
1121 incr nextupdate 100
1125 set phase {}
1126 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1127 #puts "overall $drawmsecs ms for $numcommits commits"
1128 if {$redisplaying} {
1129 if {$stopped == 0 && [info exists selectedline]} {
1130 selectline $selectedline
1132 if {$stopped == 1} {
1133 set stopped 0
1134 after idle drawgraph
1135 } else {
1136 set redisplaying 0
1141 proc findmatches {f} {
1142 global findtype foundstring foundstrlen
1143 if {$findtype == "Regexp"} {
1144 set matches [regexp -indices -all -inline $foundstring $f]
1145 } else {
1146 if {$findtype == "IgnCase"} {
1147 set str [string tolower $f]
1148 } else {
1149 set str $f
1151 set matches {}
1152 set i 0
1153 while {[set j [string first $foundstring $str $i]] >= 0} {
1154 lappend matches [list $j [expr $j+$foundstrlen-1]]
1155 set i [expr $j + $foundstrlen]
1158 return $matches
1161 proc dofind {} {
1162 global findtype findloc findstring markedmatches commitinfo
1163 global numcommits lineid linehtag linentag linedtag
1164 global mainfont namefont canv canv2 canv3 selectedline
1165 global matchinglines foundstring foundstrlen
1167 stopfindproc
1168 unmarkmatches
1169 focus .
1170 set matchinglines {}
1171 if {$findloc == "Pickaxe"} {
1172 findpatches
1173 return
1175 if {$findtype == "IgnCase"} {
1176 set foundstring [string tolower $findstring]
1177 } else {
1178 set foundstring $findstring
1180 set foundstrlen [string length $findstring]
1181 if {$foundstrlen == 0} return
1182 if {$findloc == "Files"} {
1183 findfiles
1184 return
1186 if {![info exists selectedline]} {
1187 set oldsel -1
1188 } else {
1189 set oldsel $selectedline
1191 set didsel 0
1192 set fldtypes {Headline Author Date Committer CDate Comment}
1193 for {set l 0} {$l < $numcommits} {incr l} {
1194 set id $lineid($l)
1195 set info $commitinfo($id)
1196 set doesmatch 0
1197 foreach f $info ty $fldtypes {
1198 if {$findloc != "All fields" && $findloc != $ty} {
1199 continue
1201 set matches [findmatches $f]
1202 if {$matches == {}} continue
1203 set doesmatch 1
1204 if {$ty == "Headline"} {
1205 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1206 } elseif {$ty == "Author"} {
1207 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1208 } elseif {$ty == "Date"} {
1209 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1212 if {$doesmatch} {
1213 lappend matchinglines $l
1214 if {!$didsel && $l > $oldsel} {
1215 findselectline $l
1216 set didsel 1
1220 if {$matchinglines == {}} {
1221 bell
1222 } elseif {!$didsel} {
1223 findselectline [lindex $matchinglines 0]
1227 proc findselectline {l} {
1228 global findloc commentend ctext
1229 selectline $l
1230 if {$findloc == "All fields" || $findloc == "Comments"} {
1231 # highlight the matches in the comments
1232 set f [$ctext get 1.0 $commentend]
1233 set matches [findmatches $f]
1234 foreach match $matches {
1235 set start [lindex $match 0]
1236 set end [expr [lindex $match 1] + 1]
1237 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1242 proc findnext {restart} {
1243 global matchinglines selectedline
1244 if {![info exists matchinglines]} {
1245 if {$restart} {
1246 dofind
1248 return
1250 if {![info exists selectedline]} return
1251 foreach l $matchinglines {
1252 if {$l > $selectedline} {
1253 findselectline $l
1254 return
1257 bell
1260 proc findprev {} {
1261 global matchinglines selectedline
1262 if {![info exists matchinglines]} {
1263 dofind
1264 return
1266 if {![info exists selectedline]} return
1267 set prev {}
1268 foreach l $matchinglines {
1269 if {$l >= $selectedline} break
1270 set prev $l
1272 if {$prev != {}} {
1273 findselectline $prev
1274 } else {
1275 bell
1279 proc findlocchange {name ix op} {
1280 global findloc findtype findtypemenu
1281 if {$findloc == "Pickaxe"} {
1282 set findtype Exact
1283 set state disabled
1284 } else {
1285 set state normal
1287 $findtypemenu entryconf 1 -state $state
1288 $findtypemenu entryconf 2 -state $state
1291 proc stopfindproc {{done 0}} {
1292 global findprocpid findprocfile findids
1293 global ctext findoldcursor phase maincursor textcursor
1294 global findinprogress
1296 catch {unset findids}
1297 if {[info exists findprocpid]} {
1298 if {!$done} {
1299 catch {exec kill $findprocpid}
1301 catch {close $findprocfile}
1302 unset findprocpid
1304 if {[info exists findinprogress]} {
1305 unset findinprogress
1306 if {$phase != "incrdraw"} {
1307 . config -cursor $maincursor
1308 $ctext config -cursor $textcursor
1313 proc findpatches {} {
1314 global findstring selectedline numcommits
1315 global findprocpid findprocfile
1316 global finddidsel ctext lineid findinprogress
1317 global findinsertpos
1319 if {$numcommits == 0} return
1321 # make a list of all the ids to search, starting at the one
1322 # after the selected line (if any)
1323 if {[info exists selectedline]} {
1324 set l $selectedline
1325 } else {
1326 set l -1
1328 set inputids {}
1329 for {set i 0} {$i < $numcommits} {incr i} {
1330 if {[incr l] >= $numcommits} {
1331 set l 0
1333 append inputids $lineid($l) "\n"
1336 if {[catch {
1337 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1338 << $inputids] r]
1339 } err]} {
1340 error_popup "Error starting search process: $err"
1341 return
1344 set findinsertpos end
1345 set findprocfile $f
1346 set findprocpid [pid $f]
1347 fconfigure $f -blocking 0
1348 fileevent $f readable readfindproc
1349 set finddidsel 0
1350 . config -cursor watch
1351 $ctext config -cursor watch
1352 set findinprogress 1
1355 proc readfindproc {} {
1356 global findprocfile finddidsel
1357 global idline matchinglines findinsertpos
1359 set n [gets $findprocfile line]
1360 if {$n < 0} {
1361 if {[eof $findprocfile]} {
1362 stopfindproc 1
1363 if {!$finddidsel} {
1364 bell
1367 return
1369 if {![regexp {^[0-9a-f]{40}} $line id]} {
1370 error_popup "Can't parse git-diff-tree output: $line"
1371 stopfindproc
1372 return
1374 if {![info exists idline($id)]} {
1375 puts stderr "spurious id: $id"
1376 return
1378 set l $idline($id)
1379 insertmatch $l $id
1382 proc insertmatch {l id} {
1383 global matchinglines findinsertpos finddidsel
1385 if {$findinsertpos == "end"} {
1386 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1387 set matchinglines [linsert $matchinglines 0 $l]
1388 set findinsertpos 1
1389 } else {
1390 lappend matchinglines $l
1392 } else {
1393 set matchinglines [linsert $matchinglines $findinsertpos $l]
1394 incr findinsertpos
1396 markheadline $l $id
1397 if {!$finddidsel} {
1398 findselectline $l
1399 set finddidsel 1
1403 proc findfiles {} {
1404 global selectedline numcommits lineid ctext
1405 global ffileline finddidsel parents nparents
1406 global findinprogress findstartline findinsertpos
1407 global treediffs fdiffids fdiffsneeded fdiffpos
1408 global findmergefiles
1410 if {$numcommits == 0} return
1412 if {[info exists selectedline]} {
1413 set l [expr {$selectedline + 1}]
1414 } else {
1415 set l 0
1417 set ffileline $l
1418 set findstartline $l
1419 set diffsneeded {}
1420 set fdiffsneeded {}
1421 while 1 {
1422 set id $lineid($l)
1423 if {$findmergefiles || $nparents($id) == 1} {
1424 foreach p $parents($id) {
1425 if {![info exists treediffs([list $id $p])]} {
1426 append diffsneeded "$id $p\n"
1427 lappend fdiffsneeded [list $id $p]
1431 if {[incr l] >= $numcommits} {
1432 set l 0
1434 if {$l == $findstartline} break
1437 # start off a git-diff-tree process if needed
1438 if {$diffsneeded ne {}} {
1439 if {[catch {
1440 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1441 } err ]} {
1442 error_popup "Error starting search process: $err"
1443 return
1445 catch {unset fdiffids}
1446 set fdiffpos 0
1447 fconfigure $df -blocking 0
1448 fileevent $df readable [list readfilediffs $df]
1451 set finddidsel 0
1452 set findinsertpos end
1453 set id $lineid($l)
1454 set p [lindex $parents($id) 0]
1455 . config -cursor watch
1456 $ctext config -cursor watch
1457 set findinprogress 1
1458 findcont [list $id $p]
1459 update
1462 proc readfilediffs {df} {
1463 global findids fdiffids fdiffs
1465 set n [gets $df line]
1466 if {$n < 0} {
1467 if {[eof $df]} {
1468 donefilediff
1469 if {[catch {close $df} err]} {
1470 stopfindproc
1471 bell
1472 error_popup "Error in git-diff-tree: $err"
1473 } elseif {[info exists findids]} {
1474 set ids $findids
1475 stopfindproc
1476 bell
1477 error_popup "Couldn't find diffs for {$ids}"
1480 return
1482 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1483 # start of a new string of diffs
1484 donefilediff
1485 set fdiffids [list $id $p]
1486 set fdiffs {}
1487 } elseif {[string match ":*" $line]} {
1488 lappend fdiffs [lindex $line 5]
1492 proc donefilediff {} {
1493 global fdiffids fdiffs treediffs findids
1494 global fdiffsneeded fdiffpos
1496 if {[info exists fdiffids]} {
1497 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1498 && $fdiffpos < [llength $fdiffsneeded]} {
1499 # git-diff-tree doesn't output anything for a commit
1500 # which doesn't change anything
1501 set nullids [lindex $fdiffsneeded $fdiffpos]
1502 set treediffs($nullids) {}
1503 if {[info exists findids] && $nullids eq $findids} {
1504 unset findids
1505 findcont $nullids
1507 incr fdiffpos
1509 incr fdiffpos
1511 if {![info exists treediffs($fdiffids)]} {
1512 set treediffs($fdiffids) $fdiffs
1514 if {[info exists findids] && $fdiffids eq $findids} {
1515 unset findids
1516 findcont $fdiffids
1521 proc findcont {ids} {
1522 global findids treediffs parents nparents
1523 global ffileline findstartline finddidsel
1524 global lineid numcommits matchinglines findinprogress
1525 global findmergefiles
1527 set id [lindex $ids 0]
1528 set p [lindex $ids 1]
1529 set pi [lsearch -exact $parents($id) $p]
1530 set l $ffileline
1531 while 1 {
1532 if {$findmergefiles || $nparents($id) == 1} {
1533 if {![info exists treediffs($ids)]} {
1534 set findids $ids
1535 set ffileline $l
1536 return
1538 set doesmatch 0
1539 foreach f $treediffs($ids) {
1540 set x [findmatches $f]
1541 if {$x != {}} {
1542 set doesmatch 1
1543 break
1546 if {$doesmatch} {
1547 insertmatch $l $id
1548 set pi $nparents($id)
1550 } else {
1551 set pi $nparents($id)
1553 if {[incr pi] >= $nparents($id)} {
1554 set pi 0
1555 if {[incr l] >= $numcommits} {
1556 set l 0
1558 if {$l == $findstartline} break
1559 set id $lineid($l)
1561 set p [lindex $parents($id) $pi]
1562 set ids [list $id $p]
1564 stopfindproc
1565 if {!$finddidsel} {
1566 bell
1570 # mark a commit as matching by putting a yellow background
1571 # behind the headline
1572 proc markheadline {l id} {
1573 global canv mainfont linehtag commitinfo
1575 set bbox [$canv bbox $linehtag($l)]
1576 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1577 $canv lower $t
1580 # mark the bits of a headline, author or date that match a find string
1581 proc markmatches {canv l str tag matches font} {
1582 set bbox [$canv bbox $tag]
1583 set x0 [lindex $bbox 0]
1584 set y0 [lindex $bbox 1]
1585 set y1 [lindex $bbox 3]
1586 foreach match $matches {
1587 set start [lindex $match 0]
1588 set end [lindex $match 1]
1589 if {$start > $end} continue
1590 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1591 set xlen [font measure $font [string range $str 0 [expr $end]]]
1592 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1593 -outline {} -tags matches -fill yellow]
1594 $canv lower $t
1598 proc unmarkmatches {} {
1599 global matchinglines findids
1600 allcanvs delete matches
1601 catch {unset matchinglines}
1602 catch {unset findids}
1605 proc selcanvline {w x y} {
1606 global canv canvy0 ctext linespc selectedline
1607 global lineid linehtag linentag linedtag rowtextx
1608 set ymax [lindex [$canv cget -scrollregion] 3]
1609 if {$ymax == {}} return
1610 set yfrac [lindex [$canv yview] 0]
1611 set y [expr {$y + $yfrac * $ymax}]
1612 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1613 if {$l < 0} {
1614 set l 0
1616 if {$w eq $canv} {
1617 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1619 unmarkmatches
1620 selectline $l
1623 proc selectline {l} {
1624 global canv canv2 canv3 ctext commitinfo selectedline
1625 global lineid linehtag linentag linedtag
1626 global canvy0 linespc parents nparents
1627 global cflist currentid sha1entry
1628 global commentend idtags
1629 $canv delete hover
1630 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1631 $canv delete secsel
1632 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1633 -tags secsel -fill [$canv cget -selectbackground]]
1634 $canv lower $t
1635 $canv2 delete secsel
1636 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1637 -tags secsel -fill [$canv2 cget -selectbackground]]
1638 $canv2 lower $t
1639 $canv3 delete secsel
1640 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1641 -tags secsel -fill [$canv3 cget -selectbackground]]
1642 $canv3 lower $t
1643 set y [expr {$canvy0 + $l * $linespc}]
1644 set ymax [lindex [$canv cget -scrollregion] 3]
1645 set ytop [expr {$y - $linespc - 1}]
1646 set ybot [expr {$y + $linespc + 1}]
1647 set wnow [$canv yview]
1648 set wtop [expr [lindex $wnow 0] * $ymax]
1649 set wbot [expr [lindex $wnow 1] * $ymax]
1650 set wh [expr {$wbot - $wtop}]
1651 set newtop $wtop
1652 if {$ytop < $wtop} {
1653 if {$ybot < $wtop} {
1654 set newtop [expr {$y - $wh / 2.0}]
1655 } else {
1656 set newtop $ytop
1657 if {$newtop > $wtop - $linespc} {
1658 set newtop [expr {$wtop - $linespc}]
1661 } elseif {$ybot > $wbot} {
1662 if {$ytop > $wbot} {
1663 set newtop [expr {$y - $wh / 2.0}]
1664 } else {
1665 set newtop [expr {$ybot - $wh}]
1666 if {$newtop < $wtop + $linespc} {
1667 set newtop [expr {$wtop + $linespc}]
1671 if {$newtop != $wtop} {
1672 if {$newtop < 0} {
1673 set newtop 0
1675 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1677 set selectedline $l
1679 set id $lineid($l)
1680 set currentid $id
1681 $sha1entry delete 0 end
1682 $sha1entry insert 0 $id
1683 $sha1entry selection from 0
1684 $sha1entry selection to end
1686 $ctext conf -state normal
1687 $ctext delete 0.0 end
1688 $ctext mark set fmark.0 0.0
1689 $ctext mark gravity fmark.0 left
1690 set info $commitinfo($id)
1691 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1692 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1693 if {[info exists idtags($id)]} {
1694 $ctext insert end "Tags:"
1695 foreach tag $idtags($id) {
1696 $ctext insert end " $tag"
1698 $ctext insert end "\n"
1700 $ctext insert end "\n"
1701 $ctext insert end [lindex $info 5]
1702 $ctext insert end "\n"
1703 $ctext tag delete Comments
1704 $ctext tag remove found 1.0 end
1705 $ctext conf -state disabled
1706 set commentend [$ctext index "end - 1c"]
1708 $cflist delete 0 end
1709 $cflist insert end "Comments"
1710 if {$nparents($id) == 1} {
1711 startdiff [concat $id $parents($id)]
1712 } elseif {$nparents($id) > 1} {
1713 mergediff $id
1717 proc selnextline {dir} {
1718 global selectedline
1719 if {![info exists selectedline]} return
1720 set l [expr $selectedline + $dir]
1721 unmarkmatches
1722 selectline $l
1725 proc mergediff {id} {
1726 global parents diffmergeid diffmergegca mergefilelist diffpindex
1728 set diffmergeid $id
1729 set diffpindex -1
1730 set diffmergegca [findgca $parents($id)]
1731 if {[info exists mergefilelist($id)]} {
1732 if {$mergefilelist($id) ne {}} {
1733 showmergediff
1735 } else {
1736 contmergediff {}
1740 proc findgca {ids} {
1741 set gca {}
1742 foreach id $ids {
1743 if {$gca eq {}} {
1744 set gca $id
1745 } else {
1746 if {[catch {
1747 set gca [exec git-merge-base $gca $id]
1748 } err]} {
1749 return {}
1753 return $gca
1756 proc contmergediff {ids} {
1757 global diffmergeid diffpindex parents nparents diffmergegca
1758 global treediffs mergefilelist diffids treepending
1760 # diff the child against each of the parents, and diff
1761 # each of the parents against the GCA.
1762 while 1 {
1763 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
1764 set ids [list [lindex $ids 1] $diffmergegca]
1765 } else {
1766 if {[incr diffpindex] >= $nparents($diffmergeid)} break
1767 set p [lindex $parents($diffmergeid) $diffpindex]
1768 set ids [list $diffmergeid $p]
1770 if {![info exists treediffs($ids)]} {
1771 set diffids $ids
1772 if {![info exists treepending]} {
1773 gettreediffs $ids
1775 return
1779 # If a file in some parent is different from the child and also
1780 # different from the GCA, then it's interesting.
1781 # If we don't have a GCA, then a file is interesting if it is
1782 # different from the child in all the parents.
1783 if {$diffmergegca ne {}} {
1784 set files {}
1785 foreach p $parents($diffmergeid) {
1786 set gcadiffs $treediffs([list $p $diffmergegca])
1787 foreach f $treediffs([list $diffmergeid $p]) {
1788 if {[lsearch -exact $files $f] < 0
1789 && [lsearch -exact $gcadiffs $f] >= 0} {
1790 lappend files $f
1794 set files [lsort $files]
1795 } else {
1796 set p [lindex $parents($diffmergeid) 0]
1797 set files $treediffs([list $diffmergeid $p])
1798 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
1799 set p [lindex $parents($diffmergeid) $i]
1800 set df $treediffs([list $diffmergeid $p])
1801 set nf {}
1802 foreach f $files {
1803 if {[lsearch -exact $df $f] >= 0} {
1804 lappend nf $f
1807 set files $nf
1811 set mergefilelist($diffmergeid) $files
1812 if {$files ne {}} {
1813 showmergediff
1817 proc showmergediff {} {
1818 global cflist diffmergeid mergefilelist parents
1819 global diffopts diffinhunk currentfile currenthunk filelines
1820 global diffblocked groupfilelast mergefds groupfilenum grouphunks
1822 set files $mergefilelist($diffmergeid)
1823 foreach f $files {
1824 $cflist insert end $f
1826 set env(GIT_DIFF_OPTS) $diffopts
1827 set flist {}
1828 catch {unset currentfile}
1829 catch {unset currenthunk}
1830 catch {unset filelines}
1831 catch {unset groupfilenum}
1832 catch {unset grouphunks}
1833 set groupfilelast -1
1834 foreach p $parents($diffmergeid) {
1835 set cmd [list | git-diff-tree -p $p $diffmergeid]
1836 set cmd [concat $cmd $mergefilelist($diffmergeid)]
1837 if {[catch {set f [open $cmd r]} err]} {
1838 error_popup "Error getting diffs: $err"
1839 foreach f $flist {
1840 catch {close $f}
1842 return
1844 lappend flist $f
1845 set ids [list $diffmergeid $p]
1846 set mergefds($ids) $f
1847 set diffinhunk($ids) 0
1848 set diffblocked($ids) 0
1849 fconfigure $f -blocking 0
1850 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
1854 proc getmergediffline {f ids id} {
1855 global diffmergeid diffinhunk diffoldlines diffnewlines
1856 global currentfile currenthunk
1857 global diffoldstart diffnewstart diffoldlno diffnewlno
1858 global diffblocked mergefilelist
1859 global noldlines nnewlines difflcounts filelines
1861 set n [gets $f line]
1862 if {$n < 0} {
1863 if {![eof $f]} return
1866 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
1867 if {$n < 0} {
1868 close $f
1870 return
1873 if {$diffinhunk($ids) != 0} {
1874 set fi $currentfile($ids)
1875 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
1876 # continuing an existing hunk
1877 set line [string range $line 1 end]
1878 set p [lindex $ids 1]
1879 if {$match eq "-" || $match eq " "} {
1880 set filelines($p,$fi,$diffoldlno($ids)) $line
1881 incr diffoldlno($ids)
1883 if {$match eq "+" || $match eq " "} {
1884 set filelines($id,$fi,$diffnewlno($ids)) $line
1885 incr diffnewlno($ids)
1887 if {$match eq " "} {
1888 if {$diffinhunk($ids) == 2} {
1889 lappend difflcounts($ids) \
1890 [list $noldlines($ids) $nnewlines($ids)]
1891 set noldlines($ids) 0
1892 set diffinhunk($ids) 1
1894 incr noldlines($ids)
1895 } elseif {$match eq "-" || $match eq "+"} {
1896 if {$diffinhunk($ids) == 1} {
1897 lappend difflcounts($ids) [list $noldlines($ids)]
1898 set noldlines($ids) 0
1899 set nnewlines($ids) 0
1900 set diffinhunk($ids) 2
1902 if {$match eq "-"} {
1903 incr noldlines($ids)
1904 } else {
1905 incr nnewlines($ids)
1908 # and if it's \ No newline at end of line, then what?
1909 return
1911 # end of a hunk
1912 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
1913 lappend difflcounts($ids) [list $noldlines($ids)]
1914 } elseif {$diffinhunk($ids) == 2
1915 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
1916 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
1918 set currenthunk($ids) [list $currentfile($ids) \
1919 $diffoldstart($ids) $diffnewstart($ids) \
1920 $diffoldlno($ids) $diffnewlno($ids) \
1921 $difflcounts($ids)]
1922 set diffinhunk($ids) 0
1923 # -1 = need to block, 0 = unblocked, 1 = is blocked
1924 set diffblocked($ids) -1
1925 processhunks
1926 if {$diffblocked($ids) == -1} {
1927 fileevent $f readable {}
1928 set diffblocked($ids) 1
1932 if {$n < 0} {
1933 # eof
1934 if {!$diffblocked($ids)} {
1935 close $f
1936 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
1937 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
1938 processhunks
1940 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
1941 # start of a new file
1942 set currentfile($ids) \
1943 [lsearch -exact $mergefilelist($diffmergeid) $fname]
1944 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1945 $line match f1l f1c f2l f2c rest]} {
1946 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
1947 # start of a new hunk
1948 if {$f1l == 0 && $f1c == 0} {
1949 set f1l 1
1951 if {$f2l == 0 && $f2c == 0} {
1952 set f2l 1
1954 set diffinhunk($ids) 1
1955 set diffoldstart($ids) $f1l
1956 set diffnewstart($ids) $f2l
1957 set diffoldlno($ids) $f1l
1958 set diffnewlno($ids) $f2l
1959 set difflcounts($ids) {}
1960 set noldlines($ids) 0
1961 set nnewlines($ids) 0
1966 proc processhunks {} {
1967 global diffmergeid parents nparents currenthunk
1968 global mergefilelist diffblocked mergefds
1969 global grouphunks grouplinestart grouplineend groupfilenum
1971 set nfiles [llength $mergefilelist($diffmergeid)]
1972 while 1 {
1973 set fi $nfiles
1974 set lno 0
1975 # look for the earliest hunk
1976 foreach p $parents($diffmergeid) {
1977 set ids [list $diffmergeid $p]
1978 if {![info exists currenthunk($ids)]} return
1979 set i [lindex $currenthunk($ids) 0]
1980 set l [lindex $currenthunk($ids) 2]
1981 if {$i < $fi || ($i == $fi && $l < $lno)} {
1982 set fi $i
1983 set lno $l
1984 set pi $p
1988 if {$fi < $nfiles} {
1989 set ids [list $diffmergeid $pi]
1990 set hunk $currenthunk($ids)
1991 unset currenthunk($ids)
1992 if {$diffblocked($ids) > 0} {
1993 fileevent $mergefds($ids) readable \
1994 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
1996 set diffblocked($ids) 0
1998 if {[info exists groupfilenum] && $groupfilenum == $fi
1999 && $lno <= $grouplineend} {
2000 # add this hunk to the pending group
2001 lappend grouphunks($pi) $hunk
2002 set endln [lindex $hunk 4]
2003 if {$endln > $grouplineend} {
2004 set grouplineend $endln
2006 continue
2010 # succeeding stuff doesn't belong in this group, so
2011 # process the group now
2012 if {[info exists groupfilenum]} {
2013 processgroup
2014 unset groupfilenum
2015 unset grouphunks
2018 if {$fi >= $nfiles} break
2020 # start a new group
2021 set groupfilenum $fi
2022 set grouphunks($pi) [list $hunk]
2023 set grouplinestart $lno
2024 set grouplineend [lindex $hunk 4]
2028 proc processgroup {} {
2029 global groupfilelast groupfilenum difffilestart
2030 global mergefilelist diffmergeid ctext filelines
2031 global parents diffmergeid diffoffset
2032 global grouphunks grouplinestart grouplineend nparents
2033 global mergemax
2035 $ctext conf -state normal
2036 set id $diffmergeid
2037 set f $groupfilenum
2038 if {$groupfilelast != $f} {
2039 $ctext insert end "\n"
2040 set here [$ctext index "end - 1c"]
2041 set difffilestart($f) $here
2042 set mark fmark.[expr {$f + 1}]
2043 $ctext mark set $mark $here
2044 $ctext mark gravity $mark left
2045 set header [lindex $mergefilelist($id) $f]
2046 set l [expr {(78 - [string length $header]) / 2}]
2047 set pad [string range "----------------------------------------" 1 $l]
2048 $ctext insert end "$pad $header $pad\n" filesep
2049 set groupfilelast $f
2050 foreach p $parents($id) {
2051 set diffoffset($p) 0
2055 $ctext insert end "@@" msep
2056 set nlines [expr {$grouplineend - $grouplinestart}]
2057 set events {}
2058 set pnum 0
2059 foreach p $parents($id) {
2060 set startline [expr {$grouplinestart + $diffoffset($p)}]
2061 set ol $startline
2062 set nl $grouplinestart
2063 if {[info exists grouphunks($p)]} {
2064 foreach h $grouphunks($p) {
2065 set l [lindex $h 2]
2066 if {$nl < $l} {
2067 for {} {$nl < $l} {incr nl} {
2068 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2069 incr ol
2072 foreach chunk [lindex $h 5] {
2073 if {[llength $chunk] == 2} {
2074 set olc [lindex $chunk 0]
2075 set nlc [lindex $chunk 1]
2076 set nnl [expr {$nl + $nlc}]
2077 lappend events [list $nl $nnl $pnum $olc $nlc]
2078 incr ol $olc
2079 set nl $nnl
2080 } else {
2081 incr ol [lindex $chunk 0]
2082 incr nl [lindex $chunk 0]
2087 if {$nl < $grouplineend} {
2088 for {} {$nl < $grouplineend} {incr nl} {
2089 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2090 incr ol
2093 set nlines [expr {$ol - $startline}]
2094 $ctext insert end " -$startline,$nlines" msep
2095 incr pnum
2098 set nlines [expr {$grouplineend - $grouplinestart}]
2099 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2101 set events [lsort -integer -index 0 $events]
2102 set nevents [llength $events]
2103 set nmerge $nparents($diffmergeid)
2104 set l $grouplinestart
2105 for {set i 0} {$i < $nevents} {set i $j} {
2106 set nl [lindex $events $i 0]
2107 while {$l < $nl} {
2108 $ctext insert end " $filelines($id,$f,$l)\n"
2109 incr l
2111 set e [lindex $events $i]
2112 set enl [lindex $e 1]
2113 set j $i
2114 set active {}
2115 while 1 {
2116 set pnum [lindex $e 2]
2117 set olc [lindex $e 3]
2118 set nlc [lindex $e 4]
2119 if {![info exists delta($pnum)]} {
2120 set delta($pnum) [expr {$olc - $nlc}]
2121 lappend active $pnum
2122 } else {
2123 incr delta($pnum) [expr {$olc - $nlc}]
2125 if {[incr j] >= $nevents} break
2126 set e [lindex $events $j]
2127 if {[lindex $e 0] >= $enl} break
2128 if {[lindex $e 1] > $enl} {
2129 set enl [lindex $e 1]
2132 set nlc [expr {$enl - $l}]
2133 set ncol mresult
2134 set bestpn -1
2135 if {[llength $active] == $nmerge - 1} {
2136 # no diff for one of the parents, i.e. it's identical
2137 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2138 if {![info exists delta($pnum)]} {
2139 if {$pnum < $mergemax} {
2140 lappend ncol m$pnum
2141 } else {
2142 lappend ncol mmax
2144 break
2147 } elseif {[llength $active] == $nmerge} {
2148 # all parents are different, see if one is very similar
2149 set bestsim 30
2150 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2151 set sim [similarity $pnum $l $nlc $f \
2152 [lrange $events $i [expr {$j-1}]]]
2153 if {$sim > $bestsim} {
2154 set bestsim $sim
2155 set bestpn $pnum
2158 if {$bestpn >= 0} {
2159 lappend ncol m$bestpn
2162 set pnum -1
2163 foreach p $parents($id) {
2164 incr pnum
2165 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2166 set olc [expr {$nlc + $delta($pnum)}]
2167 set ol [expr {$l + $diffoffset($p)}]
2168 incr diffoffset($p) $delta($pnum)
2169 unset delta($pnum)
2170 for {} {$olc > 0} {incr olc -1} {
2171 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2172 incr ol
2175 set endl [expr {$l + $nlc}]
2176 if {$bestpn >= 0} {
2177 # show this pretty much as a normal diff
2178 set p [lindex $parents($id) $bestpn]
2179 set ol [expr {$l + $diffoffset($p)}]
2180 incr diffoffset($p) $delta($bestpn)
2181 unset delta($bestpn)
2182 for {set k $i} {$k < $j} {incr k} {
2183 set e [lindex $events $k]
2184 if {[lindex $e 2] != $bestpn} continue
2185 set nl [lindex $e 0]
2186 set ol [expr {$ol + $nl - $l}]
2187 for {} {$l < $nl} {incr l} {
2188 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2190 set c [lindex $e 3]
2191 for {} {$c > 0} {incr c -1} {
2192 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2193 incr ol
2195 set nl [lindex $e 1]
2196 for {} {$l < $nl} {incr l} {
2197 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2201 for {} {$l < $endl} {incr l} {
2202 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2205 while {$l < $grouplineend} {
2206 $ctext insert end " $filelines($id,$f,$l)\n"
2207 incr l
2209 $ctext conf -state disabled
2212 proc similarity {pnum l nlc f events} {
2213 global diffmergeid parents diffoffset filelines
2215 set id $diffmergeid
2216 set p [lindex $parents($id) $pnum]
2217 set ol [expr {$l + $diffoffset($p)}]
2218 set endl [expr {$l + $nlc}]
2219 set same 0
2220 set diff 0
2221 foreach e $events {
2222 if {[lindex $e 2] != $pnum} continue
2223 set nl [lindex $e 0]
2224 set ol [expr {$ol + $nl - $l}]
2225 for {} {$l < $nl} {incr l} {
2226 incr same [string length $filelines($id,$f,$l)]
2227 incr same
2229 set oc [lindex $e 3]
2230 for {} {$oc > 0} {incr oc -1} {
2231 incr diff [string length $filelines($p,$f,$ol)]
2232 incr diff
2233 incr ol
2235 set nl [lindex $e 1]
2236 for {} {$l < $nl} {incr l} {
2237 incr diff [string length $filelines($id,$f,$l)]
2238 incr diff
2241 for {} {$l < $endl} {incr l} {
2242 incr same [string length $filelines($id,$f,$l)]
2243 incr same
2245 if {$same == 0} {
2246 return 0
2248 return [expr {200 * $same / (2 * $same + $diff)}]
2251 proc startdiff {ids} {
2252 global treediffs diffids treepending diffmergeid
2254 set diffids $ids
2255 catch {unset diffmergeid}
2256 if {![info exists treediffs($ids)]} {
2257 if {![info exists treepending]} {
2258 gettreediffs $ids
2260 } else {
2261 addtocflist $ids
2265 proc addtocflist {ids} {
2266 global treediffs cflist
2267 foreach f $treediffs($ids) {
2268 $cflist insert end $f
2270 getblobdiffs $ids
2273 proc gettreediffs {ids} {
2274 global treediff parents treepending
2275 set treepending $ids
2276 set treediff {}
2277 set id [lindex $ids 0]
2278 set p [lindex $ids 1]
2279 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2280 fconfigure $gdtf -blocking 0
2281 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2284 proc gettreediffline {gdtf ids} {
2285 global treediff treediffs treepending diffids diffmergeid
2287 set n [gets $gdtf line]
2288 if {$n < 0} {
2289 if {![eof $gdtf]} return
2290 close $gdtf
2291 set treediffs($ids) $treediff
2292 unset treepending
2293 if {$ids != $diffids} {
2294 gettreediffs $diffids
2295 } else {
2296 if {[info exists diffmergeid]} {
2297 contmergediff $ids
2298 } else {
2299 addtocflist $ids
2302 return
2304 set file [lindex $line 5]
2305 lappend treediff $file
2308 proc getblobdiffs {ids} {
2309 global diffopts blobdifffd diffids env curdifftag curtagstart
2310 global difffilestart nextupdate diffinhdr treediffs
2312 set id [lindex $ids 0]
2313 set p [lindex $ids 1]
2314 set env(GIT_DIFF_OPTS) $diffopts
2315 set cmd [list | git-diff-tree -r -p -C $p $id]
2316 if {[catch {set bdf [open $cmd r]} err]} {
2317 puts "error getting diffs: $err"
2318 return
2320 set diffinhdr 0
2321 fconfigure $bdf -blocking 0
2322 set blobdifffd($ids) $bdf
2323 set curdifftag Comments
2324 set curtagstart 0.0
2325 catch {unset difffilestart}
2326 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2327 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2330 proc getblobdiffline {bdf ids} {
2331 global diffids blobdifffd ctext curdifftag curtagstart
2332 global diffnexthead diffnextnote difffilestart
2333 global nextupdate diffinhdr treediffs
2334 global gaudydiff
2336 set n [gets $bdf line]
2337 if {$n < 0} {
2338 if {[eof $bdf]} {
2339 close $bdf
2340 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2341 $ctext tag add $curdifftag $curtagstart end
2344 return
2346 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2347 return
2349 $ctext conf -state normal
2350 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2351 # start of a new file
2352 $ctext insert end "\n"
2353 $ctext tag add $curdifftag $curtagstart end
2354 set curtagstart [$ctext index "end - 1c"]
2355 set header $newname
2356 set here [$ctext index "end - 1c"]
2357 set i [lsearch -exact $treediffs($diffids) $fname]
2358 if {$i >= 0} {
2359 set difffilestart($i) $here
2360 incr i
2361 $ctext mark set fmark.$i $here
2362 $ctext mark gravity fmark.$i left
2364 if {$newname != $fname} {
2365 set i [lsearch -exact $treediffs($diffids) $newname]
2366 if {$i >= 0} {
2367 set difffilestart($i) $here
2368 incr i
2369 $ctext mark set fmark.$i $here
2370 $ctext mark gravity fmark.$i left
2373 set curdifftag "f:$fname"
2374 $ctext tag delete $curdifftag
2375 set l [expr {(78 - [string length $header]) / 2}]
2376 set pad [string range "----------------------------------------" 1 $l]
2377 $ctext insert end "$pad $header $pad\n" filesep
2378 set diffinhdr 1
2379 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2380 set diffinhdr 0
2381 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2382 $line match f1l f1c f2l f2c rest]} {
2383 if {$gaudydiff} {
2384 $ctext insert end "\t" hunksep
2385 $ctext insert end " $f1l " d0 " $f2l " d1
2386 $ctext insert end " $rest \n" hunksep
2387 } else {
2388 $ctext insert end "$line\n" hunksep
2390 set diffinhdr 0
2391 } else {
2392 set x [string range $line 0 0]
2393 if {$x == "-" || $x == "+"} {
2394 set tag [expr {$x == "+"}]
2395 if {$gaudydiff} {
2396 set line [string range $line 1 end]
2398 $ctext insert end "$line\n" d$tag
2399 } elseif {$x == " "} {
2400 if {$gaudydiff} {
2401 set line [string range $line 1 end]
2403 $ctext insert end "$line\n"
2404 } elseif {$diffinhdr || $x == "\\"} {
2405 # e.g. "\ No newline at end of file"
2406 $ctext insert end "$line\n" filesep
2407 } else {
2408 # Something else we don't recognize
2409 if {$curdifftag != "Comments"} {
2410 $ctext insert end "\n"
2411 $ctext tag add $curdifftag $curtagstart end
2412 set curtagstart [$ctext index "end - 1c"]
2413 set curdifftag Comments
2415 $ctext insert end "$line\n" filesep
2418 $ctext conf -state disabled
2419 if {[clock clicks -milliseconds] >= $nextupdate} {
2420 incr nextupdate 100
2421 fileevent $bdf readable {}
2422 update
2423 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2427 proc nextfile {} {
2428 global difffilestart ctext
2429 set here [$ctext index @0,0]
2430 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2431 if {[$ctext compare $difffilestart($i) > $here]} {
2432 if {![info exists pos]
2433 || [$ctext compare $difffilestart($i) < $pos]} {
2434 set pos $difffilestart($i)
2438 if {[info exists pos]} {
2439 $ctext yview $pos
2443 proc listboxsel {} {
2444 global ctext cflist currentid
2445 if {![info exists currentid]} return
2446 set sel [lsort [$cflist curselection]]
2447 if {$sel eq {}} return
2448 set first [lindex $sel 0]
2449 catch {$ctext yview fmark.$first}
2452 proc setcoords {} {
2453 global linespc charspc canvx0 canvy0 mainfont
2454 set linespc [font metrics $mainfont -linespace]
2455 set charspc [font measure $mainfont "m"]
2456 set canvy0 [expr 3 + 0.5 * $linespc]
2457 set canvx0 [expr 3 + 0.5 * $linespc]
2460 proc redisplay {} {
2461 global selectedline stopped redisplaying phase
2462 if {$stopped > 1} return
2463 if {$phase == "getcommits"} return
2464 set redisplaying 1
2465 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2466 set stopped 1
2467 } else {
2468 drawgraph
2472 proc incrfont {inc} {
2473 global mainfont namefont textfont selectedline ctext canv phase
2474 global stopped entries
2475 unmarkmatches
2476 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2477 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2478 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2479 setcoords
2480 $ctext conf -font $textfont
2481 $ctext tag conf filesep -font [concat $textfont bold]
2482 foreach e $entries {
2483 $e conf -font $mainfont
2485 if {$phase == "getcommits"} {
2486 $canv itemconf textitems -font $mainfont
2488 redisplay
2491 proc clearsha1 {} {
2492 global sha1entry sha1string
2493 if {[string length $sha1string] == 40} {
2494 $sha1entry delete 0 end
2498 proc sha1change {n1 n2 op} {
2499 global sha1string currentid sha1but
2500 if {$sha1string == {}
2501 || ([info exists currentid] && $sha1string == $currentid)} {
2502 set state disabled
2503 } else {
2504 set state normal
2506 if {[$sha1but cget -state] == $state} return
2507 if {$state == "normal"} {
2508 $sha1but conf -state normal -relief raised -text "Goto: "
2509 } else {
2510 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2514 proc gotocommit {} {
2515 global sha1string currentid idline tagids
2516 global lineid numcommits
2518 if {$sha1string == {}
2519 || ([info exists currentid] && $sha1string == $currentid)} return
2520 if {[info exists tagids($sha1string)]} {
2521 set id $tagids($sha1string)
2522 } else {
2523 set id [string tolower $sha1string]
2524 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2525 set matches {}
2526 for {set l 0} {$l < $numcommits} {incr l} {
2527 if {[string match $id* $lineid($l)]} {
2528 lappend matches $lineid($l)
2531 if {$matches ne {}} {
2532 if {[llength $matches] > 1} {
2533 error_popup "Short SHA1 id $id is ambiguous"
2534 return
2536 set id [lindex $matches 0]
2540 if {[info exists idline($id)]} {
2541 selectline $idline($id)
2542 return
2544 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2545 set type "SHA1 id"
2546 } else {
2547 set type "Tag"
2549 error_popup "$type $sha1string is not known"
2552 proc lineenter {x y id} {
2553 global hoverx hovery hoverid hovertimer
2554 global commitinfo canv
2556 if {![info exists commitinfo($id)]} return
2557 set hoverx $x
2558 set hovery $y
2559 set hoverid $id
2560 if {[info exists hovertimer]} {
2561 after cancel $hovertimer
2563 set hovertimer [after 500 linehover]
2564 $canv delete hover
2567 proc linemotion {x y id} {
2568 global hoverx hovery hoverid hovertimer
2570 if {[info exists hoverid] && $id == $hoverid} {
2571 set hoverx $x
2572 set hovery $y
2573 if {[info exists hovertimer]} {
2574 after cancel $hovertimer
2576 set hovertimer [after 500 linehover]
2580 proc lineleave {id} {
2581 global hoverid hovertimer canv
2583 if {[info exists hoverid] && $id == $hoverid} {
2584 $canv delete hover
2585 if {[info exists hovertimer]} {
2586 after cancel $hovertimer
2587 unset hovertimer
2589 unset hoverid
2593 proc linehover {} {
2594 global hoverx hovery hoverid hovertimer
2595 global canv linespc lthickness
2596 global commitinfo mainfont
2598 set text [lindex $commitinfo($hoverid) 0]
2599 set ymax [lindex [$canv cget -scrollregion] 3]
2600 if {$ymax == {}} return
2601 set yfrac [lindex [$canv yview] 0]
2602 set x [expr {$hoverx + 2 * $linespc}]
2603 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2604 set x0 [expr {$x - 2 * $lthickness}]
2605 set y0 [expr {$y - 2 * $lthickness}]
2606 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2607 set y1 [expr {$y + $linespc + 2 * $lthickness}]
2608 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2609 -fill \#ffff80 -outline black -width 1 -tags hover]
2610 $canv raise $t
2611 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2612 $canv raise $t
2615 proc lineclick {x y id} {
2616 global ctext commitinfo children cflist canv
2618 unmarkmatches
2619 $canv delete hover
2620 # fill the details pane with info about this line
2621 $ctext conf -state normal
2622 $ctext delete 0.0 end
2623 $ctext insert end "Parent:\n "
2624 catch {destroy $ctext.$id}
2625 button $ctext.$id -text "Go:" -command "selbyid $id" \
2626 -padx 4 -pady 0
2627 $ctext window create end -window $ctext.$id -align center
2628 set info $commitinfo($id)
2629 $ctext insert end "\t[lindex $info 0]\n"
2630 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2631 $ctext insert end "\tDate:\t[lindex $info 2]\n"
2632 $ctext insert end "\tID:\t$id\n"
2633 if {[info exists children($id)]} {
2634 $ctext insert end "\nChildren:"
2635 foreach child $children($id) {
2636 $ctext insert end "\n "
2637 catch {destroy $ctext.$child}
2638 button $ctext.$child -text "Go:" -command "selbyid $child" \
2639 -padx 4 -pady 0
2640 $ctext window create end -window $ctext.$child -align center
2641 set info $commitinfo($child)
2642 $ctext insert end "\t[lindex $info 0]"
2645 $ctext conf -state disabled
2647 $cflist delete 0 end
2650 proc selbyid {id} {
2651 global idline
2652 if {[info exists idline($id)]} {
2653 selectline $idline($id)
2657 proc mstime {} {
2658 global startmstime
2659 if {![info exists startmstime]} {
2660 set startmstime [clock clicks -milliseconds]
2662 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2665 proc rowmenu {x y id} {
2666 global rowctxmenu idline selectedline rowmenuid
2668 if {![info exists selectedline] || $idline($id) eq $selectedline} {
2669 set state disabled
2670 } else {
2671 set state normal
2673 $rowctxmenu entryconfigure 0 -state $state
2674 $rowctxmenu entryconfigure 1 -state $state
2675 $rowctxmenu entryconfigure 2 -state $state
2676 set rowmenuid $id
2677 tk_popup $rowctxmenu $x $y
2680 proc diffvssel {dirn} {
2681 global rowmenuid selectedline lineid
2682 global ctext cflist
2683 global commitinfo
2685 if {![info exists selectedline]} return
2686 if {$dirn} {
2687 set oldid $lineid($selectedline)
2688 set newid $rowmenuid
2689 } else {
2690 set oldid $rowmenuid
2691 set newid $lineid($selectedline)
2693 $ctext conf -state normal
2694 $ctext delete 0.0 end
2695 $ctext mark set fmark.0 0.0
2696 $ctext mark gravity fmark.0 left
2697 $cflist delete 0 end
2698 $cflist insert end "Top"
2699 $ctext insert end "From $oldid\n "
2700 $ctext insert end [lindex $commitinfo($oldid) 0]
2701 $ctext insert end "\n\nTo $newid\n "
2702 $ctext insert end [lindex $commitinfo($newid) 0]
2703 $ctext insert end "\n"
2704 $ctext conf -state disabled
2705 $ctext tag delete Comments
2706 $ctext tag remove found 1.0 end
2707 startdiff [list $newid $oldid]
2710 proc mkpatch {} {
2711 global rowmenuid currentid commitinfo patchtop patchnum
2713 if {![info exists currentid]} return
2714 set oldid $currentid
2715 set oldhead [lindex $commitinfo($oldid) 0]
2716 set newid $rowmenuid
2717 set newhead [lindex $commitinfo($newid) 0]
2718 set top .patch
2719 set patchtop $top
2720 catch {destroy $top}
2721 toplevel $top
2722 label $top.title -text "Generate patch"
2723 grid $top.title - -pady 10
2724 label $top.from -text "From:"
2725 entry $top.fromsha1 -width 40 -relief flat
2726 $top.fromsha1 insert 0 $oldid
2727 $top.fromsha1 conf -state readonly
2728 grid $top.from $top.fromsha1 -sticky w
2729 entry $top.fromhead -width 60 -relief flat
2730 $top.fromhead insert 0 $oldhead
2731 $top.fromhead conf -state readonly
2732 grid x $top.fromhead -sticky w
2733 label $top.to -text "To:"
2734 entry $top.tosha1 -width 40 -relief flat
2735 $top.tosha1 insert 0 $newid
2736 $top.tosha1 conf -state readonly
2737 grid $top.to $top.tosha1 -sticky w
2738 entry $top.tohead -width 60 -relief flat
2739 $top.tohead insert 0 $newhead
2740 $top.tohead conf -state readonly
2741 grid x $top.tohead -sticky w
2742 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2743 grid $top.rev x -pady 10
2744 label $top.flab -text "Output file:"
2745 entry $top.fname -width 60
2746 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2747 incr patchnum
2748 grid $top.flab $top.fname -sticky w
2749 frame $top.buts
2750 button $top.buts.gen -text "Generate" -command mkpatchgo
2751 button $top.buts.can -text "Cancel" -command mkpatchcan
2752 grid $top.buts.gen $top.buts.can
2753 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2754 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2755 grid $top.buts - -pady 10 -sticky ew
2756 focus $top.fname
2759 proc mkpatchrev {} {
2760 global patchtop
2762 set oldid [$patchtop.fromsha1 get]
2763 set oldhead [$patchtop.fromhead get]
2764 set newid [$patchtop.tosha1 get]
2765 set newhead [$patchtop.tohead get]
2766 foreach e [list fromsha1 fromhead tosha1 tohead] \
2767 v [list $newid $newhead $oldid $oldhead] {
2768 $patchtop.$e conf -state normal
2769 $patchtop.$e delete 0 end
2770 $patchtop.$e insert 0 $v
2771 $patchtop.$e conf -state readonly
2775 proc mkpatchgo {} {
2776 global patchtop
2778 set oldid [$patchtop.fromsha1 get]
2779 set newid [$patchtop.tosha1 get]
2780 set fname [$patchtop.fname get]
2781 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2782 error_popup "Error creating patch: $err"
2784 catch {destroy $patchtop}
2785 unset patchtop
2788 proc mkpatchcan {} {
2789 global patchtop
2791 catch {destroy $patchtop}
2792 unset patchtop
2795 proc mktag {} {
2796 global rowmenuid mktagtop commitinfo
2798 set top .maketag
2799 set mktagtop $top
2800 catch {destroy $top}
2801 toplevel $top
2802 label $top.title -text "Create tag"
2803 grid $top.title - -pady 10
2804 label $top.id -text "ID:"
2805 entry $top.sha1 -width 40 -relief flat
2806 $top.sha1 insert 0 $rowmenuid
2807 $top.sha1 conf -state readonly
2808 grid $top.id $top.sha1 -sticky w
2809 entry $top.head -width 60 -relief flat
2810 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2811 $top.head conf -state readonly
2812 grid x $top.head -sticky w
2813 label $top.tlab -text "Tag name:"
2814 entry $top.tag -width 60
2815 grid $top.tlab $top.tag -sticky w
2816 frame $top.buts
2817 button $top.buts.gen -text "Create" -command mktaggo
2818 button $top.buts.can -text "Cancel" -command mktagcan
2819 grid $top.buts.gen $top.buts.can
2820 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2821 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2822 grid $top.buts - -pady 10 -sticky ew
2823 focus $top.tag
2826 proc domktag {} {
2827 global mktagtop env tagids idtags
2828 global idpos idline linehtag canv selectedline
2830 set id [$mktagtop.sha1 get]
2831 set tag [$mktagtop.tag get]
2832 if {$tag == {}} {
2833 error_popup "No tag name specified"
2834 return
2836 if {[info exists tagids($tag)]} {
2837 error_popup "Tag \"$tag\" already exists"
2838 return
2840 if {[catch {
2841 set dir [gitdir]
2842 set fname [file join $dir "refs/tags" $tag]
2843 set f [open $fname w]
2844 puts $f $id
2845 close $f
2846 } err]} {
2847 error_popup "Error creating tag: $err"
2848 return
2851 set tagids($tag) $id
2852 lappend idtags($id) $tag
2853 $canv delete tag.$id
2854 set xt [eval drawtags $id $idpos($id)]
2855 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2856 if {[info exists selectedline] && $selectedline == $idline($id)} {
2857 selectline $selectedline
2861 proc mktagcan {} {
2862 global mktagtop
2864 catch {destroy $mktagtop}
2865 unset mktagtop
2868 proc mktaggo {} {
2869 domktag
2870 mktagcan
2873 proc writecommit {} {
2874 global rowmenuid wrcomtop commitinfo wrcomcmd
2876 set top .writecommit
2877 set wrcomtop $top
2878 catch {destroy $top}
2879 toplevel $top
2880 label $top.title -text "Write commit to file"
2881 grid $top.title - -pady 10
2882 label $top.id -text "ID:"
2883 entry $top.sha1 -width 40 -relief flat
2884 $top.sha1 insert 0 $rowmenuid
2885 $top.sha1 conf -state readonly
2886 grid $top.id $top.sha1 -sticky w
2887 entry $top.head -width 60 -relief flat
2888 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2889 $top.head conf -state readonly
2890 grid x $top.head -sticky w
2891 label $top.clab -text "Command:"
2892 entry $top.cmd -width 60 -textvariable wrcomcmd
2893 grid $top.clab $top.cmd -sticky w -pady 10
2894 label $top.flab -text "Output file:"
2895 entry $top.fname -width 60
2896 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2897 grid $top.flab $top.fname -sticky w
2898 frame $top.buts
2899 button $top.buts.gen -text "Write" -command wrcomgo
2900 button $top.buts.can -text "Cancel" -command wrcomcan
2901 grid $top.buts.gen $top.buts.can
2902 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2903 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2904 grid $top.buts - -pady 10 -sticky ew
2905 focus $top.fname
2908 proc wrcomgo {} {
2909 global wrcomtop
2911 set id [$wrcomtop.sha1 get]
2912 set cmd "echo $id | [$wrcomtop.cmd get]"
2913 set fname [$wrcomtop.fname get]
2914 if {[catch {exec sh -c $cmd >$fname &} err]} {
2915 error_popup "Error writing commit: $err"
2917 catch {destroy $wrcomtop}
2918 unset wrcomtop
2921 proc wrcomcan {} {
2922 global wrcomtop
2924 catch {destroy $wrcomtop}
2925 unset wrcomtop
2928 proc doquit {} {
2929 global stopped
2930 set stopped 100
2931 destroy .
2934 # defaults...
2935 set datemode 0
2936 set boldnames 0
2937 set diffopts "-U 5 -p"
2938 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2940 set mainfont {Helvetica 9}
2941 set textfont {Courier 9}
2942 set findmergefiles 0
2943 set gaudydiff 0
2945 set colors {green red blue magenta darkgrey brown orange}
2947 catch {source ~/.gitk}
2949 set namefont $mainfont
2950 if {$boldnames} {
2951 lappend namefont bold
2954 set revtreeargs {}
2955 foreach arg $argv {
2956 switch -regexp -- $arg {
2957 "^$" { }
2958 "^-b" { set boldnames 1 }
2959 "^-d" { set datemode 1 }
2960 default {
2961 lappend revtreeargs $arg
2966 set stopped 0
2967 set redisplaying 0
2968 set stuffsaved 0
2969 set patchnum 0
2970 setcoords
2971 makewindow
2972 readrefs
2973 getcommits $revtreeargs