git-branch -d <branch>: delete unused branch.
[git/gitweb.git] / gitk
blobdf86dceba0c097a6e2b1be9bf296ce3de014808e
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 ncmupdate
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 set ncmupdate 1
35 if [catch {
36 set parse_args [concat --default HEAD $rargs]
37 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
38 }] {
39 # if git-rev-parse failed for some reason...
40 if {$rargs == {}} {
41 set rargs HEAD
43 set parsed_args $rargs
45 if [catch {
46 set commfd [open "|git-rev-list --header --topo-order --parents $parsed_args" r]
47 } err] {
48 puts stderr "Error executing git-rev-list: $err"
49 exit 1
51 set leftover {}
52 fconfigure $commfd -blocking 0 -translation lf
53 fileevent $commfd readable [list getcommitlines $commfd]
54 $canv delete all
55 $canv create text 3 3 -anchor nw -text "Reading commits..." \
56 -font $mainfont -tags textitems
57 . config -cursor watch
58 settextcursor watch
61 proc getcommitlines {commfd} {
62 global commits parents cdate children
63 global commitlisted phase commitinfo nextupdate
64 global stopped redisplaying leftover
66 set stuff [read $commfd]
67 if {$stuff == {}} {
68 if {![eof $commfd]} return
69 # set it blocking so we wait for the process to terminate
70 fconfigure $commfd -blocking 1
71 if {![catch {close $commfd} err]} {
72 after idle finishcommits
73 return
75 if {[string range $err 0 4] == "usage"} {
76 set err \
77 {Gitk: error reading commits: bad arguments to git-rev-list.
78 (Note: arguments to gitk are passed to git-rev-list
79 to allow selection of commits to be displayed.)}
80 } else {
81 set err "Error reading commits: $err"
83 error_popup $err
84 exit 1
86 set start 0
87 while 1 {
88 set i [string first "\0" $stuff $start]
89 if {$i < 0} {
90 append leftover [string range $stuff $start end]
91 return
93 set cmit [string range $stuff $start [expr {$i - 1}]]
94 if {$start == 0} {
95 set cmit "$leftover$cmit"
96 set leftover {}
98 set start [expr {$i + 1}]
99 set j [string first "\n" $cmit]
100 set ok 0
101 if {$j >= 0} {
102 set ids [string range $cmit 0 [expr {$j - 1}]]
103 set ok 1
104 foreach id $ids {
105 if {![regexp {^[0-9a-f]{40}$} $id]} {
106 set ok 0
107 break
111 if {!$ok} {
112 set shortcmit $cmit
113 if {[string length $shortcmit] > 80} {
114 set shortcmit "[string range $shortcmit 0 80]..."
116 error_popup "Can't parse git-rev-list output: {$shortcmit}"
117 exit 1
119 set id [lindex $ids 0]
120 set olds [lrange $ids 1 end]
121 set cmit [string range $cmit [expr {$j + 1}] end]
122 lappend commits $id
123 set commitlisted($id) 1
124 parsecommit $id $cmit 1 [lrange $ids 1 end]
125 drawcommit $id
126 if {[clock clicks -milliseconds] >= $nextupdate} {
127 doupdate 1
129 while {$redisplaying} {
130 set redisplaying 0
131 if {$stopped == 1} {
132 set stopped 0
133 set phase "getcommits"
134 foreach id $commits {
135 drawcommit $id
136 if {$stopped} break
137 if {[clock clicks -milliseconds] >= $nextupdate} {
138 doupdate 1
146 proc doupdate {reading} {
147 global commfd nextupdate numcommits ncmupdate
149 if {$reading} {
150 fileevent $commfd readable {}
152 update
153 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
154 if {$numcommits < 100} {
155 set ncmupdate [expr {$numcommits + 1}]
156 } elseif {$numcommits < 10000} {
157 set ncmupdate [expr {$numcommits + 10}]
158 } else {
159 set ncmupdate [expr {$numcommits + 100}]
161 if {$reading} {
162 fileevent $commfd readable [list getcommitlines $commfd]
166 proc readcommit {id} {
167 if [catch {set contents [exec git-cat-file commit $id]}] return
168 parsecommit $id $contents 0 {}
171 proc parsecommit {id contents listed olds} {
172 global commitinfo children nchildren parents nparents cdate ncleft
174 set inhdr 1
175 set comment {}
176 set headline {}
177 set auname {}
178 set audate {}
179 set comname {}
180 set comdate {}
181 if {![info exists nchildren($id)]} {
182 set children($id) {}
183 set nchildren($id) 0
184 set ncleft($id) 0
186 set parents($id) $olds
187 set nparents($id) [llength $olds]
188 foreach p $olds {
189 if {![info exists nchildren($p)]} {
190 set children($p) [list $id]
191 set nchildren($p) 1
192 set ncleft($p) 1
193 } elseif {[lsearch -exact $children($p) $id] < 0} {
194 lappend children($p) $id
195 incr nchildren($p)
196 incr ncleft($p)
199 foreach line [split $contents "\n"] {
200 if {$inhdr} {
201 if {$line == {}} {
202 set inhdr 0
203 } else {
204 set tag [lindex $line 0]
205 if {$tag == "author"} {
206 set x [expr {[llength $line] - 2}]
207 set audate [lindex $line $x]
208 set auname [lrange $line 1 [expr {$x - 1}]]
209 } elseif {$tag == "committer"} {
210 set x [expr {[llength $line] - 2}]
211 set comdate [lindex $line $x]
212 set comname [lrange $line 1 [expr {$x - 1}]]
215 } else {
216 if {$comment == {}} {
217 set headline [string trim $line]
218 } else {
219 append comment "\n"
221 if {!$listed} {
222 # git-rev-list indents the comment by 4 spaces;
223 # if we got this via git-cat-file, add the indentation
224 append comment " "
226 append comment $line
229 if {$audate != {}} {
230 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
232 if {$comdate != {}} {
233 set cdate($id) $comdate
234 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
236 set commitinfo($id) [list $headline $auname $audate \
237 $comname $comdate $comment]
240 proc readrefs {} {
241 global tagids idtags headids idheads tagcontents
243 set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
244 foreach f $tags {
245 catch {
246 set fd [open $f r]
247 set line [read $fd]
248 if {[regexp {^[0-9a-f]{40}} $line id]} {
249 set direct [file tail $f]
250 set tagids($direct) $id
251 lappend idtags($id) $direct
252 set tagblob [exec git-cat-file tag $id]
253 set contents [split $tagblob "\n"]
254 set obj {}
255 set type {}
256 set tag {}
257 foreach l $contents {
258 if {$l == {}} break
259 switch -- [lindex $l 0] {
260 "object" {set obj [lindex $l 1]}
261 "type" {set type [lindex $l 1]}
262 "tag" {set tag [string range $l 4 end]}
265 if {$obj != {} && $type == "commit" && $tag != {}} {
266 set tagids($tag) $obj
267 lappend idtags($obj) $tag
268 set tagcontents($tag) $tagblob
271 close $fd
274 set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
275 foreach f $heads {
276 catch {
277 set fd [open $f r]
278 set line [read $fd 40]
279 if {[regexp {^[0-9a-f]{40}} $line id]} {
280 set head [file tail $f]
281 set headids($head) $line
282 lappend idheads($line) $head
284 close $fd
287 readotherrefs refs {} {tags heads}
290 proc readotherrefs {base dname excl} {
291 global otherrefids idotherrefs
293 set git [gitdir]
294 set files [glob -nocomplain -types f [file join $git $base *]]
295 foreach f $files {
296 catch {
297 set fd [open $f r]
298 set line [read $fd 40]
299 if {[regexp {^[0-9a-f]{40}} $line id]} {
300 set name "$dname[file tail $f]"
301 set otherrefids($name) $id
302 lappend idotherrefs($id) $name
304 close $fd
307 set dirs [glob -nocomplain -types d [file join $git $base *]]
308 foreach d $dirs {
309 set dir [file tail $d]
310 if {[lsearch -exact $excl $dir] >= 0} continue
311 readotherrefs [file join $base $dir] "$dname$dir/" {}
315 proc error_popup msg {
316 set w .error
317 toplevel $w
318 wm transient $w .
319 message $w.m -text $msg -justify center -aspect 400
320 pack $w.m -side top -fill x -padx 20 -pady 20
321 button $w.ok -text OK -command "destroy $w"
322 pack $w.ok -side bottom -fill x
323 bind $w <Visibility> "grab $w; focus $w"
324 tkwait window $w
327 proc makewindow {} {
328 global canv canv2 canv3 linespc charspc ctext cflist textfont
329 global findtype findtypemenu findloc findstring fstring geometry
330 global entries sha1entry sha1string sha1but
331 global maincursor textcursor curtextcursor
332 global rowctxmenu gaudydiff mergemax
334 menu .bar
335 .bar add cascade -label "File" -menu .bar.file
336 menu .bar.file
337 .bar.file add command -label "Reread references" -command rereadrefs
338 .bar.file add command -label "Quit" -command doquit
339 menu .bar.help
340 .bar add cascade -label "Help" -menu .bar.help
341 .bar.help add command -label "About gitk" -command about
342 . configure -menu .bar
344 if {![info exists geometry(canv1)]} {
345 set geometry(canv1) [expr 45 * $charspc]
346 set geometry(canv2) [expr 30 * $charspc]
347 set geometry(canv3) [expr 15 * $charspc]
348 set geometry(canvh) [expr 25 * $linespc + 4]
349 set geometry(ctextw) 80
350 set geometry(ctexth) 30
351 set geometry(cflistw) 30
353 panedwindow .ctop -orient vertical
354 if {[info exists geometry(width)]} {
355 .ctop conf -width $geometry(width) -height $geometry(height)
356 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
357 set geometry(ctexth) [expr {($texth - 8) /
358 [font metrics $textfont -linespace]}]
360 frame .ctop.top
361 frame .ctop.top.bar
362 pack .ctop.top.bar -side bottom -fill x
363 set cscroll .ctop.top.csb
364 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
365 pack $cscroll -side right -fill y
366 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
367 pack .ctop.top.clist -side top -fill both -expand 1
368 .ctop add .ctop.top
369 set canv .ctop.top.clist.canv
370 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
371 -bg white -bd 0 \
372 -yscrollincr $linespc -yscrollcommand "$cscroll set"
373 .ctop.top.clist add $canv
374 set canv2 .ctop.top.clist.canv2
375 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
376 -bg white -bd 0 -yscrollincr $linespc
377 .ctop.top.clist add $canv2
378 set canv3 .ctop.top.clist.canv3
379 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
380 -bg white -bd 0 -yscrollincr $linespc
381 .ctop.top.clist add $canv3
382 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
384 set sha1entry .ctop.top.bar.sha1
385 set entries $sha1entry
386 set sha1but .ctop.top.bar.sha1label
387 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
388 -command gotocommit -width 8
389 $sha1but conf -disabledforeground [$sha1but cget -foreground]
390 pack .ctop.top.bar.sha1label -side left
391 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
392 trace add variable sha1string write sha1change
393 pack $sha1entry -side left -pady 2
395 image create bitmap bm-left -data {
396 #define left_width 16
397 #define left_height 16
398 static unsigned char left_bits[] = {
399 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
400 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
401 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
403 image create bitmap bm-right -data {
404 #define right_width 16
405 #define right_height 16
406 static unsigned char right_bits[] = {
407 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
408 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
409 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
411 button .ctop.top.bar.leftbut -image bm-left -command goback \
412 -state disabled -width 26
413 pack .ctop.top.bar.leftbut -side left -fill y
414 button .ctop.top.bar.rightbut -image bm-right -command goforw \
415 -state disabled -width 26
416 pack .ctop.top.bar.rightbut -side left -fill y
418 button .ctop.top.bar.findbut -text "Find" -command dofind
419 pack .ctop.top.bar.findbut -side left
420 set findstring {}
421 set fstring .ctop.top.bar.findstring
422 lappend entries $fstring
423 entry $fstring -width 30 -font $textfont -textvariable findstring
424 pack $fstring -side left -expand 1 -fill x
425 set findtype Exact
426 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
427 findtype Exact IgnCase Regexp]
428 set findloc "All fields"
429 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
430 Comments Author Committer Files Pickaxe
431 pack .ctop.top.bar.findloc -side right
432 pack .ctop.top.bar.findtype -side right
433 # for making sure type==Exact whenever loc==Pickaxe
434 trace add variable findloc write findlocchange
436 panedwindow .ctop.cdet -orient horizontal
437 .ctop add .ctop.cdet
438 frame .ctop.cdet.left
439 set ctext .ctop.cdet.left.ctext
440 text $ctext -bg white -state disabled -font $textfont \
441 -width $geometry(ctextw) -height $geometry(ctexth) \
442 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
443 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
444 pack .ctop.cdet.left.sb -side right -fill y
445 pack $ctext -side left -fill both -expand 1
446 .ctop.cdet add .ctop.cdet.left
448 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
449 if {$gaudydiff} {
450 $ctext tag conf hunksep -back blue -fore white
451 $ctext tag conf d0 -back "#ff8080"
452 $ctext tag conf d1 -back green
453 } else {
454 $ctext tag conf hunksep -fore blue
455 $ctext tag conf d0 -fore red
456 $ctext tag conf d1 -fore "#00a000"
457 $ctext tag conf m0 -fore red
458 $ctext tag conf m1 -fore blue
459 $ctext tag conf m2 -fore green
460 $ctext tag conf m3 -fore purple
461 $ctext tag conf m4 -fore brown
462 $ctext tag conf mmax -fore darkgrey
463 set mergemax 5
464 $ctext tag conf mresult -font [concat $textfont bold]
465 $ctext tag conf msep -font [concat $textfont bold]
466 $ctext tag conf found -back yellow
469 frame .ctop.cdet.right
470 set cflist .ctop.cdet.right.cfiles
471 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
472 -yscrollcommand ".ctop.cdet.right.sb set"
473 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
474 pack .ctop.cdet.right.sb -side right -fill y
475 pack $cflist -side left -fill both -expand 1
476 .ctop.cdet add .ctop.cdet.right
477 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
479 pack .ctop -side top -fill both -expand 1
481 bindall <1> {selcanvline %W %x %y}
482 #bindall <B1-Motion> {selcanvline %W %x %y}
483 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
484 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
485 bindall <2> "allcanvs scan mark 0 %y"
486 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
487 bind . <Key-Up> "selnextline -1"
488 bind . <Key-Down> "selnextline 1"
489 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
490 bind . <Key-Next> "allcanvs yview scroll 1 pages"
491 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
492 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
493 bindkey <Key-space> "$ctext yview scroll 1 pages"
494 bindkey p "selnextline -1"
495 bindkey n "selnextline 1"
496 bindkey b "$ctext yview scroll -1 pages"
497 bindkey d "$ctext yview scroll 18 units"
498 bindkey u "$ctext yview scroll -18 units"
499 bindkey / {findnext 1}
500 bindkey <Key-Return> {findnext 0}
501 bindkey ? findprev
502 bindkey f nextfile
503 bind . <Control-q> doquit
504 bind . <Control-f> dofind
505 bind . <Control-g> {findnext 0}
506 bind . <Control-r> findprev
507 bind . <Control-equal> {incrfont 1}
508 bind . <Control-KP_Add> {incrfont 1}
509 bind . <Control-minus> {incrfont -1}
510 bind . <Control-KP_Subtract> {incrfont -1}
511 bind $cflist <<ListboxSelect>> listboxsel
512 bind . <Destroy> {savestuff %W}
513 bind . <Button-1> "click %W"
514 bind $fstring <Key-Return> dofind
515 bind $sha1entry <Key-Return> gotocommit
516 bind $sha1entry <<PasteSelection>> clearsha1
518 set maincursor [. cget -cursor]
519 set textcursor [$ctext cget -cursor]
520 set curtextcursor $textcursor
522 set rowctxmenu .rowctxmenu
523 menu $rowctxmenu -tearoff 0
524 $rowctxmenu add command -label "Diff this -> selected" \
525 -command {diffvssel 0}
526 $rowctxmenu add command -label "Diff selected -> this" \
527 -command {diffvssel 1}
528 $rowctxmenu add command -label "Make patch" -command mkpatch
529 $rowctxmenu add command -label "Create tag" -command mktag
530 $rowctxmenu add command -label "Write commit to file" -command writecommit
533 # when we make a key binding for the toplevel, make sure
534 # it doesn't get triggered when that key is pressed in the
535 # find string entry widget.
536 proc bindkey {ev script} {
537 global entries
538 bind . $ev $script
539 set escript [bind Entry $ev]
540 if {$escript == {}} {
541 set escript [bind Entry <Key>]
543 foreach e $entries {
544 bind $e $ev "$escript; break"
548 # set the focus back to the toplevel for any click outside
549 # the entry widgets
550 proc click {w} {
551 global entries
552 foreach e $entries {
553 if {$w == $e} return
555 focus .
558 proc savestuff {w} {
559 global canv canv2 canv3 ctext cflist mainfont textfont
560 global stuffsaved findmergefiles gaudydiff maxgraphpct
561 global maxwidth
563 if {$stuffsaved} return
564 if {![winfo viewable .]} return
565 catch {
566 set f [open "~/.gitk-new" w]
567 puts $f [list set mainfont $mainfont]
568 puts $f [list set textfont $textfont]
569 puts $f [list set findmergefiles $findmergefiles]
570 puts $f [list set gaudydiff $gaudydiff]
571 puts $f [list set maxgraphpct $maxgraphpct]
572 puts $f [list set maxwidth $maxwidth]
573 puts $f "set geometry(width) [winfo width .ctop]"
574 puts $f "set geometry(height) [winfo height .ctop]"
575 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
576 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
577 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
578 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
579 set wid [expr {([winfo width $ctext] - 8) \
580 / [font measure $textfont "0"]}]
581 puts $f "set geometry(ctextw) $wid"
582 set wid [expr {([winfo width $cflist] - 11) \
583 / [font measure [$cflist cget -font] "0"]}]
584 puts $f "set geometry(cflistw) $wid"
585 close $f
586 file rename -force "~/.gitk-new" "~/.gitk"
588 set stuffsaved 1
591 proc resizeclistpanes {win w} {
592 global oldwidth
593 if [info exists oldwidth($win)] {
594 set s0 [$win sash coord 0]
595 set s1 [$win sash coord 1]
596 if {$w < 60} {
597 set sash0 [expr {int($w/2 - 2)}]
598 set sash1 [expr {int($w*5/6 - 2)}]
599 } else {
600 set factor [expr {1.0 * $w / $oldwidth($win)}]
601 set sash0 [expr {int($factor * [lindex $s0 0])}]
602 set sash1 [expr {int($factor * [lindex $s1 0])}]
603 if {$sash0 < 30} {
604 set sash0 30
606 if {$sash1 < $sash0 + 20} {
607 set sash1 [expr $sash0 + 20]
609 if {$sash1 > $w - 10} {
610 set sash1 [expr $w - 10]
611 if {$sash0 > $sash1 - 20} {
612 set sash0 [expr $sash1 - 20]
616 $win sash place 0 $sash0 [lindex $s0 1]
617 $win sash place 1 $sash1 [lindex $s1 1]
619 set oldwidth($win) $w
622 proc resizecdetpanes {win w} {
623 global oldwidth
624 if [info exists oldwidth($win)] {
625 set s0 [$win sash coord 0]
626 if {$w < 60} {
627 set sash0 [expr {int($w*3/4 - 2)}]
628 } else {
629 set factor [expr {1.0 * $w / $oldwidth($win)}]
630 set sash0 [expr {int($factor * [lindex $s0 0])}]
631 if {$sash0 < 45} {
632 set sash0 45
634 if {$sash0 > $w - 15} {
635 set sash0 [expr $w - 15]
638 $win sash place 0 $sash0 [lindex $s0 1]
640 set oldwidth($win) $w
643 proc allcanvs args {
644 global canv canv2 canv3
645 eval $canv $args
646 eval $canv2 $args
647 eval $canv3 $args
650 proc bindall {event action} {
651 global canv canv2 canv3
652 bind $canv $event $action
653 bind $canv2 $event $action
654 bind $canv3 $event $action
657 proc about {} {
658 set w .about
659 if {[winfo exists $w]} {
660 raise $w
661 return
663 toplevel $w
664 wm title $w "About gitk"
665 message $w.m -text {
666 Gitk version 1.2
668 Copyright © 2005 Paul Mackerras
670 Use and redistribute under the terms of the GNU General Public License} \
671 -justify center -aspect 400
672 pack $w.m -side top -fill x -padx 20 -pady 20
673 button $w.ok -text Close -command "destroy $w"
674 pack $w.ok -side bottom
677 proc assigncolor {id} {
678 global commitinfo colormap commcolors colors nextcolor
679 global parents nparents children nchildren
680 global cornercrossings crossings
682 if [info exists colormap($id)] return
683 set ncolors [llength $colors]
684 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
685 set child [lindex $children($id) 0]
686 if {[info exists colormap($child)]
687 && $nparents($child) == 1} {
688 set colormap($id) $colormap($child)
689 return
692 set badcolors {}
693 if {[info exists cornercrossings($id)]} {
694 foreach x $cornercrossings($id) {
695 if {[info exists colormap($x)]
696 && [lsearch -exact $badcolors $colormap($x)] < 0} {
697 lappend badcolors $colormap($x)
700 if {[llength $badcolors] >= $ncolors} {
701 set badcolors {}
704 set origbad $badcolors
705 if {[llength $badcolors] < $ncolors - 1} {
706 if {[info exists crossings($id)]} {
707 foreach x $crossings($id) {
708 if {[info exists colormap($x)]
709 && [lsearch -exact $badcolors $colormap($x)] < 0} {
710 lappend badcolors $colormap($x)
713 if {[llength $badcolors] >= $ncolors} {
714 set badcolors $origbad
717 set origbad $badcolors
719 if {[llength $badcolors] < $ncolors - 1} {
720 foreach child $children($id) {
721 if {[info exists colormap($child)]
722 && [lsearch -exact $badcolors $colormap($child)] < 0} {
723 lappend badcolors $colormap($child)
725 if {[info exists parents($child)]} {
726 foreach p $parents($child) {
727 if {[info exists colormap($p)]
728 && [lsearch -exact $badcolors $colormap($p)] < 0} {
729 lappend badcolors $colormap($p)
734 if {[llength $badcolors] >= $ncolors} {
735 set badcolors $origbad
738 for {set i 0} {$i <= $ncolors} {incr i} {
739 set c [lindex $colors $nextcolor]
740 if {[incr nextcolor] >= $ncolors} {
741 set nextcolor 0
743 if {[lsearch -exact $badcolors $c]} break
745 set colormap($id) $c
748 proc initgraph {} {
749 global canvy canvy0 lineno numcommits nextcolor linespc
750 global mainline mainlinearrow sidelines
751 global nchildren ncleft
752 global displist nhyperspace
754 allcanvs delete all
755 set nextcolor 0
756 set canvy $canvy0
757 set lineno -1
758 set numcommits 0
759 catch {unset mainline}
760 catch {unset mainlinearrow}
761 catch {unset sidelines}
762 foreach id [array names nchildren] {
763 set ncleft($id) $nchildren($id)
765 set displist {}
766 set nhyperspace 0
769 proc bindline {t id} {
770 global canv
772 $canv bind $t <Enter> "lineenter %x %y $id"
773 $canv bind $t <Motion> "linemotion %x %y $id"
774 $canv bind $t <Leave> "lineleave $id"
775 $canv bind $t <Button-1> "lineclick %x %y $id 1"
778 proc drawlines {id xtra} {
779 global mainline mainlinearrow sidelines lthickness colormap canv
781 $canv delete lines.$id
782 if {[info exists mainline($id)]} {
783 set t [$canv create line $mainline($id) \
784 -width [expr {($xtra + 1) * $lthickness}] \
785 -fill $colormap($id) -tags lines.$id \
786 -arrow $mainlinearrow($id)]
787 $canv lower $t
788 bindline $t $id
790 if {[info exists sidelines($id)]} {
791 foreach ls $sidelines($id) {
792 set coords [lindex $ls 0]
793 set thick [lindex $ls 1]
794 set arrow [lindex $ls 2]
795 set t [$canv create line $coords -fill $colormap($id) \
796 -width [expr {($thick + $xtra) * $lthickness}] \
797 -arrow $arrow -tags lines.$id]
798 $canv lower $t
799 bindline $t $id
804 # level here is an index in displist
805 proc drawcommitline {level} {
806 global parents children nparents displist
807 global canv canv2 canv3 mainfont namefont canvy linespc
808 global lineid linehtag linentag linedtag commitinfo
809 global colormap numcommits currentparents dupparents
810 global idtags idline idheads idotherrefs
811 global lineno lthickness mainline mainlinearrow sidelines
812 global commitlisted rowtextx idpos lastuse displist
813 global oldnlines olddlevel olddisplist
815 incr numcommits
816 incr lineno
817 set id [lindex $displist $level]
818 set lastuse($id) $lineno
819 set lineid($lineno) $id
820 set idline($id) $lineno
821 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
822 if {![info exists commitinfo($id)]} {
823 readcommit $id
824 if {![info exists commitinfo($id)]} {
825 set commitinfo($id) {"No commit information available"}
826 set nparents($id) 0
829 assigncolor $id
830 set currentparents {}
831 set dupparents {}
832 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
833 foreach p $parents($id) {
834 if {[lsearch -exact $currentparents $p] < 0} {
835 lappend currentparents $p
836 } else {
837 # remember that this parent was listed twice
838 lappend dupparents $p
842 set x [xcoord $level $level $lineno]
843 set y1 $canvy
844 set canvy [expr $canvy + $linespc]
845 allcanvs conf -scrollregion \
846 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
847 if {[info exists mainline($id)]} {
848 lappend mainline($id) $x $y1
849 if {$mainlinearrow($id) ne "none"} {
850 set mainline($id) [trimdiagstart $mainline($id)]
853 drawlines $id 0
854 set orad [expr {$linespc / 3}]
855 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
856 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
857 -fill $ofill -outline black -width 1]
858 $canv raise $t
859 $canv bind $t <1> {selcanvline {} %x %y}
860 set xt [xcoord [llength $displist] $level $lineno]
861 if {[llength $currentparents] > 2} {
862 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
864 set rowtextx($lineno) $xt
865 set idpos($id) [list $x $xt $y1]
866 if {[info exists idtags($id)] || [info exists idheads($id)]
867 || [info exists idotherrefs($id)]} {
868 set xt [drawtags $id $x $xt $y1]
870 set headline [lindex $commitinfo($id) 0]
871 set name [lindex $commitinfo($id) 1]
872 set date [lindex $commitinfo($id) 2]
873 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
874 -text $headline -font $mainfont ]
875 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
876 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
877 -text $name -font $namefont]
878 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
879 -text $date -font $mainfont]
881 set olddlevel $level
882 set olddisplist $displist
883 set oldnlines [llength $displist]
886 proc drawtags {id x xt y1} {
887 global idtags idheads idotherrefs
888 global linespc lthickness
889 global canv mainfont idline rowtextx
891 set marks {}
892 set ntags 0
893 set nheads 0
894 if {[info exists idtags($id)]} {
895 set marks $idtags($id)
896 set ntags [llength $marks]
898 if {[info exists idheads($id)]} {
899 set marks [concat $marks $idheads($id)]
900 set nheads [llength $idheads($id)]
902 if {[info exists idotherrefs($id)]} {
903 set marks [concat $marks $idotherrefs($id)]
905 if {$marks eq {}} {
906 return $xt
909 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
910 set yt [expr $y1 - 0.5 * $linespc]
911 set yb [expr $yt + $linespc - 1]
912 set xvals {}
913 set wvals {}
914 foreach tag $marks {
915 set wid [font measure $mainfont $tag]
916 lappend xvals $xt
917 lappend wvals $wid
918 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
920 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
921 -width $lthickness -fill black -tags tag.$id]
922 $canv lower $t
923 foreach tag $marks x $xvals wid $wvals {
924 set xl [expr $x + $delta]
925 set xr [expr $x + $delta + $wid + $lthickness]
926 if {[incr ntags -1] >= 0} {
927 # draw a tag
928 set t [$canv create polygon $x [expr $yt + $delta] $xl $yt \
929 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
930 -width 1 -outline black -fill yellow -tags tag.$id]
931 $canv bind $t <1> [list showtag $tag 1]
932 set rowtextx($idline($id)) [expr {$xr + $linespc}]
933 } else {
934 # draw a head or other ref
935 if {[incr nheads -1] >= 0} {
936 set col green
937 } else {
938 set col "#ddddff"
940 set xl [expr $xl - $delta/2]
941 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
942 -width 1 -outline black -fill $col -tags tag.$id
944 set t [$canv create text $xl $y1 -anchor w -text $tag \
945 -font $mainfont -tags tag.$id]
946 if {$ntags >= 0} {
947 $canv bind $t <1> [list showtag $tag 1]
950 return $xt
953 proc notecrossings {id lo hi corner} {
954 global olddisplist crossings cornercrossings
956 for {set i $lo} {[incr i] < $hi} {} {
957 set p [lindex $olddisplist $i]
958 if {$p == {}} continue
959 if {$i == $corner} {
960 if {![info exists cornercrossings($id)]
961 || [lsearch -exact $cornercrossings($id) $p] < 0} {
962 lappend cornercrossings($id) $p
964 if {![info exists cornercrossings($p)]
965 || [lsearch -exact $cornercrossings($p) $id] < 0} {
966 lappend cornercrossings($p) $id
968 } else {
969 if {![info exists crossings($id)]
970 || [lsearch -exact $crossings($id) $p] < 0} {
971 lappend crossings($id) $p
973 if {![info exists crossings($p)]
974 || [lsearch -exact $crossings($p) $id] < 0} {
975 lappend crossings($p) $id
981 proc xcoord {i level ln} {
982 global canvx0 xspc1 xspc2
984 set x [expr {$canvx0 + $i * $xspc1($ln)}]
985 if {$i > 0 && $i == $level} {
986 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
987 } elseif {$i > $level} {
988 set x [expr {$x + $xspc2 - $xspc1($ln)}]
990 return $x
993 # it seems Tk can't draw arrows on the end of diagonal line segments...
994 proc trimdiagend {line} {
995 while {[llength $line] > 4} {
996 set x1 [lindex $line end-3]
997 set y1 [lindex $line end-2]
998 set x2 [lindex $line end-1]
999 set y2 [lindex $line end]
1000 if {($x1 == $x2) != ($y1 == $y2)} break
1001 set line [lreplace $line end-1 end]
1003 return $line
1006 proc trimdiagstart {line} {
1007 while {[llength $line] > 4} {
1008 set x1 [lindex $line 0]
1009 set y1 [lindex $line 1]
1010 set x2 [lindex $line 2]
1011 set y2 [lindex $line 3]
1012 if {($x1 == $x2) != ($y1 == $y2)} break
1013 set line [lreplace $line 0 1]
1015 return $line
1018 proc drawslants {id needonscreen nohs} {
1019 global canv mainline mainlinearrow sidelines
1020 global canvx0 canvy xspc1 xspc2 lthickness
1021 global currentparents dupparents
1022 global lthickness linespc canvy colormap lineno geometry
1023 global maxgraphpct maxwidth
1024 global displist onscreen lastuse
1025 global parents commitlisted
1026 global oldnlines olddlevel olddisplist
1027 global nhyperspace numcommits nnewparents
1029 if {$lineno < 0} {
1030 lappend displist $id
1031 set onscreen($id) 1
1032 return 0
1035 set y1 [expr {$canvy - $linespc}]
1036 set y2 $canvy
1038 # work out what we need to get back on screen
1039 set reins {}
1040 if {$onscreen($id) < 0} {
1041 # next to do isn't displayed, better get it on screen...
1042 lappend reins [list $id 0]
1044 # make sure all the previous commits's parents are on the screen
1045 foreach p $currentparents {
1046 if {$onscreen($p) < 0} {
1047 lappend reins [list $p 0]
1050 # bring back anything requested by caller
1051 if {$needonscreen ne {}} {
1052 lappend reins $needonscreen
1055 # try the shortcut
1056 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1057 set dlevel $olddlevel
1058 set x [xcoord $dlevel $dlevel $lineno]
1059 set mainline($id) [list $x $y1]
1060 set mainlinearrow($id) none
1061 set lastuse($id) $lineno
1062 set displist [lreplace $displist $dlevel $dlevel $id]
1063 set onscreen($id) 1
1064 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1065 return $dlevel
1068 # update displist
1069 set displist [lreplace $displist $olddlevel $olddlevel]
1070 set j $olddlevel
1071 foreach p $currentparents {
1072 set lastuse($p) $lineno
1073 if {$onscreen($p) == 0} {
1074 set displist [linsert $displist $j $p]
1075 set onscreen($p) 1
1076 incr j
1079 if {$onscreen($id) == 0} {
1080 lappend displist $id
1081 set onscreen($id) 1
1084 # remove the null entry if present
1085 set nullentry [lsearch -exact $displist {}]
1086 if {$nullentry >= 0} {
1087 set displist [lreplace $displist $nullentry $nullentry]
1090 # bring back the ones we need now (if we did it earlier
1091 # it would change displist and invalidate olddlevel)
1092 foreach pi $reins {
1093 # test again in case of duplicates in reins
1094 set p [lindex $pi 0]
1095 if {$onscreen($p) < 0} {
1096 set onscreen($p) 1
1097 set lastuse($p) $lineno
1098 set displist [linsert $displist [lindex $pi 1] $p]
1099 incr nhyperspace -1
1103 set lastuse($id) $lineno
1105 # see if we need to make any lines jump off into hyperspace
1106 set displ [llength $displist]
1107 if {$displ > $maxwidth} {
1108 set ages {}
1109 foreach x $displist {
1110 lappend ages [list $lastuse($x) $x]
1112 set ages [lsort -integer -index 0 $ages]
1113 set k 0
1114 while {$displ > $maxwidth} {
1115 set use [lindex $ages $k 0]
1116 set victim [lindex $ages $k 1]
1117 if {$use >= $lineno - 5} break
1118 incr k
1119 if {[lsearch -exact $nohs $victim] >= 0} continue
1120 set i [lsearch -exact $displist $victim]
1121 set displist [lreplace $displist $i $i]
1122 set onscreen($victim) -1
1123 incr nhyperspace
1124 incr displ -1
1125 if {$i < $nullentry} {
1126 incr nullentry -1
1128 set x [lindex $mainline($victim) end-1]
1129 lappend mainline($victim) $x $y1
1130 set line [trimdiagend $mainline($victim)]
1131 set arrow "last"
1132 if {$mainlinearrow($victim) ne "none"} {
1133 set line [trimdiagstart $line]
1134 set arrow "both"
1136 lappend sidelines($victim) [list $line 1 $arrow]
1137 unset mainline($victim)
1141 set dlevel [lsearch -exact $displist $id]
1143 # If we are reducing, put in a null entry
1144 if {$displ < $oldnlines} {
1145 # does the next line look like a merge?
1146 # i.e. does it have > 1 new parent?
1147 if {$nnewparents($id) > 1} {
1148 set i [expr {$dlevel + 1}]
1149 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1150 set i $olddlevel
1151 if {$nullentry >= 0 && $nullentry < $i} {
1152 incr i -1
1154 } elseif {$nullentry >= 0} {
1155 set i $nullentry
1156 while {$i < $displ
1157 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1158 incr i
1160 } else {
1161 set i $olddlevel
1162 if {$dlevel >= $i} {
1163 incr i
1166 if {$i < $displ} {
1167 set displist [linsert $displist $i {}]
1168 incr displ
1169 if {$dlevel >= $i} {
1170 incr dlevel
1175 # decide on the line spacing for the next line
1176 set lj [expr {$lineno + 1}]
1177 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1178 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1179 set xspc1($lj) $xspc2
1180 } else {
1181 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1182 if {$xspc1($lj) < $lthickness} {
1183 set xspc1($lj) $lthickness
1187 foreach idi $reins {
1188 set id [lindex $idi 0]
1189 set j [lsearch -exact $displist $id]
1190 set xj [xcoord $j $dlevel $lj]
1191 set mainline($id) [list $xj $y2]
1192 set mainlinearrow($id) first
1195 set i -1
1196 foreach id $olddisplist {
1197 incr i
1198 if {$id == {}} continue
1199 if {$onscreen($id) <= 0} continue
1200 set xi [xcoord $i $olddlevel $lineno]
1201 if {$i == $olddlevel} {
1202 foreach p $currentparents {
1203 set j [lsearch -exact $displist $p]
1204 set coords [list $xi $y1]
1205 set xj [xcoord $j $dlevel $lj]
1206 if {$xj < $xi - $linespc} {
1207 lappend coords [expr {$xj + $linespc}] $y1
1208 notecrossings $p $j $i [expr {$j + 1}]
1209 } elseif {$xj > $xi + $linespc} {
1210 lappend coords [expr {$xj - $linespc}] $y1
1211 notecrossings $p $i $j [expr {$j - 1}]
1213 if {[lsearch -exact $dupparents $p] >= 0} {
1214 # draw a double-width line to indicate the doubled parent
1215 lappend coords $xj $y2
1216 lappend sidelines($p) [list $coords 2 none]
1217 if {![info exists mainline($p)]} {
1218 set mainline($p) [list $xj $y2]
1219 set mainlinearrow($p) none
1221 } else {
1222 # normal case, no parent duplicated
1223 set yb $y2
1224 set dx [expr {abs($xi - $xj)}]
1225 if {0 && $dx < $linespc} {
1226 set yb [expr {$y1 + $dx}]
1228 if {![info exists mainline($p)]} {
1229 if {$xi != $xj} {
1230 lappend coords $xj $yb
1232 set mainline($p) $coords
1233 set mainlinearrow($p) none
1234 } else {
1235 lappend coords $xj $yb
1236 if {$yb < $y2} {
1237 lappend coords $xj $y2
1239 lappend sidelines($p) [list $coords 1 none]
1243 } else {
1244 set j $i
1245 if {[lindex $displist $i] != $id} {
1246 set j [lsearch -exact $displist $id]
1248 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1249 || ($olddlevel < $i && $i < $dlevel)
1250 || ($dlevel < $i && $i < $olddlevel)} {
1251 set xj [xcoord $j $dlevel $lj]
1252 lappend mainline($id) $xi $y1 $xj $y2
1256 return $dlevel
1259 # search for x in a list of lists
1260 proc llsearch {llist x} {
1261 set i 0
1262 foreach l $llist {
1263 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1264 return $i
1266 incr i
1268 return -1
1271 proc drawmore {reading} {
1272 global displayorder numcommits ncmupdate nextupdate
1273 global stopped nhyperspace parents commitlisted
1274 global maxwidth onscreen displist currentparents olddlevel
1276 set n [llength $displayorder]
1277 while {$numcommits < $n} {
1278 set id [lindex $displayorder $numcommits]
1279 set ctxend [expr {$numcommits + 10}]
1280 if {!$reading && $ctxend > $n} {
1281 set ctxend $n
1283 set dlist {}
1284 if {$numcommits > 0} {
1285 set dlist [lreplace $displist $olddlevel $olddlevel]
1286 set i $olddlevel
1287 foreach p $currentparents {
1288 if {$onscreen($p) == 0} {
1289 set dlist [linsert $dlist $i $p]
1290 incr i
1294 set nohs {}
1295 set reins {}
1296 set isfat [expr {[llength $dlist] > $maxwidth}]
1297 if {$nhyperspace > 0 || $isfat} {
1298 if {$ctxend > $n} break
1299 # work out what to bring back and
1300 # what we want to don't want to send into hyperspace
1301 set room 1
1302 for {set k $numcommits} {$k < $ctxend} {incr k} {
1303 set x [lindex $displayorder $k]
1304 set i [llsearch $dlist $x]
1305 if {$i < 0} {
1306 set i [llength $dlist]
1307 lappend dlist $x
1309 if {[lsearch -exact $nohs $x] < 0} {
1310 lappend nohs $x
1312 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1313 set reins [list $x $i]
1315 set newp {}
1316 if {[info exists commitlisted($x)]} {
1317 set right 0
1318 foreach p $parents($x) {
1319 if {[llsearch $dlist $p] < 0} {
1320 lappend newp $p
1321 if {[lsearch -exact $nohs $p] < 0} {
1322 lappend nohs $p
1324 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1325 set reins [list $p [expr {$i + $right}]]
1328 set right 1
1331 set l [lindex $dlist $i]
1332 if {[llength $l] == 1} {
1333 set l $newp
1334 } else {
1335 set j [lsearch -exact $l $x]
1336 set l [concat [lreplace $l $j $j] $newp]
1338 set dlist [lreplace $dlist $i $i $l]
1339 if {$room && $isfat && [llength $newp] <= 1} {
1340 set room 0
1345 set dlevel [drawslants $id $reins $nohs]
1346 drawcommitline $dlevel
1347 if {[clock clicks -milliseconds] >= $nextupdate
1348 && $numcommits >= $ncmupdate} {
1349 doupdate $reading
1350 if {$stopped} break
1355 # level here is an index in todo
1356 proc updatetodo {level noshortcut} {
1357 global ncleft todo nnewparents
1358 global commitlisted parents onscreen
1360 set id [lindex $todo $level]
1361 set olds {}
1362 if {[info exists commitlisted($id)]} {
1363 foreach p $parents($id) {
1364 if {[lsearch -exact $olds $p] < 0} {
1365 lappend olds $p
1369 if {!$noshortcut && [llength $olds] == 1} {
1370 set p [lindex $olds 0]
1371 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1372 set ncleft($p) 0
1373 set todo [lreplace $todo $level $level $p]
1374 set onscreen($p) 0
1375 set nnewparents($id) 1
1376 return 0
1380 set todo [lreplace $todo $level $level]
1381 set i $level
1382 set n 0
1383 foreach p $olds {
1384 incr ncleft($p) -1
1385 set k [lsearch -exact $todo $p]
1386 if {$k < 0} {
1387 set todo [linsert $todo $i $p]
1388 set onscreen($p) 0
1389 incr i
1390 incr n
1393 set nnewparents($id) $n
1395 return 1
1398 proc decidenext {{noread 0}} {
1399 global ncleft todo
1400 global datemode cdate
1401 global commitinfo
1403 # choose which one to do next time around
1404 set todol [llength $todo]
1405 set level -1
1406 set latest {}
1407 for {set k $todol} {[incr k -1] >= 0} {} {
1408 set p [lindex $todo $k]
1409 if {$ncleft($p) == 0} {
1410 if {$datemode} {
1411 if {![info exists commitinfo($p)]} {
1412 if {$noread} {
1413 return {}
1415 readcommit $p
1417 if {$latest == {} || $cdate($p) > $latest} {
1418 set level $k
1419 set latest $cdate($p)
1421 } else {
1422 set level $k
1423 break
1427 if {$level < 0} {
1428 if {$todo != {}} {
1429 puts "ERROR: none of the pending commits can be done yet:"
1430 foreach p $todo {
1431 puts " $p ($ncleft($p))"
1434 return -1
1437 return $level
1440 proc drawcommit {id} {
1441 global phase todo nchildren datemode nextupdate
1442 global numcommits ncmupdate displayorder todo onscreen
1444 if {$phase != "incrdraw"} {
1445 set phase incrdraw
1446 set displayorder {}
1447 set todo {}
1448 initgraph
1450 if {$nchildren($id) == 0} {
1451 lappend todo $id
1452 set onscreen($id) 0
1454 set level [decidenext 1]
1455 if {$level == {} || $id != [lindex $todo $level]} {
1456 return
1458 while 1 {
1459 lappend displayorder [lindex $todo $level]
1460 if {[updatetodo $level $datemode]} {
1461 set level [decidenext 1]
1462 if {$level == {}} break
1464 set id [lindex $todo $level]
1465 if {![info exists commitlisted($id)]} {
1466 break
1469 drawmore 1
1472 proc finishcommits {} {
1473 global phase
1474 global canv mainfont ctext maincursor textcursor
1476 if {$phase != "incrdraw"} {
1477 $canv delete all
1478 $canv create text 3 3 -anchor nw -text "No commits selected" \
1479 -font $mainfont -tags textitems
1480 set phase {}
1481 } else {
1482 drawrest
1484 . config -cursor $maincursor
1485 settextcursor $textcursor
1488 # Don't change the text pane cursor if it is currently the hand cursor,
1489 # showing that we are over a sha1 ID link.
1490 proc settextcursor {c} {
1491 global ctext curtextcursor
1493 if {[$ctext cget -cursor] == $curtextcursor} {
1494 $ctext config -cursor $c
1496 set curtextcursor $c
1499 proc drawgraph {} {
1500 global nextupdate startmsecs ncmupdate
1501 global displayorder onscreen
1503 if {$displayorder == {}} return
1504 set startmsecs [clock clicks -milliseconds]
1505 set nextupdate [expr $startmsecs + 100]
1506 set ncmupdate 1
1507 initgraph
1508 foreach id $displayorder {
1509 set onscreen($id) 0
1511 drawmore 0
1514 proc drawrest {} {
1515 global phase stopped redisplaying selectedline
1516 global datemode todo displayorder
1517 global numcommits ncmupdate
1518 global nextupdate startmsecs
1520 set level [decidenext]
1521 if {$level >= 0} {
1522 set phase drawgraph
1523 while 1 {
1524 lappend displayorder [lindex $todo $level]
1525 set hard [updatetodo $level $datemode]
1526 if {$hard} {
1527 set level [decidenext]
1528 if {$level < 0} break
1531 drawmore 0
1533 set phase {}
1534 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1535 #puts "overall $drawmsecs ms for $numcommits commits"
1536 if {$redisplaying} {
1537 if {$stopped == 0 && [info exists selectedline]} {
1538 selectline $selectedline 0
1540 if {$stopped == 1} {
1541 set stopped 0
1542 after idle drawgraph
1543 } else {
1544 set redisplaying 0
1549 proc findmatches {f} {
1550 global findtype foundstring foundstrlen
1551 if {$findtype == "Regexp"} {
1552 set matches [regexp -indices -all -inline $foundstring $f]
1553 } else {
1554 if {$findtype == "IgnCase"} {
1555 set str [string tolower $f]
1556 } else {
1557 set str $f
1559 set matches {}
1560 set i 0
1561 while {[set j [string first $foundstring $str $i]] >= 0} {
1562 lappend matches [list $j [expr $j+$foundstrlen-1]]
1563 set i [expr $j + $foundstrlen]
1566 return $matches
1569 proc dofind {} {
1570 global findtype findloc findstring markedmatches commitinfo
1571 global numcommits lineid linehtag linentag linedtag
1572 global mainfont namefont canv canv2 canv3 selectedline
1573 global matchinglines foundstring foundstrlen
1575 stopfindproc
1576 unmarkmatches
1577 focus .
1578 set matchinglines {}
1579 if {$findloc == "Pickaxe"} {
1580 findpatches
1581 return
1583 if {$findtype == "IgnCase"} {
1584 set foundstring [string tolower $findstring]
1585 } else {
1586 set foundstring $findstring
1588 set foundstrlen [string length $findstring]
1589 if {$foundstrlen == 0} return
1590 if {$findloc == "Files"} {
1591 findfiles
1592 return
1594 if {![info exists selectedline]} {
1595 set oldsel -1
1596 } else {
1597 set oldsel $selectedline
1599 set didsel 0
1600 set fldtypes {Headline Author Date Committer CDate Comment}
1601 for {set l 0} {$l < $numcommits} {incr l} {
1602 set id $lineid($l)
1603 set info $commitinfo($id)
1604 set doesmatch 0
1605 foreach f $info ty $fldtypes {
1606 if {$findloc != "All fields" && $findloc != $ty} {
1607 continue
1609 set matches [findmatches $f]
1610 if {$matches == {}} continue
1611 set doesmatch 1
1612 if {$ty == "Headline"} {
1613 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1614 } elseif {$ty == "Author"} {
1615 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1616 } elseif {$ty == "Date"} {
1617 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1620 if {$doesmatch} {
1621 lappend matchinglines $l
1622 if {!$didsel && $l > $oldsel} {
1623 findselectline $l
1624 set didsel 1
1628 if {$matchinglines == {}} {
1629 bell
1630 } elseif {!$didsel} {
1631 findselectline [lindex $matchinglines 0]
1635 proc findselectline {l} {
1636 global findloc commentend ctext
1637 selectline $l 1
1638 if {$findloc == "All fields" || $findloc == "Comments"} {
1639 # highlight the matches in the comments
1640 set f [$ctext get 1.0 $commentend]
1641 set matches [findmatches $f]
1642 foreach match $matches {
1643 set start [lindex $match 0]
1644 set end [expr [lindex $match 1] + 1]
1645 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1650 proc findnext {restart} {
1651 global matchinglines selectedline
1652 if {![info exists matchinglines]} {
1653 if {$restart} {
1654 dofind
1656 return
1658 if {![info exists selectedline]} return
1659 foreach l $matchinglines {
1660 if {$l > $selectedline} {
1661 findselectline $l
1662 return
1665 bell
1668 proc findprev {} {
1669 global matchinglines selectedline
1670 if {![info exists matchinglines]} {
1671 dofind
1672 return
1674 if {![info exists selectedline]} return
1675 set prev {}
1676 foreach l $matchinglines {
1677 if {$l >= $selectedline} break
1678 set prev $l
1680 if {$prev != {}} {
1681 findselectline $prev
1682 } else {
1683 bell
1687 proc findlocchange {name ix op} {
1688 global findloc findtype findtypemenu
1689 if {$findloc == "Pickaxe"} {
1690 set findtype Exact
1691 set state disabled
1692 } else {
1693 set state normal
1695 $findtypemenu entryconf 1 -state $state
1696 $findtypemenu entryconf 2 -state $state
1699 proc stopfindproc {{done 0}} {
1700 global findprocpid findprocfile findids
1701 global ctext findoldcursor phase maincursor textcursor
1702 global findinprogress
1704 catch {unset findids}
1705 if {[info exists findprocpid]} {
1706 if {!$done} {
1707 catch {exec kill $findprocpid}
1709 catch {close $findprocfile}
1710 unset findprocpid
1712 if {[info exists findinprogress]} {
1713 unset findinprogress
1714 if {$phase != "incrdraw"} {
1715 . config -cursor $maincursor
1716 settextcursor $textcursor
1721 proc findpatches {} {
1722 global findstring selectedline numcommits
1723 global findprocpid findprocfile
1724 global finddidsel ctext lineid findinprogress
1725 global findinsertpos
1727 if {$numcommits == 0} return
1729 # make a list of all the ids to search, starting at the one
1730 # after the selected line (if any)
1731 if {[info exists selectedline]} {
1732 set l $selectedline
1733 } else {
1734 set l -1
1736 set inputids {}
1737 for {set i 0} {$i < $numcommits} {incr i} {
1738 if {[incr l] >= $numcommits} {
1739 set l 0
1741 append inputids $lineid($l) "\n"
1744 if {[catch {
1745 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1746 << $inputids] r]
1747 } err]} {
1748 error_popup "Error starting search process: $err"
1749 return
1752 set findinsertpos end
1753 set findprocfile $f
1754 set findprocpid [pid $f]
1755 fconfigure $f -blocking 0
1756 fileevent $f readable readfindproc
1757 set finddidsel 0
1758 . config -cursor watch
1759 settextcursor watch
1760 set findinprogress 1
1763 proc readfindproc {} {
1764 global findprocfile finddidsel
1765 global idline matchinglines findinsertpos
1767 set n [gets $findprocfile line]
1768 if {$n < 0} {
1769 if {[eof $findprocfile]} {
1770 stopfindproc 1
1771 if {!$finddidsel} {
1772 bell
1775 return
1777 if {![regexp {^[0-9a-f]{40}} $line id]} {
1778 error_popup "Can't parse git-diff-tree output: $line"
1779 stopfindproc
1780 return
1782 if {![info exists idline($id)]} {
1783 puts stderr "spurious id: $id"
1784 return
1786 set l $idline($id)
1787 insertmatch $l $id
1790 proc insertmatch {l id} {
1791 global matchinglines findinsertpos finddidsel
1793 if {$findinsertpos == "end"} {
1794 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1795 set matchinglines [linsert $matchinglines 0 $l]
1796 set findinsertpos 1
1797 } else {
1798 lappend matchinglines $l
1800 } else {
1801 set matchinglines [linsert $matchinglines $findinsertpos $l]
1802 incr findinsertpos
1804 markheadline $l $id
1805 if {!$finddidsel} {
1806 findselectline $l
1807 set finddidsel 1
1811 proc findfiles {} {
1812 global selectedline numcommits lineid ctext
1813 global ffileline finddidsel parents nparents
1814 global findinprogress findstartline findinsertpos
1815 global treediffs fdiffids fdiffsneeded fdiffpos
1816 global findmergefiles
1818 if {$numcommits == 0} return
1820 if {[info exists selectedline]} {
1821 set l [expr {$selectedline + 1}]
1822 } else {
1823 set l 0
1825 set ffileline $l
1826 set findstartline $l
1827 set diffsneeded {}
1828 set fdiffsneeded {}
1829 while 1 {
1830 set id $lineid($l)
1831 if {$findmergefiles || $nparents($id) == 1} {
1832 foreach p $parents($id) {
1833 if {![info exists treediffs([list $id $p])]} {
1834 append diffsneeded "$id $p\n"
1835 lappend fdiffsneeded [list $id $p]
1839 if {[incr l] >= $numcommits} {
1840 set l 0
1842 if {$l == $findstartline} break
1845 # start off a git-diff-tree process if needed
1846 if {$diffsneeded ne {}} {
1847 if {[catch {
1848 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1849 } err ]} {
1850 error_popup "Error starting search process: $err"
1851 return
1853 catch {unset fdiffids}
1854 set fdiffpos 0
1855 fconfigure $df -blocking 0
1856 fileevent $df readable [list readfilediffs $df]
1859 set finddidsel 0
1860 set findinsertpos end
1861 set id $lineid($l)
1862 set p [lindex $parents($id) 0]
1863 . config -cursor watch
1864 settextcursor watch
1865 set findinprogress 1
1866 findcont [list $id $p]
1867 update
1870 proc readfilediffs {df} {
1871 global findids fdiffids fdiffs
1873 set n [gets $df line]
1874 if {$n < 0} {
1875 if {[eof $df]} {
1876 donefilediff
1877 if {[catch {close $df} err]} {
1878 stopfindproc
1879 bell
1880 error_popup "Error in git-diff-tree: $err"
1881 } elseif {[info exists findids]} {
1882 set ids $findids
1883 stopfindproc
1884 bell
1885 error_popup "Couldn't find diffs for {$ids}"
1888 return
1890 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1891 # start of a new string of diffs
1892 donefilediff
1893 set fdiffids [list $id $p]
1894 set fdiffs {}
1895 } elseif {[string match ":*" $line]} {
1896 lappend fdiffs [lindex $line 5]
1900 proc donefilediff {} {
1901 global fdiffids fdiffs treediffs findids
1902 global fdiffsneeded fdiffpos
1904 if {[info exists fdiffids]} {
1905 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1906 && $fdiffpos < [llength $fdiffsneeded]} {
1907 # git-diff-tree doesn't output anything for a commit
1908 # which doesn't change anything
1909 set nullids [lindex $fdiffsneeded $fdiffpos]
1910 set treediffs($nullids) {}
1911 if {[info exists findids] && $nullids eq $findids} {
1912 unset findids
1913 findcont $nullids
1915 incr fdiffpos
1917 incr fdiffpos
1919 if {![info exists treediffs($fdiffids)]} {
1920 set treediffs($fdiffids) $fdiffs
1922 if {[info exists findids] && $fdiffids eq $findids} {
1923 unset findids
1924 findcont $fdiffids
1929 proc findcont {ids} {
1930 global findids treediffs parents nparents
1931 global ffileline findstartline finddidsel
1932 global lineid numcommits matchinglines findinprogress
1933 global findmergefiles
1935 set id [lindex $ids 0]
1936 set p [lindex $ids 1]
1937 set pi [lsearch -exact $parents($id) $p]
1938 set l $ffileline
1939 while 1 {
1940 if {$findmergefiles || $nparents($id) == 1} {
1941 if {![info exists treediffs($ids)]} {
1942 set findids $ids
1943 set ffileline $l
1944 return
1946 set doesmatch 0
1947 foreach f $treediffs($ids) {
1948 set x [findmatches $f]
1949 if {$x != {}} {
1950 set doesmatch 1
1951 break
1954 if {$doesmatch} {
1955 insertmatch $l $id
1956 set pi $nparents($id)
1958 } else {
1959 set pi $nparents($id)
1961 if {[incr pi] >= $nparents($id)} {
1962 set pi 0
1963 if {[incr l] >= $numcommits} {
1964 set l 0
1966 if {$l == $findstartline} break
1967 set id $lineid($l)
1969 set p [lindex $parents($id) $pi]
1970 set ids [list $id $p]
1972 stopfindproc
1973 if {!$finddidsel} {
1974 bell
1978 # mark a commit as matching by putting a yellow background
1979 # behind the headline
1980 proc markheadline {l id} {
1981 global canv mainfont linehtag commitinfo
1983 set bbox [$canv bbox $linehtag($l)]
1984 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1985 $canv lower $t
1988 # mark the bits of a headline, author or date that match a find string
1989 proc markmatches {canv l str tag matches font} {
1990 set bbox [$canv bbox $tag]
1991 set x0 [lindex $bbox 0]
1992 set y0 [lindex $bbox 1]
1993 set y1 [lindex $bbox 3]
1994 foreach match $matches {
1995 set start [lindex $match 0]
1996 set end [lindex $match 1]
1997 if {$start > $end} continue
1998 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1999 set xlen [font measure $font [string range $str 0 [expr $end]]]
2000 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
2001 -outline {} -tags matches -fill yellow]
2002 $canv lower $t
2006 proc unmarkmatches {} {
2007 global matchinglines findids
2008 allcanvs delete matches
2009 catch {unset matchinglines}
2010 catch {unset findids}
2013 proc selcanvline {w x y} {
2014 global canv canvy0 ctext linespc
2015 global lineid linehtag linentag linedtag rowtextx
2016 set ymax [lindex [$canv cget -scrollregion] 3]
2017 if {$ymax == {}} return
2018 set yfrac [lindex [$canv yview] 0]
2019 set y [expr {$y + $yfrac * $ymax}]
2020 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2021 if {$l < 0} {
2022 set l 0
2024 if {$w eq $canv} {
2025 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2027 unmarkmatches
2028 selectline $l 1
2031 proc commit_descriptor {p} {
2032 global commitinfo
2033 set l "..."
2034 if {[info exists commitinfo($p)]} {
2035 set l [lindex $commitinfo($p) 0]
2037 return "$p ($l)"
2040 # append some text to the ctext widget, and make any SHA1 ID
2041 # that we know about be a clickable link.
2042 proc appendwithlinks {text} {
2043 global ctext idline linknum
2045 set start [$ctext index "end - 1c"]
2046 $ctext insert end $text
2047 $ctext insert end "\n"
2048 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2049 foreach l $links {
2050 set s [lindex $l 0]
2051 set e [lindex $l 1]
2052 set linkid [string range $text $s $e]
2053 if {![info exists idline($linkid)]} continue
2054 incr e
2055 $ctext tag add link "$start + $s c" "$start + $e c"
2056 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2057 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2058 incr linknum
2060 $ctext tag conf link -foreground blue -underline 1
2061 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2062 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2065 proc selectline {l isnew} {
2066 global canv canv2 canv3 ctext commitinfo selectedline
2067 global lineid linehtag linentag linedtag
2068 global canvy0 linespc parents nparents children
2069 global cflist currentid sha1entry
2070 global commentend idtags idline linknum
2072 $canv delete hover
2073 normalline
2074 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2075 $canv delete secsel
2076 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2077 -tags secsel -fill [$canv cget -selectbackground]]
2078 $canv lower $t
2079 $canv2 delete secsel
2080 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2081 -tags secsel -fill [$canv2 cget -selectbackground]]
2082 $canv2 lower $t
2083 $canv3 delete secsel
2084 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2085 -tags secsel -fill [$canv3 cget -selectbackground]]
2086 $canv3 lower $t
2087 set y [expr {$canvy0 + $l * $linespc}]
2088 set ymax [lindex [$canv cget -scrollregion] 3]
2089 set ytop [expr {$y - $linespc - 1}]
2090 set ybot [expr {$y + $linespc + 1}]
2091 set wnow [$canv yview]
2092 set wtop [expr [lindex $wnow 0] * $ymax]
2093 set wbot [expr [lindex $wnow 1] * $ymax]
2094 set wh [expr {$wbot - $wtop}]
2095 set newtop $wtop
2096 if {$ytop < $wtop} {
2097 if {$ybot < $wtop} {
2098 set newtop [expr {$y - $wh / 2.0}]
2099 } else {
2100 set newtop $ytop
2101 if {$newtop > $wtop - $linespc} {
2102 set newtop [expr {$wtop - $linespc}]
2105 } elseif {$ybot > $wbot} {
2106 if {$ytop > $wbot} {
2107 set newtop [expr {$y - $wh / 2.0}]
2108 } else {
2109 set newtop [expr {$ybot - $wh}]
2110 if {$newtop < $wtop + $linespc} {
2111 set newtop [expr {$wtop + $linespc}]
2115 if {$newtop != $wtop} {
2116 if {$newtop < 0} {
2117 set newtop 0
2119 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
2122 if {$isnew} {
2123 addtohistory [list selectline $l 0]
2126 set selectedline $l
2128 set id $lineid($l)
2129 set currentid $id
2130 $sha1entry delete 0 end
2131 $sha1entry insert 0 $id
2132 $sha1entry selection from 0
2133 $sha1entry selection to end
2135 $ctext conf -state normal
2136 $ctext delete 0.0 end
2137 set linknum 0
2138 $ctext mark set fmark.0 0.0
2139 $ctext mark gravity fmark.0 left
2140 set info $commitinfo($id)
2141 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
2142 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
2143 if {[info exists idtags($id)]} {
2144 $ctext insert end "Tags:"
2145 foreach tag $idtags($id) {
2146 $ctext insert end " $tag"
2148 $ctext insert end "\n"
2151 set comment {}
2152 if {[info exists parents($id)]} {
2153 foreach p $parents($id) {
2154 append comment "Parent: [commit_descriptor $p]\n"
2157 if {[info exists children($id)]} {
2158 foreach c $children($id) {
2159 append comment "Child: [commit_descriptor $c]\n"
2162 append comment "\n"
2163 append comment [lindex $info 5]
2165 # make anything that looks like a SHA1 ID be a clickable link
2166 appendwithlinks $comment
2168 $ctext tag delete Comments
2169 $ctext tag remove found 1.0 end
2170 $ctext conf -state disabled
2171 set commentend [$ctext index "end - 1c"]
2173 $cflist delete 0 end
2174 $cflist insert end "Comments"
2175 if {$nparents($id) == 1} {
2176 startdiff [concat $id $parents($id)]
2177 } elseif {$nparents($id) > 1} {
2178 mergediff $id
2182 proc selnextline {dir} {
2183 global selectedline
2184 if {![info exists selectedline]} return
2185 set l [expr $selectedline + $dir]
2186 unmarkmatches
2187 selectline $l 1
2190 proc unselectline {} {
2191 global selectedline
2193 catch {unset selectedline}
2194 allcanvs delete secsel
2197 proc addtohistory {cmd} {
2198 global history historyindex
2200 if {$historyindex > 0
2201 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2202 return
2205 if {$historyindex < [llength $history]} {
2206 set history [lreplace $history $historyindex end $cmd]
2207 } else {
2208 lappend history $cmd
2210 incr historyindex
2211 if {$historyindex > 1} {
2212 .ctop.top.bar.leftbut conf -state normal
2213 } else {
2214 .ctop.top.bar.leftbut conf -state disabled
2216 .ctop.top.bar.rightbut conf -state disabled
2219 proc goback {} {
2220 global history historyindex
2222 if {$historyindex > 1} {
2223 incr historyindex -1
2224 set cmd [lindex $history [expr {$historyindex - 1}]]
2225 eval $cmd
2226 .ctop.top.bar.rightbut conf -state normal
2228 if {$historyindex <= 1} {
2229 .ctop.top.bar.leftbut conf -state disabled
2233 proc goforw {} {
2234 global history historyindex
2236 if {$historyindex < [llength $history]} {
2237 set cmd [lindex $history $historyindex]
2238 incr historyindex
2239 eval $cmd
2240 .ctop.top.bar.leftbut conf -state normal
2242 if {$historyindex >= [llength $history]} {
2243 .ctop.top.bar.rightbut conf -state disabled
2247 proc mergediff {id} {
2248 global parents diffmergeid diffmergegca mergefilelist diffpindex
2250 set diffmergeid $id
2251 set diffpindex -1
2252 set diffmergegca [findgca $parents($id)]
2253 if {[info exists mergefilelist($id)]} {
2254 if {$mergefilelist($id) ne {}} {
2255 showmergediff
2257 } else {
2258 contmergediff {}
2262 proc findgca {ids} {
2263 set gca {}
2264 foreach id $ids {
2265 if {$gca eq {}} {
2266 set gca $id
2267 } else {
2268 if {[catch {
2269 set gca [exec git-merge-base $gca $id]
2270 } err]} {
2271 return {}
2275 return $gca
2278 proc contmergediff {ids} {
2279 global diffmergeid diffpindex parents nparents diffmergegca
2280 global treediffs mergefilelist diffids treepending
2282 # diff the child against each of the parents, and diff
2283 # each of the parents against the GCA.
2284 while 1 {
2285 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2286 set ids [list [lindex $ids 1] $diffmergegca]
2287 } else {
2288 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2289 set p [lindex $parents($diffmergeid) $diffpindex]
2290 set ids [list $diffmergeid $p]
2292 if {![info exists treediffs($ids)]} {
2293 set diffids $ids
2294 if {![info exists treepending]} {
2295 gettreediffs $ids
2297 return
2301 # If a file in some parent is different from the child and also
2302 # different from the GCA, then it's interesting.
2303 # If we don't have a GCA, then a file is interesting if it is
2304 # different from the child in all the parents.
2305 if {$diffmergegca ne {}} {
2306 set files {}
2307 foreach p $parents($diffmergeid) {
2308 set gcadiffs $treediffs([list $p $diffmergegca])
2309 foreach f $treediffs([list $diffmergeid $p]) {
2310 if {[lsearch -exact $files $f] < 0
2311 && [lsearch -exact $gcadiffs $f] >= 0} {
2312 lappend files $f
2316 set files [lsort $files]
2317 } else {
2318 set p [lindex $parents($diffmergeid) 0]
2319 set files $treediffs([list $diffmergeid $p])
2320 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2321 set p [lindex $parents($diffmergeid) $i]
2322 set df $treediffs([list $diffmergeid $p])
2323 set nf {}
2324 foreach f $files {
2325 if {[lsearch -exact $df $f] >= 0} {
2326 lappend nf $f
2329 set files $nf
2333 set mergefilelist($diffmergeid) $files
2334 if {$files ne {}} {
2335 showmergediff
2339 proc showmergediff {} {
2340 global cflist diffmergeid mergefilelist parents
2341 global diffopts diffinhunk currentfile currenthunk filelines
2342 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2344 set files $mergefilelist($diffmergeid)
2345 foreach f $files {
2346 $cflist insert end $f
2348 set env(GIT_DIFF_OPTS) $diffopts
2349 set flist {}
2350 catch {unset currentfile}
2351 catch {unset currenthunk}
2352 catch {unset filelines}
2353 catch {unset groupfilenum}
2354 catch {unset grouphunks}
2355 set groupfilelast -1
2356 foreach p $parents($diffmergeid) {
2357 set cmd [list | git-diff-tree -p $p $diffmergeid]
2358 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2359 if {[catch {set f [open $cmd r]} err]} {
2360 error_popup "Error getting diffs: $err"
2361 foreach f $flist {
2362 catch {close $f}
2364 return
2366 lappend flist $f
2367 set ids [list $diffmergeid $p]
2368 set mergefds($ids) $f
2369 set diffinhunk($ids) 0
2370 set diffblocked($ids) 0
2371 fconfigure $f -blocking 0
2372 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2376 proc getmergediffline {f ids id} {
2377 global diffmergeid diffinhunk diffoldlines diffnewlines
2378 global currentfile currenthunk
2379 global diffoldstart diffnewstart diffoldlno diffnewlno
2380 global diffblocked mergefilelist
2381 global noldlines nnewlines difflcounts filelines
2383 set n [gets $f line]
2384 if {$n < 0} {
2385 if {![eof $f]} return
2388 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2389 if {$n < 0} {
2390 close $f
2392 return
2395 if {$diffinhunk($ids) != 0} {
2396 set fi $currentfile($ids)
2397 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2398 # continuing an existing hunk
2399 set line [string range $line 1 end]
2400 set p [lindex $ids 1]
2401 if {$match eq "-" || $match eq " "} {
2402 set filelines($p,$fi,$diffoldlno($ids)) $line
2403 incr diffoldlno($ids)
2405 if {$match eq "+" || $match eq " "} {
2406 set filelines($id,$fi,$diffnewlno($ids)) $line
2407 incr diffnewlno($ids)
2409 if {$match eq " "} {
2410 if {$diffinhunk($ids) == 2} {
2411 lappend difflcounts($ids) \
2412 [list $noldlines($ids) $nnewlines($ids)]
2413 set noldlines($ids) 0
2414 set diffinhunk($ids) 1
2416 incr noldlines($ids)
2417 } elseif {$match eq "-" || $match eq "+"} {
2418 if {$diffinhunk($ids) == 1} {
2419 lappend difflcounts($ids) [list $noldlines($ids)]
2420 set noldlines($ids) 0
2421 set nnewlines($ids) 0
2422 set diffinhunk($ids) 2
2424 if {$match eq "-"} {
2425 incr noldlines($ids)
2426 } else {
2427 incr nnewlines($ids)
2430 # and if it's \ No newline at end of line, then what?
2431 return
2433 # end of a hunk
2434 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2435 lappend difflcounts($ids) [list $noldlines($ids)]
2436 } elseif {$diffinhunk($ids) == 2
2437 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2438 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2440 set currenthunk($ids) [list $currentfile($ids) \
2441 $diffoldstart($ids) $diffnewstart($ids) \
2442 $diffoldlno($ids) $diffnewlno($ids) \
2443 $difflcounts($ids)]
2444 set diffinhunk($ids) 0
2445 # -1 = need to block, 0 = unblocked, 1 = is blocked
2446 set diffblocked($ids) -1
2447 processhunks
2448 if {$diffblocked($ids) == -1} {
2449 fileevent $f readable {}
2450 set diffblocked($ids) 1
2454 if {$n < 0} {
2455 # eof
2456 if {!$diffblocked($ids)} {
2457 close $f
2458 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2459 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2460 processhunks
2462 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2463 # start of a new file
2464 set currentfile($ids) \
2465 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2466 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2467 $line match f1l f1c f2l f2c rest]} {
2468 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2469 # start of a new hunk
2470 if {$f1l == 0 && $f1c == 0} {
2471 set f1l 1
2473 if {$f2l == 0 && $f2c == 0} {
2474 set f2l 1
2476 set diffinhunk($ids) 1
2477 set diffoldstart($ids) $f1l
2478 set diffnewstart($ids) $f2l
2479 set diffoldlno($ids) $f1l
2480 set diffnewlno($ids) $f2l
2481 set difflcounts($ids) {}
2482 set noldlines($ids) 0
2483 set nnewlines($ids) 0
2488 proc processhunks {} {
2489 global diffmergeid parents nparents currenthunk
2490 global mergefilelist diffblocked mergefds
2491 global grouphunks grouplinestart grouplineend groupfilenum
2493 set nfiles [llength $mergefilelist($diffmergeid)]
2494 while 1 {
2495 set fi $nfiles
2496 set lno 0
2497 # look for the earliest hunk
2498 foreach p $parents($diffmergeid) {
2499 set ids [list $diffmergeid $p]
2500 if {![info exists currenthunk($ids)]} return
2501 set i [lindex $currenthunk($ids) 0]
2502 set l [lindex $currenthunk($ids) 2]
2503 if {$i < $fi || ($i == $fi && $l < $lno)} {
2504 set fi $i
2505 set lno $l
2506 set pi $p
2510 if {$fi < $nfiles} {
2511 set ids [list $diffmergeid $pi]
2512 set hunk $currenthunk($ids)
2513 unset currenthunk($ids)
2514 if {$diffblocked($ids) > 0} {
2515 fileevent $mergefds($ids) readable \
2516 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2518 set diffblocked($ids) 0
2520 if {[info exists groupfilenum] && $groupfilenum == $fi
2521 && $lno <= $grouplineend} {
2522 # add this hunk to the pending group
2523 lappend grouphunks($pi) $hunk
2524 set endln [lindex $hunk 4]
2525 if {$endln > $grouplineend} {
2526 set grouplineend $endln
2528 continue
2532 # succeeding stuff doesn't belong in this group, so
2533 # process the group now
2534 if {[info exists groupfilenum]} {
2535 processgroup
2536 unset groupfilenum
2537 unset grouphunks
2540 if {$fi >= $nfiles} break
2542 # start a new group
2543 set groupfilenum $fi
2544 set grouphunks($pi) [list $hunk]
2545 set grouplinestart $lno
2546 set grouplineend [lindex $hunk 4]
2550 proc processgroup {} {
2551 global groupfilelast groupfilenum difffilestart
2552 global mergefilelist diffmergeid ctext filelines
2553 global parents diffmergeid diffoffset
2554 global grouphunks grouplinestart grouplineend nparents
2555 global mergemax
2557 $ctext conf -state normal
2558 set id $diffmergeid
2559 set f $groupfilenum
2560 if {$groupfilelast != $f} {
2561 $ctext insert end "\n"
2562 set here [$ctext index "end - 1c"]
2563 set difffilestart($f) $here
2564 set mark fmark.[expr {$f + 1}]
2565 $ctext mark set $mark $here
2566 $ctext mark gravity $mark left
2567 set header [lindex $mergefilelist($id) $f]
2568 set l [expr {(78 - [string length $header]) / 2}]
2569 set pad [string range "----------------------------------------" 1 $l]
2570 $ctext insert end "$pad $header $pad\n" filesep
2571 set groupfilelast $f
2572 foreach p $parents($id) {
2573 set diffoffset($p) 0
2577 $ctext insert end "@@" msep
2578 set nlines [expr {$grouplineend - $grouplinestart}]
2579 set events {}
2580 set pnum 0
2581 foreach p $parents($id) {
2582 set startline [expr {$grouplinestart + $diffoffset($p)}]
2583 set ol $startline
2584 set nl $grouplinestart
2585 if {[info exists grouphunks($p)]} {
2586 foreach h $grouphunks($p) {
2587 set l [lindex $h 2]
2588 if {$nl < $l} {
2589 for {} {$nl < $l} {incr nl} {
2590 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2591 incr ol
2594 foreach chunk [lindex $h 5] {
2595 if {[llength $chunk] == 2} {
2596 set olc [lindex $chunk 0]
2597 set nlc [lindex $chunk 1]
2598 set nnl [expr {$nl + $nlc}]
2599 lappend events [list $nl $nnl $pnum $olc $nlc]
2600 incr ol $olc
2601 set nl $nnl
2602 } else {
2603 incr ol [lindex $chunk 0]
2604 incr nl [lindex $chunk 0]
2609 if {$nl < $grouplineend} {
2610 for {} {$nl < $grouplineend} {incr nl} {
2611 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2612 incr ol
2615 set nlines [expr {$ol - $startline}]
2616 $ctext insert end " -$startline,$nlines" msep
2617 incr pnum
2620 set nlines [expr {$grouplineend - $grouplinestart}]
2621 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2623 set events [lsort -integer -index 0 $events]
2624 set nevents [llength $events]
2625 set nmerge $nparents($diffmergeid)
2626 set l $grouplinestart
2627 for {set i 0} {$i < $nevents} {set i $j} {
2628 set nl [lindex $events $i 0]
2629 while {$l < $nl} {
2630 $ctext insert end " $filelines($id,$f,$l)\n"
2631 incr l
2633 set e [lindex $events $i]
2634 set enl [lindex $e 1]
2635 set j $i
2636 set active {}
2637 while 1 {
2638 set pnum [lindex $e 2]
2639 set olc [lindex $e 3]
2640 set nlc [lindex $e 4]
2641 if {![info exists delta($pnum)]} {
2642 set delta($pnum) [expr {$olc - $nlc}]
2643 lappend active $pnum
2644 } else {
2645 incr delta($pnum) [expr {$olc - $nlc}]
2647 if {[incr j] >= $nevents} break
2648 set e [lindex $events $j]
2649 if {[lindex $e 0] >= $enl} break
2650 if {[lindex $e 1] > $enl} {
2651 set enl [lindex $e 1]
2654 set nlc [expr {$enl - $l}]
2655 set ncol mresult
2656 set bestpn -1
2657 if {[llength $active] == $nmerge - 1} {
2658 # no diff for one of the parents, i.e. it's identical
2659 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2660 if {![info exists delta($pnum)]} {
2661 if {$pnum < $mergemax} {
2662 lappend ncol m$pnum
2663 } else {
2664 lappend ncol mmax
2666 break
2669 } elseif {[llength $active] == $nmerge} {
2670 # all parents are different, see if one is very similar
2671 set bestsim 30
2672 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2673 set sim [similarity $pnum $l $nlc $f \
2674 [lrange $events $i [expr {$j-1}]]]
2675 if {$sim > $bestsim} {
2676 set bestsim $sim
2677 set bestpn $pnum
2680 if {$bestpn >= 0} {
2681 lappend ncol m$bestpn
2684 set pnum -1
2685 foreach p $parents($id) {
2686 incr pnum
2687 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2688 set olc [expr {$nlc + $delta($pnum)}]
2689 set ol [expr {$l + $diffoffset($p)}]
2690 incr diffoffset($p) $delta($pnum)
2691 unset delta($pnum)
2692 for {} {$olc > 0} {incr olc -1} {
2693 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2694 incr ol
2697 set endl [expr {$l + $nlc}]
2698 if {$bestpn >= 0} {
2699 # show this pretty much as a normal diff
2700 set p [lindex $parents($id) $bestpn]
2701 set ol [expr {$l + $diffoffset($p)}]
2702 incr diffoffset($p) $delta($bestpn)
2703 unset delta($bestpn)
2704 for {set k $i} {$k < $j} {incr k} {
2705 set e [lindex $events $k]
2706 if {[lindex $e 2] != $bestpn} continue
2707 set nl [lindex $e 0]
2708 set ol [expr {$ol + $nl - $l}]
2709 for {} {$l < $nl} {incr l} {
2710 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2712 set c [lindex $e 3]
2713 for {} {$c > 0} {incr c -1} {
2714 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2715 incr ol
2717 set nl [lindex $e 1]
2718 for {} {$l < $nl} {incr l} {
2719 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2723 for {} {$l < $endl} {incr l} {
2724 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2727 while {$l < $grouplineend} {
2728 $ctext insert end " $filelines($id,$f,$l)\n"
2729 incr l
2731 $ctext conf -state disabled
2734 proc similarity {pnum l nlc f events} {
2735 global diffmergeid parents diffoffset filelines
2737 set id $diffmergeid
2738 set p [lindex $parents($id) $pnum]
2739 set ol [expr {$l + $diffoffset($p)}]
2740 set endl [expr {$l + $nlc}]
2741 set same 0
2742 set diff 0
2743 foreach e $events {
2744 if {[lindex $e 2] != $pnum} continue
2745 set nl [lindex $e 0]
2746 set ol [expr {$ol + $nl - $l}]
2747 for {} {$l < $nl} {incr l} {
2748 incr same [string length $filelines($id,$f,$l)]
2749 incr same
2751 set oc [lindex $e 3]
2752 for {} {$oc > 0} {incr oc -1} {
2753 incr diff [string length $filelines($p,$f,$ol)]
2754 incr diff
2755 incr ol
2757 set nl [lindex $e 1]
2758 for {} {$l < $nl} {incr l} {
2759 incr diff [string length $filelines($id,$f,$l)]
2760 incr diff
2763 for {} {$l < $endl} {incr l} {
2764 incr same [string length $filelines($id,$f,$l)]
2765 incr same
2767 if {$same == 0} {
2768 return 0
2770 return [expr {200 * $same / (2 * $same + $diff)}]
2773 proc startdiff {ids} {
2774 global treediffs diffids treepending diffmergeid
2776 set diffids $ids
2777 catch {unset diffmergeid}
2778 if {![info exists treediffs($ids)]} {
2779 if {![info exists treepending]} {
2780 gettreediffs $ids
2782 } else {
2783 addtocflist $ids
2787 proc addtocflist {ids} {
2788 global treediffs cflist
2789 foreach f $treediffs($ids) {
2790 $cflist insert end $f
2792 getblobdiffs $ids
2795 proc gettreediffs {ids} {
2796 global treediff parents treepending
2797 set treepending $ids
2798 set treediff {}
2799 set id [lindex $ids 0]
2800 set p [lindex $ids 1]
2801 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2802 fconfigure $gdtf -blocking 0
2803 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2806 proc gettreediffline {gdtf ids} {
2807 global treediff treediffs treepending diffids diffmergeid
2809 set n [gets $gdtf line]
2810 if {$n < 0} {
2811 if {![eof $gdtf]} return
2812 close $gdtf
2813 set treediffs($ids) $treediff
2814 unset treepending
2815 if {$ids != $diffids} {
2816 gettreediffs $diffids
2817 } else {
2818 if {[info exists diffmergeid]} {
2819 contmergediff $ids
2820 } else {
2821 addtocflist $ids
2824 return
2826 set file [lindex $line 5]
2827 lappend treediff $file
2830 proc getblobdiffs {ids} {
2831 global diffopts blobdifffd diffids env curdifftag curtagstart
2832 global difffilestart nextupdate diffinhdr treediffs
2834 set id [lindex $ids 0]
2835 set p [lindex $ids 1]
2836 set env(GIT_DIFF_OPTS) $diffopts
2837 set cmd [list | git-diff-tree -r -p -C $p $id]
2838 if {[catch {set bdf [open $cmd r]} err]} {
2839 puts "error getting diffs: $err"
2840 return
2842 set diffinhdr 0
2843 fconfigure $bdf -blocking 0
2844 set blobdifffd($ids) $bdf
2845 set curdifftag Comments
2846 set curtagstart 0.0
2847 catch {unset difffilestart}
2848 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2849 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2852 proc getblobdiffline {bdf ids} {
2853 global diffids blobdifffd ctext curdifftag curtagstart
2854 global diffnexthead diffnextnote difffilestart
2855 global nextupdate diffinhdr treediffs
2856 global gaudydiff
2858 set n [gets $bdf line]
2859 if {$n < 0} {
2860 if {[eof $bdf]} {
2861 close $bdf
2862 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2863 $ctext tag add $curdifftag $curtagstart end
2866 return
2868 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2869 return
2871 $ctext conf -state normal
2872 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2873 # start of a new file
2874 $ctext insert end "\n"
2875 $ctext tag add $curdifftag $curtagstart end
2876 set curtagstart [$ctext index "end - 1c"]
2877 set header $newname
2878 set here [$ctext index "end - 1c"]
2879 set i [lsearch -exact $treediffs($diffids) $fname]
2880 if {$i >= 0} {
2881 set difffilestart($i) $here
2882 incr i
2883 $ctext mark set fmark.$i $here
2884 $ctext mark gravity fmark.$i left
2886 if {$newname != $fname} {
2887 set i [lsearch -exact $treediffs($diffids) $newname]
2888 if {$i >= 0} {
2889 set difffilestart($i) $here
2890 incr i
2891 $ctext mark set fmark.$i $here
2892 $ctext mark gravity fmark.$i left
2895 set curdifftag "f:$fname"
2896 $ctext tag delete $curdifftag
2897 set l [expr {(78 - [string length $header]) / 2}]
2898 set pad [string range "----------------------------------------" 1 $l]
2899 $ctext insert end "$pad $header $pad\n" filesep
2900 set diffinhdr 1
2901 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2902 set diffinhdr 0
2903 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2904 $line match f1l f1c f2l f2c rest]} {
2905 if {$gaudydiff} {
2906 $ctext insert end "\t" hunksep
2907 $ctext insert end " $f1l " d0 " $f2l " d1
2908 $ctext insert end " $rest \n" hunksep
2909 } else {
2910 $ctext insert end "$line\n" hunksep
2912 set diffinhdr 0
2913 } else {
2914 set x [string range $line 0 0]
2915 if {$x == "-" || $x == "+"} {
2916 set tag [expr {$x == "+"}]
2917 if {$gaudydiff} {
2918 set line [string range $line 1 end]
2920 $ctext insert end "$line\n" d$tag
2921 } elseif {$x == " "} {
2922 if {$gaudydiff} {
2923 set line [string range $line 1 end]
2925 $ctext insert end "$line\n"
2926 } elseif {$diffinhdr || $x == "\\"} {
2927 # e.g. "\ No newline at end of file"
2928 $ctext insert end "$line\n" filesep
2929 } else {
2930 # Something else we don't recognize
2931 if {$curdifftag != "Comments"} {
2932 $ctext insert end "\n"
2933 $ctext tag add $curdifftag $curtagstart end
2934 set curtagstart [$ctext index "end - 1c"]
2935 set curdifftag Comments
2937 $ctext insert end "$line\n" filesep
2940 $ctext conf -state disabled
2941 if {[clock clicks -milliseconds] >= $nextupdate} {
2942 incr nextupdate 100
2943 fileevent $bdf readable {}
2944 update
2945 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2949 proc nextfile {} {
2950 global difffilestart ctext
2951 set here [$ctext index @0,0]
2952 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2953 if {[$ctext compare $difffilestart($i) > $here]} {
2954 if {![info exists pos]
2955 || [$ctext compare $difffilestart($i) < $pos]} {
2956 set pos $difffilestart($i)
2960 if {[info exists pos]} {
2961 $ctext yview $pos
2965 proc listboxsel {} {
2966 global ctext cflist currentid
2967 if {![info exists currentid]} return
2968 set sel [lsort [$cflist curselection]]
2969 if {$sel eq {}} return
2970 set first [lindex $sel 0]
2971 catch {$ctext yview fmark.$first}
2974 proc setcoords {} {
2975 global linespc charspc canvx0 canvy0 mainfont
2976 global xspc1 xspc2 lthickness
2978 set linespc [font metrics $mainfont -linespace]
2979 set charspc [font measure $mainfont "m"]
2980 set canvy0 [expr 3 + 0.5 * $linespc]
2981 set canvx0 [expr 3 + 0.5 * $linespc]
2982 set lthickness [expr {int($linespc / 9) + 1}]
2983 set xspc1(0) $linespc
2984 set xspc2 $linespc
2987 proc redisplay {} {
2988 global stopped redisplaying phase
2989 if {$stopped > 1} return
2990 if {$phase == "getcommits"} return
2991 set redisplaying 1
2992 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2993 set stopped 1
2994 } else {
2995 drawgraph
2999 proc incrfont {inc} {
3000 global mainfont namefont textfont ctext canv phase
3001 global stopped entries
3002 unmarkmatches
3003 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
3004 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
3005 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
3006 setcoords
3007 $ctext conf -font $textfont
3008 $ctext tag conf filesep -font [concat $textfont bold]
3009 foreach e $entries {
3010 $e conf -font $mainfont
3012 if {$phase == "getcommits"} {
3013 $canv itemconf textitems -font $mainfont
3015 redisplay
3018 proc clearsha1 {} {
3019 global sha1entry sha1string
3020 if {[string length $sha1string] == 40} {
3021 $sha1entry delete 0 end
3025 proc sha1change {n1 n2 op} {
3026 global sha1string currentid sha1but
3027 if {$sha1string == {}
3028 || ([info exists currentid] && $sha1string == $currentid)} {
3029 set state disabled
3030 } else {
3031 set state normal
3033 if {[$sha1but cget -state] == $state} return
3034 if {$state == "normal"} {
3035 $sha1but conf -state normal -relief raised -text "Goto: "
3036 } else {
3037 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3041 proc gotocommit {} {
3042 global sha1string currentid idline tagids
3043 global lineid numcommits
3045 if {$sha1string == {}
3046 || ([info exists currentid] && $sha1string == $currentid)} return
3047 if {[info exists tagids($sha1string)]} {
3048 set id $tagids($sha1string)
3049 } else {
3050 set id [string tolower $sha1string]
3051 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3052 set matches {}
3053 for {set l 0} {$l < $numcommits} {incr l} {
3054 if {[string match $id* $lineid($l)]} {
3055 lappend matches $lineid($l)
3058 if {$matches ne {}} {
3059 if {[llength $matches] > 1} {
3060 error_popup "Short SHA1 id $id is ambiguous"
3061 return
3063 set id [lindex $matches 0]
3067 if {[info exists idline($id)]} {
3068 selectline $idline($id) 1
3069 return
3071 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3072 set type "SHA1 id"
3073 } else {
3074 set type "Tag"
3076 error_popup "$type $sha1string is not known"
3079 proc lineenter {x y id} {
3080 global hoverx hovery hoverid hovertimer
3081 global commitinfo canv
3083 if {![info exists commitinfo($id)]} return
3084 set hoverx $x
3085 set hovery $y
3086 set hoverid $id
3087 if {[info exists hovertimer]} {
3088 after cancel $hovertimer
3090 set hovertimer [after 500 linehover]
3091 $canv delete hover
3094 proc linemotion {x y id} {
3095 global hoverx hovery hoverid hovertimer
3097 if {[info exists hoverid] && $id == $hoverid} {
3098 set hoverx $x
3099 set hovery $y
3100 if {[info exists hovertimer]} {
3101 after cancel $hovertimer
3103 set hovertimer [after 500 linehover]
3107 proc lineleave {id} {
3108 global hoverid hovertimer canv
3110 if {[info exists hoverid] && $id == $hoverid} {
3111 $canv delete hover
3112 if {[info exists hovertimer]} {
3113 after cancel $hovertimer
3114 unset hovertimer
3116 unset hoverid
3120 proc linehover {} {
3121 global hoverx hovery hoverid hovertimer
3122 global canv linespc lthickness
3123 global commitinfo mainfont
3125 set text [lindex $commitinfo($hoverid) 0]
3126 set ymax [lindex [$canv cget -scrollregion] 3]
3127 if {$ymax == {}} return
3128 set yfrac [lindex [$canv yview] 0]
3129 set x [expr {$hoverx + 2 * $linespc}]
3130 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3131 set x0 [expr {$x - 2 * $lthickness}]
3132 set y0 [expr {$y - 2 * $lthickness}]
3133 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3134 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3135 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3136 -fill \#ffff80 -outline black -width 1 -tags hover]
3137 $canv raise $t
3138 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
3139 $canv raise $t
3142 proc clickisonarrow {id y} {
3143 global mainline mainlinearrow sidelines lthickness
3145 set thresh [expr {2 * $lthickness + 6}]
3146 if {[info exists mainline($id)]} {
3147 if {$mainlinearrow($id) ne "none"} {
3148 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3149 return "up"
3153 if {[info exists sidelines($id)]} {
3154 foreach ls $sidelines($id) {
3155 set coords [lindex $ls 0]
3156 set arrow [lindex $ls 2]
3157 if {$arrow eq "first" || $arrow eq "both"} {
3158 if {abs([lindex $coords 1] - $y) < $thresh} {
3159 return "up"
3162 if {$arrow eq "last" || $arrow eq "both"} {
3163 if {abs([lindex $coords end] - $y) < $thresh} {
3164 return "down"
3169 return {}
3172 proc arrowjump {id dirn y} {
3173 global mainline sidelines canv
3175 set yt {}
3176 if {$dirn eq "down"} {
3177 if {[info exists mainline($id)]} {
3178 set y1 [lindex $mainline($id) 1]
3179 if {$y1 > $y} {
3180 set yt $y1
3183 if {[info exists sidelines($id)]} {
3184 foreach ls $sidelines($id) {
3185 set y1 [lindex $ls 0 1]
3186 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3187 set yt $y1
3191 } else {
3192 if {[info exists sidelines($id)]} {
3193 foreach ls $sidelines($id) {
3194 set y1 [lindex $ls 0 end]
3195 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3196 set yt $y1
3201 if {$yt eq {}} return
3202 set ymax [lindex [$canv cget -scrollregion] 3]
3203 if {$ymax eq {} || $ymax <= 0} return
3204 set view [$canv yview]
3205 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3206 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3207 if {$yfrac < 0} {
3208 set yfrac 0
3210 $canv yview moveto $yfrac
3213 proc lineclick {x y id isnew} {
3214 global ctext commitinfo children cflist canv thickerline
3216 unmarkmatches
3217 unselectline
3218 normalline
3219 $canv delete hover
3220 # draw this line thicker than normal
3221 drawlines $id 1
3222 set thickerline $id
3223 if {$isnew} {
3224 set ymax [lindex [$canv cget -scrollregion] 3]
3225 if {$ymax eq {}} return
3226 set yfrac [lindex [$canv yview] 0]
3227 set y [expr {$y + $yfrac * $ymax}]
3229 set dirn [clickisonarrow $id $y]
3230 if {$dirn ne {}} {
3231 arrowjump $id $dirn $y
3232 return
3235 if {$isnew} {
3236 addtohistory [list lineclick $x $y $id 0]
3238 # fill the details pane with info about this line
3239 $ctext conf -state normal
3240 $ctext delete 0.0 end
3241 $ctext tag conf link -foreground blue -underline 1
3242 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3243 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3244 $ctext insert end "Parent:\t"
3245 $ctext insert end $id [list link link0]
3246 $ctext tag bind link0 <1> [list selbyid $id]
3247 set info $commitinfo($id)
3248 $ctext insert end "\n\t[lindex $info 0]\n"
3249 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3250 $ctext insert end "\tDate:\t[lindex $info 2]\n"
3251 if {[info exists children($id)]} {
3252 $ctext insert end "\nChildren:"
3253 set i 0
3254 foreach child $children($id) {
3255 incr i
3256 set info $commitinfo($child)
3257 $ctext insert end "\n\t"
3258 $ctext insert end $child [list link link$i]
3259 $ctext tag bind link$i <1> [list selbyid $child]
3260 $ctext insert end "\n\t[lindex $info 0]"
3261 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3262 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
3265 $ctext conf -state disabled
3267 $cflist delete 0 end
3270 proc normalline {} {
3271 global thickerline
3272 if {[info exists thickerline]} {
3273 drawlines $thickerline 0
3274 unset thickerline
3278 proc selbyid {id} {
3279 global idline
3280 if {[info exists idline($id)]} {
3281 selectline $idline($id) 1
3285 proc mstime {} {
3286 global startmstime
3287 if {![info exists startmstime]} {
3288 set startmstime [clock clicks -milliseconds]
3290 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3293 proc rowmenu {x y id} {
3294 global rowctxmenu idline selectedline rowmenuid
3296 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3297 set state disabled
3298 } else {
3299 set state normal
3301 $rowctxmenu entryconfigure 0 -state $state
3302 $rowctxmenu entryconfigure 1 -state $state
3303 $rowctxmenu entryconfigure 2 -state $state
3304 set rowmenuid $id
3305 tk_popup $rowctxmenu $x $y
3308 proc diffvssel {dirn} {
3309 global rowmenuid selectedline lineid
3311 if {![info exists selectedline]} return
3312 if {$dirn} {
3313 set oldid $lineid($selectedline)
3314 set newid $rowmenuid
3315 } else {
3316 set oldid $rowmenuid
3317 set newid $lineid($selectedline)
3319 addtohistory [list doseldiff $oldid $newid]
3320 doseldiff $oldid $newid
3323 proc doseldiff {oldid newid} {
3324 global ctext cflist
3325 global commitinfo
3327 $ctext conf -state normal
3328 $ctext delete 0.0 end
3329 $ctext mark set fmark.0 0.0
3330 $ctext mark gravity fmark.0 left
3331 $cflist delete 0 end
3332 $cflist insert end "Top"
3333 $ctext insert end "From "
3334 $ctext tag conf link -foreground blue -underline 1
3335 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3336 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3337 $ctext tag bind link0 <1> [list selbyid $oldid]
3338 $ctext insert end $oldid [list link link0]
3339 $ctext insert end "\n "
3340 $ctext insert end [lindex $commitinfo($oldid) 0]
3341 $ctext insert end "\n\nTo "
3342 $ctext tag bind link1 <1> [list selbyid $newid]
3343 $ctext insert end $newid [list link link1]
3344 $ctext insert end "\n "
3345 $ctext insert end [lindex $commitinfo($newid) 0]
3346 $ctext insert end "\n"
3347 $ctext conf -state disabled
3348 $ctext tag delete Comments
3349 $ctext tag remove found 1.0 end
3350 startdiff [list $newid $oldid]
3353 proc mkpatch {} {
3354 global rowmenuid currentid commitinfo patchtop patchnum
3356 if {![info exists currentid]} return
3357 set oldid $currentid
3358 set oldhead [lindex $commitinfo($oldid) 0]
3359 set newid $rowmenuid
3360 set newhead [lindex $commitinfo($newid) 0]
3361 set top .patch
3362 set patchtop $top
3363 catch {destroy $top}
3364 toplevel $top
3365 label $top.title -text "Generate patch"
3366 grid $top.title - -pady 10
3367 label $top.from -text "From:"
3368 entry $top.fromsha1 -width 40 -relief flat
3369 $top.fromsha1 insert 0 $oldid
3370 $top.fromsha1 conf -state readonly
3371 grid $top.from $top.fromsha1 -sticky w
3372 entry $top.fromhead -width 60 -relief flat
3373 $top.fromhead insert 0 $oldhead
3374 $top.fromhead conf -state readonly
3375 grid x $top.fromhead -sticky w
3376 label $top.to -text "To:"
3377 entry $top.tosha1 -width 40 -relief flat
3378 $top.tosha1 insert 0 $newid
3379 $top.tosha1 conf -state readonly
3380 grid $top.to $top.tosha1 -sticky w
3381 entry $top.tohead -width 60 -relief flat
3382 $top.tohead insert 0 $newhead
3383 $top.tohead conf -state readonly
3384 grid x $top.tohead -sticky w
3385 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3386 grid $top.rev x -pady 10
3387 label $top.flab -text "Output file:"
3388 entry $top.fname -width 60
3389 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3390 incr patchnum
3391 grid $top.flab $top.fname -sticky w
3392 frame $top.buts
3393 button $top.buts.gen -text "Generate" -command mkpatchgo
3394 button $top.buts.can -text "Cancel" -command mkpatchcan
3395 grid $top.buts.gen $top.buts.can
3396 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3397 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3398 grid $top.buts - -pady 10 -sticky ew
3399 focus $top.fname
3402 proc mkpatchrev {} {
3403 global patchtop
3405 set oldid [$patchtop.fromsha1 get]
3406 set oldhead [$patchtop.fromhead get]
3407 set newid [$patchtop.tosha1 get]
3408 set newhead [$patchtop.tohead get]
3409 foreach e [list fromsha1 fromhead tosha1 tohead] \
3410 v [list $newid $newhead $oldid $oldhead] {
3411 $patchtop.$e conf -state normal
3412 $patchtop.$e delete 0 end
3413 $patchtop.$e insert 0 $v
3414 $patchtop.$e conf -state readonly
3418 proc mkpatchgo {} {
3419 global patchtop
3421 set oldid [$patchtop.fromsha1 get]
3422 set newid [$patchtop.tosha1 get]
3423 set fname [$patchtop.fname get]
3424 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3425 error_popup "Error creating patch: $err"
3427 catch {destroy $patchtop}
3428 unset patchtop
3431 proc mkpatchcan {} {
3432 global patchtop
3434 catch {destroy $patchtop}
3435 unset patchtop
3438 proc mktag {} {
3439 global rowmenuid mktagtop commitinfo
3441 set top .maketag
3442 set mktagtop $top
3443 catch {destroy $top}
3444 toplevel $top
3445 label $top.title -text "Create tag"
3446 grid $top.title - -pady 10
3447 label $top.id -text "ID:"
3448 entry $top.sha1 -width 40 -relief flat
3449 $top.sha1 insert 0 $rowmenuid
3450 $top.sha1 conf -state readonly
3451 grid $top.id $top.sha1 -sticky w
3452 entry $top.head -width 60 -relief flat
3453 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3454 $top.head conf -state readonly
3455 grid x $top.head -sticky w
3456 label $top.tlab -text "Tag name:"
3457 entry $top.tag -width 60
3458 grid $top.tlab $top.tag -sticky w
3459 frame $top.buts
3460 button $top.buts.gen -text "Create" -command mktaggo
3461 button $top.buts.can -text "Cancel" -command mktagcan
3462 grid $top.buts.gen $top.buts.can
3463 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3464 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3465 grid $top.buts - -pady 10 -sticky ew
3466 focus $top.tag
3469 proc domktag {} {
3470 global mktagtop env tagids idtags
3472 set id [$mktagtop.sha1 get]
3473 set tag [$mktagtop.tag get]
3474 if {$tag == {}} {
3475 error_popup "No tag name specified"
3476 return
3478 if {[info exists tagids($tag)]} {
3479 error_popup "Tag \"$tag\" already exists"
3480 return
3482 if {[catch {
3483 set dir [gitdir]
3484 set fname [file join $dir "refs/tags" $tag]
3485 set f [open $fname w]
3486 puts $f $id
3487 close $f
3488 } err]} {
3489 error_popup "Error creating tag: $err"
3490 return
3493 set tagids($tag) $id
3494 lappend idtags($id) $tag
3495 redrawtags $id
3498 proc redrawtags {id} {
3499 global canv linehtag idline idpos selectedline
3501 if {![info exists idline($id)]} return
3502 $canv delete tag.$id
3503 set xt [eval drawtags $id $idpos($id)]
3504 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3505 if {[info exists selectedline] && $selectedline == $idline($id)} {
3506 selectline $selectedline 0
3510 proc mktagcan {} {
3511 global mktagtop
3513 catch {destroy $mktagtop}
3514 unset mktagtop
3517 proc mktaggo {} {
3518 domktag
3519 mktagcan
3522 proc writecommit {} {
3523 global rowmenuid wrcomtop commitinfo wrcomcmd
3525 set top .writecommit
3526 set wrcomtop $top
3527 catch {destroy $top}
3528 toplevel $top
3529 label $top.title -text "Write commit to file"
3530 grid $top.title - -pady 10
3531 label $top.id -text "ID:"
3532 entry $top.sha1 -width 40 -relief flat
3533 $top.sha1 insert 0 $rowmenuid
3534 $top.sha1 conf -state readonly
3535 grid $top.id $top.sha1 -sticky w
3536 entry $top.head -width 60 -relief flat
3537 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3538 $top.head conf -state readonly
3539 grid x $top.head -sticky w
3540 label $top.clab -text "Command:"
3541 entry $top.cmd -width 60 -textvariable wrcomcmd
3542 grid $top.clab $top.cmd -sticky w -pady 10
3543 label $top.flab -text "Output file:"
3544 entry $top.fname -width 60
3545 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3546 grid $top.flab $top.fname -sticky w
3547 frame $top.buts
3548 button $top.buts.gen -text "Write" -command wrcomgo
3549 button $top.buts.can -text "Cancel" -command wrcomcan
3550 grid $top.buts.gen $top.buts.can
3551 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3552 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3553 grid $top.buts - -pady 10 -sticky ew
3554 focus $top.fname
3557 proc wrcomgo {} {
3558 global wrcomtop
3560 set id [$wrcomtop.sha1 get]
3561 set cmd "echo $id | [$wrcomtop.cmd get]"
3562 set fname [$wrcomtop.fname get]
3563 if {[catch {exec sh -c $cmd >$fname &} err]} {
3564 error_popup "Error writing commit: $err"
3566 catch {destroy $wrcomtop}
3567 unset wrcomtop
3570 proc wrcomcan {} {
3571 global wrcomtop
3573 catch {destroy $wrcomtop}
3574 unset wrcomtop
3577 proc listrefs {id} {
3578 global idtags idheads idotherrefs
3580 set x {}
3581 if {[info exists idtags($id)]} {
3582 set x $idtags($id)
3584 set y {}
3585 if {[info exists idheads($id)]} {
3586 set y $idheads($id)
3588 set z {}
3589 if {[info exists idotherrefs($id)]} {
3590 set z $idotherrefs($id)
3592 return [list $x $y $z]
3595 proc rereadrefs {} {
3596 global idtags idheads idotherrefs
3597 global tagids headids otherrefids
3599 set refids [concat [array names idtags] \
3600 [array names idheads] [array names idotherrefs]]
3601 foreach id $refids {
3602 if {![info exists ref($id)]} {
3603 set ref($id) [listrefs $id]
3606 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
3607 catch {unset $v}
3609 readrefs
3610 set refids [lsort -unique [concat $refids [array names idtags] \
3611 [array names idheads] [array names idotherrefs]]]
3612 foreach id $refids {
3613 set v [listrefs $id]
3614 if {![info exists ref($id)] || $ref($id) != $v} {
3615 redrawtags $id
3620 proc showtag {tag isnew} {
3621 global ctext cflist tagcontents tagids linknum
3623 if {$isnew} {
3624 addtohistory [list showtag $tag 0]
3626 $ctext conf -state normal
3627 $ctext delete 0.0 end
3628 set linknum 0
3629 if {[info exists tagcontents($tag)]} {
3630 set text $tagcontents($tag)
3631 } else {
3632 set text "Tag: $tag\nId: $tagids($tag)"
3634 appendwithlinks $text
3635 $ctext conf -state disabled
3636 $cflist delete 0 end
3639 proc doquit {} {
3640 global stopped
3641 set stopped 100
3642 destroy .
3645 # defaults...
3646 set datemode 0
3647 set boldnames 0
3648 set diffopts "-U 5 -p"
3649 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3651 set mainfont {Helvetica 9}
3652 set textfont {Courier 9}
3653 set findmergefiles 0
3654 set gaudydiff 0
3655 set maxgraphpct 50
3656 set maxwidth 16
3658 set colors {green red blue magenta darkgrey brown orange}
3660 catch {source ~/.gitk}
3662 set namefont $mainfont
3663 if {$boldnames} {
3664 lappend namefont bold
3667 set revtreeargs {}
3668 foreach arg $argv {
3669 switch -regexp -- $arg {
3670 "^$" { }
3671 "^-b" { set boldnames 1 }
3672 "^-d" { set datemode 1 }
3673 default {
3674 lappend revtreeargs $arg
3679 set history {}
3680 set historyindex 0
3682 set stopped 0
3683 set redisplaying 0
3684 set stuffsaved 0
3685 set patchnum 0
3686 setcoords
3687 makewindow
3688 readrefs
3689 getcommits $revtreeargs