Do a cross-project merge of Paul Mackerras' gitk visualizer
[git/git.git] / gitk
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "${1+$@}"
4
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.
9
10 # CVS $Revision: 1.24 $
11
12 proc getcommits {rargs} {
13 global commits commfd phase canv mainfont
14 global startmsecs nextupdate
15 global ctext maincursor textcursor leftover
16
17 set commits {}
18 set phase getcommits
19 set startmsecs [clock clicks -milliseconds]
20 set nextupdate [expr $startmsecs + 100]
21 if [catch {
22 set parse_args [concat --default HEAD $rargs]
23 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
24 }] {
25 # if git-rev-parse failed for some reason...
26 if {$rargs == {}} {
27 set rargs HEAD
28 }
29 set parsed_args $rargs
30 }
31 if [catch {
32 set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
33 } err] {
34 puts stderr "Error executing git-rev-list: $err"
35 exit 1
36 }
37 set leftover {}
38 fconfigure $commfd -blocking 0 -translation binary
39 fileevent $commfd readable "getcommitlines $commfd"
40 $canv delete all
41 $canv create text 3 3 -anchor nw -text "Reading commits..." \
42 -font $mainfont -tags textitems
43 . config -cursor watch
44 $ctext config -cursor watch
45 }
46
47 proc getcommitlines {commfd} {
48 global commits parents cdate children nchildren
49 global commitlisted phase commitinfo nextupdate
50 global stopped redisplaying leftover
51
52 set stuff [read $commfd]
53 if {$stuff == {}} {
54 if {![eof $commfd]} return
55 # this works around what is apparently a bug in Tcl...
56 fconfigure $commfd -blocking 1
57 if {![catch {close $commfd} err]} {
58 after idle finishcommits
59 return
60 }
61 if {[string range $err 0 4] == "usage"} {
62 set err \
63 {Gitk: error reading commits: bad arguments to git-rev-list.
64 (Note: arguments to gitk are passed to git-rev-list
65 to allow selection of commits to be displayed.)}
66 } else {
67 set err "Error reading commits: $err"
68 }
69 error_popup $err
70 exit 1
71 }
72 set start 0
73 while 1 {
74 set i [string first "\0" $stuff $start]
75 if {$i < 0} {
76 set leftover [string range $stuff $start end]
77 return
78 }
79 set cmit [string range $stuff $start [expr {$i - 1}]]
80 if {$start == 0} {
81 set cmit "$leftover$cmit"
82 }
83 set start [expr {$i + 1}]
84 if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
85 error_popup "Can't parse git-rev-list output: {$cmit}"
86 exit 1
87 }
88 set cmit [string range $cmit 41 end]
89 lappend commits $id
90 set commitlisted($id) 1
91 parsecommit $id $cmit 1
92 drawcommit $id
93 if {[clock clicks -milliseconds] >= $nextupdate} {
94 doupdate
95 }
96 while {$redisplaying} {
97 set redisplaying 0
98 if {$stopped == 1} {
99 set stopped 0
100 set phase "getcommits"
101 foreach id $commits {
102 drawcommit $id
103 if {$stopped} break
104 if {[clock clicks -milliseconds] >= $nextupdate} {
105 doupdate
106 }
107 }
108 }
109 }
110 }
111 }
112
113 proc doupdate {} {
114 global commfd nextupdate
115
116 incr nextupdate 100
117 fileevent $commfd readable {}
118 update
119 fileevent $commfd readable "getcommitlines $commfd"
120 }
121
122 proc readcommit {id} {
123 if [catch {set contents [exec git-cat-file commit $id]}] return
124 parsecommit $id $contents 0
125 }
126
127 proc parsecommit {id contents listed} {
128 global commitinfo children nchildren parents nparents cdate ncleft
129
130 set inhdr 1
131 set comment {}
132 set headline {}
133 set auname {}
134 set audate {}
135 set comname {}
136 set comdate {}
137 if {![info exists nchildren($id)]} {
138 set children($id) {}
139 set nchildren($id) 0
140 set ncleft($id) 0
141 }
142 set parents($id) {}
143 set nparents($id) 0
144 foreach line [split $contents "\n"] {
145 if {$inhdr} {
146 if {$line == {}} {
147 set inhdr 0
148 } else {
149 set tag [lindex $line 0]
150 if {$tag == "parent"} {
151 set p [lindex $line 1]
152 if {![info exists nchildren($p)]} {
153 set children($p) {}
154 set nchildren($p) 0
155 set ncleft($p) 0
156 }
157 lappend parents($id) $p
158 incr nparents($id)
159 # sometimes we get a commit that lists a parent twice...
160 if {$listed && [lsearch -exact $children($p) $id] < 0} {
161 lappend children($p) $id
162 incr nchildren($p)
163 incr ncleft($p)
164 }
165 } elseif {$tag == "author"} {
166 set x [expr {[llength $line] - 2}]
167 set audate [lindex $line $x]
168 set auname [lrange $line 1 [expr {$x - 1}]]
169 } elseif {$tag == "committer"} {
170 set x [expr {[llength $line] - 2}]
171 set comdate [lindex $line $x]
172 set comname [lrange $line 1 [expr {$x - 1}]]
173 }
174 }
175 } else {
176 if {$comment == {}} {
177 set headline [string trim $line]
178 } else {
179 append comment "\n"
180 }
181 if {!$listed} {
182 # git-rev-list indents the comment by 4 spaces;
183 # if we got this via git-cat-file, add the indentation
184 append comment " "
185 }
186 append comment $line
187 }
188 }
189 if {$audate != {}} {
190 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
191 }
192 if {$comdate != {}} {
193 set cdate($id) $comdate
194 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
195 }
196 set commitinfo($id) [list $headline $auname $audate \
197 $comname $comdate $comment]
198 }
199
200 proc readrefs {} {
201 global tagids idtags headids idheads
202 set tags [glob -nocomplain -types f .git/refs/tags/*]
203 foreach f $tags {
204 catch {
205 set fd [open $f r]
206 set line [read $fd]
207 if {[regexp {^[0-9a-f]{40}} $line id]} {
208 set direct [file tail $f]
209 set tagids($direct) $id
210 lappend idtags($id) $direct
211 set contents [split [exec git-cat-file tag $id] "\n"]
212 set obj {}
213 set type {}
214 set tag {}
215 foreach l $contents {
216 if {$l == {}} break
217 switch -- [lindex $l 0] {
218 "object" {set obj [lindex $l 1]}
219 "type" {set type [lindex $l 1]}
220 "tag" {set tag [string range $l 4 end]}
221 }
222 }
223 if {$obj != {} && $type == "commit" && $tag != {}} {
224 set tagids($tag) $obj
225 lappend idtags($obj) $tag
226 }
227 }
228 close $fd
229 }
230 }
231 set heads [glob -nocomplain -types f .git/refs/heads/*]
232 foreach f $heads {
233 catch {
234 set fd [open $f r]
235 set line [read $fd 40]
236 if {[regexp {^[0-9a-f]{40}} $line id]} {
237 set head [file tail $f]
238 set headids($head) $line
239 lappend idheads($line) $head
240 }
241 close $fd
242 }
243 }
244 }
245
246 proc error_popup msg {
247 set w .error
248 toplevel $w
249 wm transient $w .
250 message $w.m -text $msg -justify center -aspect 400
251 pack $w.m -side top -fill x -padx 20 -pady 20
252 button $w.ok -text OK -command "destroy $w"
253 pack $w.ok -side bottom -fill x
254 bind $w <Visibility> "grab $w; focus $w"
255 tkwait window $w
256 }
257
258 proc makewindow {} {
259 global canv canv2 canv3 linespc charspc ctext cflist textfont
260 global findtype findloc findstring fstring geometry
261 global entries sha1entry sha1string sha1but
262 global maincursor textcursor
263 global linectxmenu
264
265 menu .bar
266 .bar add cascade -label "File" -menu .bar.file
267 menu .bar.file
268 .bar.file add command -label "Quit" -command doquit
269 menu .bar.help
270 .bar add cascade -label "Help" -menu .bar.help
271 .bar.help add command -label "About gitk" -command about
272 . configure -menu .bar
273
274 if {![info exists geometry(canv1)]} {
275 set geometry(canv1) [expr 45 * $charspc]
276 set geometry(canv2) [expr 30 * $charspc]
277 set geometry(canv3) [expr 15 * $charspc]
278 set geometry(canvh) [expr 25 * $linespc + 4]
279 set geometry(ctextw) 80
280 set geometry(ctexth) 30
281 set geometry(cflistw) 30
282 }
283 panedwindow .ctop -orient vertical
284 if {[info exists geometry(width)]} {
285 .ctop conf -width $geometry(width) -height $geometry(height)
286 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
287 set geometry(ctexth) [expr {($texth - 8) /
288 [font metrics $textfont -linespace]}]
289 }
290 frame .ctop.top
291 frame .ctop.top.bar
292 pack .ctop.top.bar -side bottom -fill x
293 set cscroll .ctop.top.csb
294 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
295 pack $cscroll -side right -fill y
296 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
297 pack .ctop.top.clist -side top -fill both -expand 1
298 .ctop add .ctop.top
299 set canv .ctop.top.clist.canv
300 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
301 -bg white -bd 0 \
302 -yscrollincr $linespc -yscrollcommand "$cscroll set"
303 .ctop.top.clist add $canv
304 set canv2 .ctop.top.clist.canv2
305 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
306 -bg white -bd 0 -yscrollincr $linespc
307 .ctop.top.clist add $canv2
308 set canv3 .ctop.top.clist.canv3
309 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
310 -bg white -bd 0 -yscrollincr $linespc
311 .ctop.top.clist add $canv3
312 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
313
314 set sha1entry .ctop.top.bar.sha1
315 set entries $sha1entry
316 set sha1but .ctop.top.bar.sha1label
317 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
318 -command gotocommit -width 8
319 $sha1but conf -disabledforeground [$sha1but cget -foreground]
320 pack .ctop.top.bar.sha1label -side left
321 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
322 trace add variable sha1string write sha1change
323 pack $sha1entry -side left -pady 2
324 button .ctop.top.bar.findbut -text "Find" -command dofind
325 pack .ctop.top.bar.findbut -side left
326 set findstring {}
327 set fstring .ctop.top.bar.findstring
328 lappend entries $fstring
329 entry $fstring -width 30 -font $textfont -textvariable findstring
330 pack $fstring -side left -expand 1 -fill x
331 set findtype Exact
332 tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp
333 set findloc "All fields"
334 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
335 Comments Author Committer
336 pack .ctop.top.bar.findloc -side right
337 pack .ctop.top.bar.findtype -side right
338
339 panedwindow .ctop.cdet -orient horizontal
340 .ctop add .ctop.cdet
341 frame .ctop.cdet.left
342 set ctext .ctop.cdet.left.ctext
343 text $ctext -bg white -state disabled -font $textfont \
344 -width $geometry(ctextw) -height $geometry(ctexth) \
345 -yscrollcommand ".ctop.cdet.left.sb set"
346 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
347 pack .ctop.cdet.left.sb -side right -fill y
348 pack $ctext -side left -fill both -expand 1
349 .ctop.cdet add .ctop.cdet.left
350
351 $ctext tag conf filesep -font [concat $textfont bold]
352 $ctext tag conf hunksep -back blue -fore white
353 $ctext tag conf d0 -back "#ff8080"
354 $ctext tag conf d1 -back green
355 $ctext tag conf found -back yellow
356
357 frame .ctop.cdet.right
358 set cflist .ctop.cdet.right.cfiles
359 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
360 -yscrollcommand ".ctop.cdet.right.sb set"
361 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
362 pack .ctop.cdet.right.sb -side right -fill y
363 pack $cflist -side left -fill both -expand 1
364 .ctop.cdet add .ctop.cdet.right
365 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
366
367 pack .ctop -side top -fill both -expand 1
368
369 bindall <1> {selcanvline %x %y}
370 bindall <B1-Motion> {selcanvline %x %y}
371 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
372 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
373 bindall <2> "allcanvs scan mark 0 %y"
374 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
375 bind . <Key-Up> "selnextline -1"
376 bind . <Key-Down> "selnextline 1"
377 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
378 bind . <Key-Next> "allcanvs yview scroll 1 pages"
379 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
380 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
381 bindkey <Key-space> "$ctext yview scroll 1 pages"
382 bindkey p "selnextline -1"
383 bindkey n "selnextline 1"
384 bindkey b "$ctext yview scroll -1 pages"
385 bindkey d "$ctext yview scroll 18 units"
386 bindkey u "$ctext yview scroll -18 units"
387 bindkey / findnext
388 bindkey ? findprev
389 bindkey f nextfile
390 bind . <Control-q> doquit
391 bind . <Control-f> dofind
392 bind . <Control-g> findnext
393 bind . <Control-r> findprev
394 bind . <Control-equal> {incrfont 1}
395 bind . <Control-KP_Add> {incrfont 1}
396 bind . <Control-minus> {incrfont -1}
397 bind . <Control-KP_Subtract> {incrfont -1}
398 bind $cflist <<ListboxSelect>> listboxsel
399 bind . <Destroy> {savestuff %W}
400 bind . <Button-1> "click %W"
401 bind $fstring <Key-Return> dofind
402 bind $sha1entry <Key-Return> gotocommit
403
404 set maincursor [. cget -cursor]
405 set textcursor [$ctext cget -cursor]
406
407 set linectxmenu .linectxmenu
408 menu $linectxmenu -tearoff 0
409 $linectxmenu add command -label "Select" -command lineselect
410 }
411
412 # when we make a key binding for the toplevel, make sure
413 # it doesn't get triggered when that key is pressed in the
414 # find string entry widget.
415 proc bindkey {ev script} {
416 global entries
417 bind . $ev $script
418 set escript [bind Entry $ev]
419 if {$escript == {}} {
420 set escript [bind Entry <Key>]
421 }
422 foreach e $entries {
423 bind $e $ev "$escript; break"
424 }
425 }
426
427 # set the focus back to the toplevel for any click outside
428 # the entry widgets
429 proc click {w} {
430 global entries
431 foreach e $entries {
432 if {$w == $e} return
433 }
434 focus .
435 }
436
437 proc savestuff {w} {
438 global canv canv2 canv3 ctext cflist mainfont textfont
439 global stuffsaved
440 if {$stuffsaved} return
441 if {![winfo viewable .]} return
442 catch {
443 set f [open "~/.gitk-new" w]
444 puts $f "set mainfont {$mainfont}"
445 puts $f "set textfont {$textfont}"
446 puts $f "set geometry(width) [winfo width .ctop]"
447 puts $f "set geometry(height) [winfo height .ctop]"
448 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
449 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
450 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
451 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
452 set wid [expr {([winfo width $ctext] - 8) \
453 / [font measure $textfont "0"]}]
454 puts $f "set geometry(ctextw) $wid"
455 set wid [expr {([winfo width $cflist] - 11) \
456 / [font measure [$cflist cget -font] "0"]}]
457 puts $f "set geometry(cflistw) $wid"
458 close $f
459 file rename -force "~/.gitk-new" "~/.gitk"
460 }
461 set stuffsaved 1
462 }
463
464 proc resizeclistpanes {win w} {
465 global oldwidth
466 if [info exists oldwidth($win)] {
467 set s0 [$win sash coord 0]
468 set s1 [$win sash coord 1]
469 if {$w < 60} {
470 set sash0 [expr {int($w/2 - 2)}]
471 set sash1 [expr {int($w*5/6 - 2)}]
472 } else {
473 set factor [expr {1.0 * $w / $oldwidth($win)}]
474 set sash0 [expr {int($factor * [lindex $s0 0])}]
475 set sash1 [expr {int($factor * [lindex $s1 0])}]
476 if {$sash0 < 30} {
477 set sash0 30
478 }
479 if {$sash1 < $sash0 + 20} {
480 set sash1 [expr $sash0 + 20]
481 }
482 if {$sash1 > $w - 10} {
483 set sash1 [expr $w - 10]
484 if {$sash0 > $sash1 - 20} {
485 set sash0 [expr $sash1 - 20]
486 }
487 }
488 }
489 $win sash place 0 $sash0 [lindex $s0 1]
490 $win sash place 1 $sash1 [lindex $s1 1]
491 }
492 set oldwidth($win) $w
493 }
494
495 proc resizecdetpanes {win w} {
496 global oldwidth
497 if [info exists oldwidth($win)] {
498 set s0 [$win sash coord 0]
499 if {$w < 60} {
500 set sash0 [expr {int($w*3/4 - 2)}]
501 } else {
502 set factor [expr {1.0 * $w / $oldwidth($win)}]
503 set sash0 [expr {int($factor * [lindex $s0 0])}]
504 if {$sash0 < 45} {
505 set sash0 45
506 }
507 if {$sash0 > $w - 15} {
508 set sash0 [expr $w - 15]
509 }
510 }
511 $win sash place 0 $sash0 [lindex $s0 1]
512 }
513 set oldwidth($win) $w
514 }
515
516 proc allcanvs args {
517 global canv canv2 canv3
518 eval $canv $args
519 eval $canv2 $args
520 eval $canv3 $args
521 }
522
523 proc bindall {event action} {
524 global canv canv2 canv3
525 bind $canv $event $action
526 bind $canv2 $event $action
527 bind $canv3 $event $action
528 }
529
530 proc about {} {
531 set w .about
532 if {[winfo exists $w]} {
533 raise $w
534 return
535 }
536 toplevel $w
537 wm title $w "About gitk"
538 message $w.m -text {
539 Gitk version 1.1
540
541 Copyright © 2005 Paul Mackerras
542
543 Use and redistribute under the terms of the GNU General Public License
544
545 (CVS $Revision: 1.24 $)} \
546 -justify center -aspect 400
547 pack $w.m -side top -fill x -padx 20 -pady 20
548 button $w.ok -text Close -command "destroy $w"
549 pack $w.ok -side bottom
550 }
551
552 proc assigncolor {id} {
553 global commitinfo colormap commcolors colors nextcolor
554 global parents nparents children nchildren
555 global cornercrossings crossings
556
557 if [info exists colormap($id)] return
558 set ncolors [llength $colors]
559 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
560 set child [lindex $children($id) 0]
561 if {[info exists colormap($child)]
562 && $nparents($child) == 1} {
563 set colormap($id) $colormap($child)
564 return
565 }
566 }
567 set badcolors {}
568 if {[info exists cornercrossings($id)]} {
569 foreach x $cornercrossings($id) {
570 if {[info exists colormap($x)]
571 && [lsearch -exact $badcolors $colormap($x)] < 0} {
572 lappend badcolors $colormap($x)
573 }
574 }
575 if {[llength $badcolors] >= $ncolors} {
576 set badcolors {}
577 }
578 }
579 set origbad $badcolors
580 if {[llength $badcolors] < $ncolors - 1} {
581 if {[info exists crossings($id)]} {
582 foreach x $crossings($id) {
583 if {[info exists colormap($x)]
584 && [lsearch -exact $badcolors $colormap($x)] < 0} {
585 lappend badcolors $colormap($x)
586 }
587 }
588 if {[llength $badcolors] >= $ncolors} {
589 set badcolors $origbad
590 }
591 }
592 set origbad $badcolors
593 }
594 if {[llength $badcolors] < $ncolors - 1} {
595 foreach child $children($id) {
596 if {[info exists colormap($child)]
597 && [lsearch -exact $badcolors $colormap($child)] < 0} {
598 lappend badcolors $colormap($child)
599 }
600 if {[info exists parents($child)]} {
601 foreach p $parents($child) {
602 if {[info exists colormap($p)]
603 && [lsearch -exact $badcolors $colormap($p)] < 0} {
604 lappend badcolors $colormap($p)
605 }
606 }
607 }
608 }
609 if {[llength $badcolors] >= $ncolors} {
610 set badcolors $origbad
611 }
612 }
613 for {set i 0} {$i <= $ncolors} {incr i} {
614 set c [lindex $colors $nextcolor]
615 if {[incr nextcolor] >= $ncolors} {
616 set nextcolor 0
617 }
618 if {[lsearch -exact $badcolors $c]} break
619 }
620 set colormap($id) $c
621 }
622
623 proc initgraph {} {
624 global canvy canvy0 lineno numcommits lthickness nextcolor linespc
625 global mainline sidelines
626 global nchildren ncleft
627
628 allcanvs delete all
629 set nextcolor 0
630 set canvy $canvy0
631 set lineno -1
632 set numcommits 0
633 set lthickness [expr {int($linespc / 9) + 1}]
634 catch {unset mainline}
635 catch {unset sidelines}
636 foreach id [array names nchildren] {
637 set ncleft($id) $nchildren($id)
638 }
639 }
640
641 proc bindline {t id} {
642 global canv
643
644 $canv bind $t <Button-3> "linemenu %X %Y $id"
645 $canv bind $t <Enter> "lineenter %x %y $id"
646 $canv bind $t <Motion> "linemotion %x %y $id"
647 $canv bind $t <Leave> "lineleave $id"
648 }
649
650 proc drawcommitline {level} {
651 global parents children nparents nchildren todo
652 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
653 global lineid linehtag linentag linedtag commitinfo
654 global colormap numcommits currentparents dupparents
655 global oldlevel oldnlines oldtodo
656 global idtags idline idheads
657 global lineno lthickness mainline sidelines
658 global commitlisted
659
660 incr numcommits
661 incr lineno
662 set id [lindex $todo $level]
663 set lineid($lineno) $id
664 set idline($id) $lineno
665 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
666 if {![info exists commitinfo($id)]} {
667 readcommit $id
668 if {![info exists commitinfo($id)]} {
669 set commitinfo($id) {"No commit information available"}
670 set nparents($id) 0
671 }
672 }
673 assigncolor $id
674 set currentparents {}
675 set dupparents {}
676 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
677 foreach p $parents($id) {
678 if {[lsearch -exact $currentparents $p] < 0} {
679 lappend currentparents $p
680 } else {
681 # remember that this parent was listed twice
682 lappend dupparents $p
683 }
684 }
685 }
686 set x [expr $canvx0 + $level * $linespc]
687 set y1 $canvy
688 set canvy [expr $canvy + $linespc]
689 allcanvs conf -scrollregion \
690 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
691 if {[info exists mainline($id)]} {
692 lappend mainline($id) $x $y1
693 set t [$canv create line $mainline($id) \
694 -width $lthickness -fill $colormap($id)]
695 $canv lower $t
696 bindline $t $id
697 }
698 if {[info exists sidelines($id)]} {
699 foreach ls $sidelines($id) {
700 set coords [lindex $ls 0]
701 set thick [lindex $ls 1]
702 set t [$canv create line $coords -fill $colormap($id) \
703 -width [expr {$thick * $lthickness}]]
704 $canv lower $t
705 bindline $t $id
706 }
707 }
708 set orad [expr {$linespc / 3}]
709 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
710 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
711 -fill $ofill -outline black -width 1]
712 $canv raise $t
713 set xt [expr $canvx0 + [llength $todo] * $linespc]
714 if {[llength $currentparents] > 2} {
715 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
716 }
717 set marks {}
718 set ntags 0
719 if {[info exists idtags($id)]} {
720 set marks $idtags($id)
721 set ntags [llength $marks]
722 }
723 if {[info exists idheads($id)]} {
724 set marks [concat $marks $idheads($id)]
725 }
726 if {$marks != {}} {
727 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
728 set yt [expr $y1 - 0.5 * $linespc]
729 set yb [expr $yt + $linespc - 1]
730 set xvals {}
731 set wvals {}
732 foreach tag $marks {
733 set wid [font measure $mainfont $tag]
734 lappend xvals $xt
735 lappend wvals $wid
736 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
737 }
738 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
739 -width $lthickness -fill black]
740 $canv lower $t
741 foreach tag $marks x $xvals wid $wvals {
742 set xl [expr $x + $delta]
743 set xr [expr $x + $delta + $wid + $lthickness]
744 if {[incr ntags -1] >= 0} {
745 # draw a tag
746 $canv create polygon $x [expr $yt + $delta] $xl $yt\
747 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
748 -width 1 -outline black -fill yellow
749 } else {
750 # draw a head
751 set xl [expr $xl - $delta/2]
752 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
753 -width 1 -outline black -fill green
754 }
755 $canv create text $xl $y1 -anchor w -text $tag \
756 -font $mainfont
757 }
758 }
759 set headline [lindex $commitinfo($id) 0]
760 set name [lindex $commitinfo($id) 1]
761 set date [lindex $commitinfo($id) 2]
762 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
763 -text $headline -font $mainfont ]
764 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
765 -text $name -font $namefont]
766 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
767 -text $date -font $mainfont]
768 }
769
770 proc updatetodo {level noshortcut} {
771 global currentparents ncleft todo
772 global mainline oldlevel oldtodo oldnlines
773 global canvx0 canvy linespc mainline
774 global commitinfo
775
776 set oldlevel $level
777 set oldtodo $todo
778 set oldnlines [llength $todo]
779 if {!$noshortcut && [llength $currentparents] == 1} {
780 set p [lindex $currentparents 0]
781 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
782 set ncleft($p) 0
783 set x [expr $canvx0 + $level * $linespc]
784 set y [expr $canvy - $linespc]
785 set mainline($p) [list $x $y]
786 set todo [lreplace $todo $level $level $p]
787 return 0
788 }
789 }
790
791 set todo [lreplace $todo $level $level]
792 set i $level
793 foreach p $currentparents {
794 incr ncleft($p) -1
795 set k [lsearch -exact $todo $p]
796 if {$k < 0} {
797 set todo [linsert $todo $i $p]
798 incr i
799 }
800 }
801 return 1
802 }
803
804 proc notecrossings {id lo hi corner} {
805 global oldtodo crossings cornercrossings
806
807 for {set i $lo} {[incr i] < $hi} {} {
808 set p [lindex $oldtodo $i]
809 if {$p == {}} continue
810 if {$i == $corner} {
811 if {![info exists cornercrossings($id)]
812 || [lsearch -exact $cornercrossings($id) $p] < 0} {
813 lappend cornercrossings($id) $p
814 }
815 if {![info exists cornercrossings($p)]
816 || [lsearch -exact $cornercrossings($p) $id] < 0} {
817 lappend cornercrossings($p) $id
818 }
819 } else {
820 if {![info exists crossings($id)]
821 || [lsearch -exact $crossings($id) $p] < 0} {
822 lappend crossings($id) $p
823 }
824 if {![info exists crossings($p)]
825 || [lsearch -exact $crossings($p) $id] < 0} {
826 lappend crossings($p) $id
827 }
828 }
829 }
830 }
831
832 proc drawslants {} {
833 global canv mainline sidelines canvx0 canvy linespc
834 global oldlevel oldtodo todo currentparents dupparents
835 global lthickness linespc canvy colormap
836
837 set y1 [expr $canvy - $linespc]
838 set y2 $canvy
839 set i -1
840 foreach id $oldtodo {
841 incr i
842 if {$id == {}} continue
843 set xi [expr {$canvx0 + $i * $linespc}]
844 if {$i == $oldlevel} {
845 foreach p $currentparents {
846 set j [lsearch -exact $todo $p]
847 set coords [list $xi $y1]
848 set xj [expr {$canvx0 + $j * $linespc}]
849 if {$j < $i - 1} {
850 lappend coords [expr $xj + $linespc] $y1
851 notecrossings $p $j $i [expr {$j + 1}]
852 } elseif {$j > $i + 1} {
853 lappend coords [expr $xj - $linespc] $y1
854 notecrossings $p $i $j [expr {$j - 1}]
855 }
856 if {[lsearch -exact $dupparents $p] >= 0} {
857 # draw a double-width line to indicate the doubled parent
858 lappend coords $xj $y2
859 lappend sidelines($p) [list $coords 2]
860 if {![info exists mainline($p)]} {
861 set mainline($p) [list $xj $y2]
862 }
863 } else {
864 # normal case, no parent duplicated
865 if {![info exists mainline($p)]} {
866 if {$i != $j} {
867 lappend coords $xj $y2
868 }
869 set mainline($p) $coords
870 } else {
871 lappend coords $xj $y2
872 lappend sidelines($p) [list $coords 1]
873 }
874 }
875 }
876 } elseif {[lindex $todo $i] != $id} {
877 set j [lsearch -exact $todo $id]
878 set xj [expr {$canvx0 + $j * $linespc}]
879 lappend mainline($id) $xi $y1 $xj $y2
880 }
881 }
882 }
883
884 proc decidenext {} {
885 global parents children nchildren ncleft todo
886 global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
887 global datemode cdate
888 global lineid linehtag linentag linedtag commitinfo
889 global currentparents oldlevel oldnlines oldtodo
890 global lineno lthickness
891
892 # remove the null entry if present
893 set nullentry [lsearch -exact $todo {}]
894 if {$nullentry >= 0} {
895 set todo [lreplace $todo $nullentry $nullentry]
896 }
897
898 # choose which one to do next time around
899 set todol [llength $todo]
900 set level -1
901 set latest {}
902 for {set k $todol} {[incr k -1] >= 0} {} {
903 set p [lindex $todo $k]
904 if {$ncleft($p) == 0} {
905 if {$datemode} {
906 if {$latest == {} || $cdate($p) > $latest} {
907 set level $k
908 set latest $cdate($p)
909 }
910 } else {
911 set level $k
912 break
913 }
914 }
915 }
916 if {$level < 0} {
917 if {$todo != {}} {
918 puts "ERROR: none of the pending commits can be done yet:"
919 foreach p $todo {
920 puts " $p ($ncleft($p))"
921 }
922 }
923 return -1
924 }
925
926 # If we are reducing, put in a null entry
927 if {$todol < $oldnlines} {
928 if {$nullentry >= 0} {
929 set i $nullentry
930 while {$i < $todol
931 && [lindex $oldtodo $i] == [lindex $todo $i]} {
932 incr i
933 }
934 } else {
935 set i $oldlevel
936 if {$level >= $i} {
937 incr i
938 }
939 }
940 if {$i < $todol} {
941 set todo [linsert $todo $i {}]
942 if {$level >= $i} {
943 incr level
944 }
945 }
946 }
947 return $level
948 }
949
950 proc drawcommit {id} {
951 global phase todo nchildren datemode nextupdate
952 global startcommits
953
954 if {$phase != "incrdraw"} {
955 set phase incrdraw
956 set todo $id
957 set startcommits $id
958 initgraph
959 drawcommitline 0
960 updatetodo 0 $datemode
961 } else {
962 if {$nchildren($id) == 0} {
963 lappend todo $id
964 lappend startcommits $id
965 }
966 set level [decidenext]
967 if {$id != [lindex $todo $level]} {
968 return
969 }
970 while 1 {
971 drawslants
972 drawcommitline $level
973 if {[updatetodo $level $datemode]} {
974 set level [decidenext]
975 }
976 set id [lindex $todo $level]
977 if {![info exists commitlisted($id)]} {
978 break
979 }
980 if {[clock clicks -milliseconds] >= $nextupdate} {
981 doupdate
982 if {$stopped} break
983 }
984 }
985 }
986 }
987
988 proc finishcommits {} {
989 global phase
990 global startcommits
991 global ctext maincursor textcursor
992
993 if {$phase != "incrdraw"} {
994 $canv delete all
995 $canv create text 3 3 -anchor nw -text "No commits selected" \
996 -font $mainfont -tags textitems
997 set phase {}
998 return
999 }
1000 drawslants
1001 set level [decidenext]
1002 drawrest $level [llength $startcommits]
1003 . config -cursor $maincursor
1004 $ctext config -cursor $textcursor
1005 }
1006
1007 proc drawgraph {} {
1008 global nextupdate startmsecs startcommits todo
1009
1010 if {$startcommits == {}} return
1011 set startmsecs [clock clicks -milliseconds]
1012 set nextupdate [expr $startmsecs + 100]
1013 initgraph
1014 set todo [lindex $startcommits 0]
1015 drawrest 0 1
1016 }
1017
1018 proc drawrest {level startix} {
1019 global phase stopped redisplaying selectedline
1020 global datemode currentparents todo
1021 global numcommits
1022 global nextupdate startmsecs startcommits idline
1023
1024 if {$level >= 0} {
1025 set phase drawgraph
1026 set startid [lindex $startcommits $startix]
1027 set startline -1
1028 if {$startid != {}} {
1029 set startline $idline($startid)
1030 }
1031 while 1 {
1032 if {$stopped} break
1033 drawcommitline $level
1034 set hard [updatetodo $level $datemode]
1035 if {$numcommits == $startline} {
1036 lappend todo $startid
1037 set hard 1
1038 incr startix
1039 set startid [lindex $startcommits $startix]
1040 set startline -1
1041 if {$startid != {}} {
1042 set startline $idline($startid)
1043 }
1044 }
1045 if {$hard} {
1046 set level [decidenext]
1047 if {$level < 0} break
1048 drawslants
1049 }
1050 if {[clock clicks -milliseconds] >= $nextupdate} {
1051 update
1052 incr nextupdate 100
1053 }
1054 }
1055 }
1056 set phase {}
1057 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1058 #puts "overall $drawmsecs ms for $numcommits commits"
1059 if {$redisplaying} {
1060 if {$stopped == 0 && [info exists selectedline]} {
1061 selectline $selectedline
1062 }
1063 if {$stopped == 1} {
1064 set stopped 0
1065 after idle drawgraph
1066 } else {
1067 set redisplaying 0
1068 }
1069 }
1070 }
1071
1072 proc findmatches {f} {
1073 global findtype foundstring foundstrlen
1074 if {$findtype == "Regexp"} {
1075 set matches [regexp -indices -all -inline $foundstring $f]
1076 } else {
1077 if {$findtype == "IgnCase"} {
1078 set str [string tolower $f]
1079 } else {
1080 set str $f
1081 }
1082 set matches {}
1083 set i 0
1084 while {[set j [string first $foundstring $str $i]] >= 0} {
1085 lappend matches [list $j [expr $j+$foundstrlen-1]]
1086 set i [expr $j + $foundstrlen]
1087 }
1088 }
1089 return $matches
1090 }
1091
1092 proc dofind {} {
1093 global findtype findloc findstring markedmatches commitinfo
1094 global numcommits lineid linehtag linentag linedtag
1095 global mainfont namefont canv canv2 canv3 selectedline
1096 global matchinglines foundstring foundstrlen
1097 unmarkmatches
1098 focus .
1099 set matchinglines {}
1100 set fldtypes {Headline Author Date Committer CDate Comment}
1101 if {$findtype == "IgnCase"} {
1102 set foundstring [string tolower $findstring]
1103 } else {
1104 set foundstring $findstring
1105 }
1106 set foundstrlen [string length $findstring]
1107 if {$foundstrlen == 0} return
1108 if {![info exists selectedline]} {
1109 set oldsel -1
1110 } else {
1111 set oldsel $selectedline
1112 }
1113 set didsel 0
1114 for {set l 0} {$l < $numcommits} {incr l} {
1115 set id $lineid($l)
1116 set info $commitinfo($id)
1117 set doesmatch 0
1118 foreach f $info ty $fldtypes {
1119 if {$findloc != "All fields" && $findloc != $ty} {
1120 continue
1121 }
1122 set matches [findmatches $f]
1123 if {$matches == {}} continue
1124 set doesmatch 1
1125 if {$ty == "Headline"} {
1126 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1127 } elseif {$ty == "Author"} {
1128 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1129 } elseif {$ty == "Date"} {
1130 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1131 }
1132 }
1133 if {$doesmatch} {
1134 lappend matchinglines $l
1135 if {!$didsel && $l > $oldsel} {
1136 findselectline $l
1137 set didsel 1
1138 }
1139 }
1140 }
1141 if {$matchinglines == {}} {
1142 bell
1143 } elseif {!$didsel} {
1144 findselectline [lindex $matchinglines 0]
1145 }
1146 }
1147
1148 proc findselectline {l} {
1149 global findloc commentend ctext
1150 selectline $l
1151 if {$findloc == "All fields" || $findloc == "Comments"} {
1152 # highlight the matches in the comments
1153 set f [$ctext get 1.0 $commentend]
1154 set matches [findmatches $f]
1155 foreach match $matches {
1156 set start [lindex $match 0]
1157 set end [expr [lindex $match 1] + 1]
1158 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1159 }
1160 }
1161 }
1162
1163 proc findnext {} {
1164 global matchinglines selectedline
1165 if {![info exists matchinglines]} {
1166 dofind
1167 return
1168 }
1169 if {![info exists selectedline]} return
1170 foreach l $matchinglines {
1171 if {$l > $selectedline} {
1172 findselectline $l
1173 return
1174 }
1175 }
1176 bell
1177 }
1178
1179 proc findprev {} {
1180 global matchinglines selectedline
1181 if {![info exists matchinglines]} {
1182 dofind
1183 return
1184 }
1185 if {![info exists selectedline]} return
1186 set prev {}
1187 foreach l $matchinglines {
1188 if {$l >= $selectedline} break
1189 set prev $l
1190 }
1191 if {$prev != {}} {
1192 findselectline $prev
1193 } else {
1194 bell
1195 }
1196 }
1197
1198 proc markmatches {canv l str tag matches font} {
1199 set bbox [$canv bbox $tag]
1200 set x0 [lindex $bbox 0]
1201 set y0 [lindex $bbox 1]
1202 set y1 [lindex $bbox 3]
1203 foreach match $matches {
1204 set start [lindex $match 0]
1205 set end [lindex $match 1]
1206 if {$start > $end} continue
1207 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1208 set xlen [font measure $font [string range $str 0 [expr $end]]]
1209 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1210 -outline {} -tags matches -fill yellow]
1211 $canv lower $t
1212 }
1213 }
1214
1215 proc unmarkmatches {} {
1216 global matchinglines
1217 allcanvs delete matches
1218 catch {unset matchinglines}
1219 }
1220
1221 proc selcanvline {x y} {
1222 global canv canvy0 ctext linespc selectedline
1223 global lineid linehtag linentag linedtag
1224 set ymax [lindex [$canv cget -scrollregion] 3]
1225 if {$ymax == {}} return
1226 set yfrac [lindex [$canv yview] 0]
1227 set y [expr {$y + $yfrac * $ymax}]
1228 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1229 if {$l < 0} {
1230 set l 0
1231 }
1232 if {[info exists selectedline] && $selectedline == $l} return
1233 unmarkmatches
1234 selectline $l
1235 }
1236
1237 proc selectline {l} {
1238 global canv canv2 canv3 ctext commitinfo selectedline
1239 global lineid linehtag linentag linedtag
1240 global canvy0 linespc nparents treepending
1241 global cflist treediffs currentid sha1entry
1242 global commentend seenfile idtags
1243 $canv delete hover
1244 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1245 $canv delete secsel
1246 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1247 -tags secsel -fill [$canv cget -selectbackground]]
1248 $canv lower $t
1249 $canv2 delete secsel
1250 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1251 -tags secsel -fill [$canv2 cget -selectbackground]]
1252 $canv2 lower $t
1253 $canv3 delete secsel
1254 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1255 -tags secsel -fill [$canv3 cget -selectbackground]]
1256 $canv3 lower $t
1257 set y [expr {$canvy0 + $l * $linespc}]
1258 set ymax [lindex [$canv cget -scrollregion] 3]
1259 set ytop [expr {$y - $linespc - 1}]
1260 set ybot [expr {$y + $linespc + 1}]
1261 set wnow [$canv yview]
1262 set wtop [expr [lindex $wnow 0] * $ymax]
1263 set wbot [expr [lindex $wnow 1] * $ymax]
1264 set wh [expr {$wbot - $wtop}]
1265 set newtop $wtop
1266 if {$ytop < $wtop} {
1267 if {$ybot < $wtop} {
1268 set newtop [expr {$y - $wh / 2.0}]
1269 } else {
1270 set newtop $ytop
1271 if {$newtop > $wtop - $linespc} {
1272 set newtop [expr {$wtop - $linespc}]
1273 }
1274 }
1275 } elseif {$ybot > $wbot} {
1276 if {$ytop > $wbot} {
1277 set newtop [expr {$y - $wh / 2.0}]
1278 } else {
1279 set newtop [expr {$ybot - $wh}]
1280 if {$newtop < $wtop + $linespc} {
1281 set newtop [expr {$wtop + $linespc}]
1282 }
1283 }
1284 }
1285 if {$newtop != $wtop} {
1286 if {$newtop < 0} {
1287 set newtop 0
1288 }
1289 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1290 }
1291 set selectedline $l
1292
1293 set id $lineid($l)
1294 set currentid $id
1295 $sha1entry delete 0 end
1296 $sha1entry insert 0 $id
1297 $sha1entry selection from 0
1298 $sha1entry selection to end
1299
1300 $ctext conf -state normal
1301 $ctext delete 0.0 end
1302 set info $commitinfo($id)
1303 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1304 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1305 if {[info exists idtags($id)]} {
1306 $ctext insert end "Tags:"
1307 foreach tag $idtags($id) {
1308 $ctext insert end " $tag"
1309 }
1310 $ctext insert end "\n"
1311 }
1312 $ctext insert end "\n"
1313 $ctext insert end [lindex $info 5]
1314 $ctext insert end "\n"
1315 $ctext tag delete Comments
1316 $ctext tag remove found 1.0 end
1317 $ctext conf -state disabled
1318 set commentend [$ctext index "end - 1c"]
1319
1320 $cflist delete 0 end
1321 if {$nparents($id) == 1} {
1322 if {![info exists treediffs($id)]} {
1323 if {![info exists treepending]} {
1324 gettreediffs $id
1325 }
1326 } else {
1327 addtocflist $id
1328 }
1329 }
1330 catch {unset seenfile}
1331 }
1332
1333 proc selnextline {dir} {
1334 global selectedline
1335 if {![info exists selectedline]} return
1336 set l [expr $selectedline + $dir]
1337 unmarkmatches
1338 selectline $l
1339 }
1340
1341 proc addtocflist {id} {
1342 global currentid treediffs cflist treepending
1343 if {$id != $currentid} {
1344 gettreediffs $currentid
1345 return
1346 }
1347 $cflist insert end "All files"
1348 foreach f $treediffs($currentid) {
1349 $cflist insert end $f
1350 }
1351 getblobdiffs $id
1352 }
1353
1354 proc gettreediffs {id} {
1355 global treediffs parents treepending
1356 set treepending $id
1357 set treediffs($id) {}
1358 set p [lindex $parents($id) 0]
1359 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1360 fconfigure $gdtf -blocking 0
1361 fileevent $gdtf readable "gettreediffline $gdtf $id"
1362 }
1363
1364 proc gettreediffline {gdtf id} {
1365 global treediffs treepending
1366 set n [gets $gdtf line]
1367 if {$n < 0} {
1368 if {![eof $gdtf]} return
1369 close $gdtf
1370 unset treepending
1371 addtocflist $id
1372 return
1373 }
1374 set file [lindex $line 5]
1375 lappend treediffs($id) $file
1376 }
1377
1378 proc getblobdiffs {id} {
1379 global parents diffopts blobdifffd env curdifftag curtagstart
1380 global diffindex difffilestart
1381 set p [lindex $parents($id) 0]
1382 set env(GIT_DIFF_OPTS) $diffopts
1383 if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1384 puts "error getting diffs: $err"
1385 return
1386 }
1387 fconfigure $bdf -blocking 0
1388 set blobdifffd($id) $bdf
1389 set curdifftag Comments
1390 set curtagstart 0.0
1391 set diffindex 0
1392 catch {unset difffilestart}
1393 fileevent $bdf readable "getblobdiffline $bdf $id"
1394 }
1395
1396 proc getblobdiffline {bdf id} {
1397 global currentid blobdifffd ctext curdifftag curtagstart seenfile
1398 global diffnexthead diffnextnote diffindex difffilestart
1399 set n [gets $bdf line]
1400 if {$n < 0} {
1401 if {[eof $bdf]} {
1402 close $bdf
1403 if {$id == $currentid && $bdf == $blobdifffd($id)} {
1404 $ctext tag add $curdifftag $curtagstart end
1405 set seenfile($curdifftag) 1
1406 }
1407 }
1408 return
1409 }
1410 if {$id != $currentid || $bdf != $blobdifffd($id)} {
1411 return
1412 }
1413 $ctext conf -state normal
1414 if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1415 # start of a new file
1416 $ctext insert end "\n"
1417 $ctext tag add $curdifftag $curtagstart end
1418 set seenfile($curdifftag) 1
1419 set curtagstart [$ctext index "end - 1c"]
1420 set header $fname
1421 if {[info exists diffnexthead]} {
1422 set fname $diffnexthead
1423 set header "$diffnexthead ($diffnextnote)"
1424 unset diffnexthead
1425 }
1426 set difffilestart($diffindex) [$ctext index "end - 1c"]
1427 incr diffindex
1428 set curdifftag "f:$fname"
1429 $ctext tag delete $curdifftag
1430 set l [expr {(78 - [string length $header]) / 2}]
1431 set pad [string range "----------------------------------------" 1 $l]
1432 $ctext insert end "$pad $header $pad\n" filesep
1433 } elseif {[string range $line 0 2] == "+++"} {
1434 # no need to do anything with this
1435 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1436 set diffnexthead $fn
1437 set diffnextnote "created, mode $m"
1438 } elseif {[string range $line 0 8] == "Deleted: "} {
1439 set diffnexthead [string range $line 9 end]
1440 set diffnextnote "deleted"
1441 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1442 # save the filename in case the next thing is "new file mode ..."
1443 set diffnexthead $fn
1444 set diffnextnote "modified"
1445 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1446 set diffnextnote "new file, mode $m"
1447 } elseif {[string range $line 0 11] == "deleted file"} {
1448 set diffnextnote "deleted"
1449 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1450 $line match f1l f1c f2l f2c rest]} {
1451 $ctext insert end "\t" hunksep
1452 $ctext insert end " $f1l " d0 " $f2l " d1
1453 $ctext insert end " $rest \n" hunksep
1454 } else {
1455 set x [string range $line 0 0]
1456 if {$x == "-" || $x == "+"} {
1457 set tag [expr {$x == "+"}]
1458 set line [string range $line 1 end]
1459 $ctext insert end "$line\n" d$tag
1460 } elseif {$x == " "} {
1461 set line [string range $line 1 end]
1462 $ctext insert end "$line\n"
1463 } elseif {$x == "\\"} {
1464 # e.g. "\ No newline at end of file"
1465 $ctext insert end "$line\n" filesep
1466 } else {
1467 # Something else we don't recognize
1468 if {$curdifftag != "Comments"} {
1469 $ctext insert end "\n"
1470 $ctext tag add $curdifftag $curtagstart end
1471 set seenfile($curdifftag) 1
1472 set curtagstart [$ctext index "end - 1c"]
1473 set curdifftag Comments
1474 }
1475 $ctext insert end "$line\n" filesep
1476 }
1477 }
1478 $ctext conf -state disabled
1479 }
1480
1481 proc nextfile {} {
1482 global difffilestart ctext
1483 set here [$ctext index @0,0]
1484 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1485 if {[$ctext compare $difffilestart($i) > $here]} {
1486 $ctext yview $difffilestart($i)
1487 break
1488 }
1489 }
1490 }
1491
1492 proc listboxsel {} {
1493 global ctext cflist currentid treediffs seenfile
1494 if {![info exists currentid]} return
1495 set sel [$cflist curselection]
1496 if {$sel == {} || [lsearch -exact $sel 0] >= 0} {
1497 # show everything
1498 $ctext tag conf Comments -elide 0
1499 foreach f $treediffs($currentid) {
1500 if [info exists seenfile(f:$f)] {
1501 $ctext tag conf "f:$f" -elide 0
1502 }
1503 }
1504 } else {
1505 # just show selected files
1506 $ctext tag conf Comments -elide 1
1507 set i 1
1508 foreach f $treediffs($currentid) {
1509 set elide [expr {[lsearch -exact $sel $i] < 0}]
1510 if [info exists seenfile(f:$f)] {
1511 $ctext tag conf "f:$f" -elide $elide
1512 }
1513 incr i
1514 }
1515 }
1516 }
1517
1518 proc setcoords {} {
1519 global linespc charspc canvx0 canvy0 mainfont
1520 set linespc [font metrics $mainfont -linespace]
1521 set charspc [font measure $mainfont "m"]
1522 set canvy0 [expr 3 + 0.5 * $linespc]
1523 set canvx0 [expr 3 + 0.5 * $linespc]
1524 }
1525
1526 proc redisplay {} {
1527 global selectedline stopped redisplaying phase
1528 if {$stopped > 1} return
1529 if {$phase == "getcommits"} return
1530 set redisplaying 1
1531 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1532 set stopped 1
1533 } else {
1534 drawgraph
1535 }
1536 }
1537
1538 proc incrfont {inc} {
1539 global mainfont namefont textfont selectedline ctext canv phase
1540 global stopped entries
1541 unmarkmatches
1542 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1543 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1544 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1545 setcoords
1546 $ctext conf -font $textfont
1547 $ctext tag conf filesep -font [concat $textfont bold]
1548 foreach e $entries {
1549 $e conf -font $mainfont
1550 }
1551 if {$phase == "getcommits"} {
1552 $canv itemconf textitems -font $mainfont
1553 }
1554 redisplay
1555 }
1556
1557 proc sha1change {n1 n2 op} {
1558 global sha1string currentid sha1but
1559 if {$sha1string == {}
1560 || ([info exists currentid] && $sha1string == $currentid)} {
1561 set state disabled
1562 } else {
1563 set state normal
1564 }
1565 if {[$sha1but cget -state] == $state} return
1566 if {$state == "normal"} {
1567 $sha1but conf -state normal -relief raised -text "Goto: "
1568 } else {
1569 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1570 }
1571 }
1572
1573 proc gotocommit {} {
1574 global sha1string currentid idline tagids
1575 if {$sha1string == {}
1576 || ([info exists currentid] && $sha1string == $currentid)} return
1577 if {[info exists tagids($sha1string)]} {
1578 set id $tagids($sha1string)
1579 } else {
1580 set id [string tolower $sha1string]
1581 }
1582 if {[info exists idline($id)]} {
1583 selectline $idline($id)
1584 return
1585 }
1586 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1587 set type "SHA1 id"
1588 } else {
1589 set type "Tag"
1590 }
1591 error_popup "$type $sha1string is not known"
1592 }
1593
1594 proc linemenu {x y id} {
1595 global linectxmenu linemenuid
1596 set linemenuid $id
1597 $linectxmenu post $x $y
1598 }
1599
1600 proc lineselect {} {
1601 global linemenuid idline
1602 if {[info exists linemenuid] && [info exists idline($linemenuid)]} {
1603 selectline $idline($linemenuid)
1604 }
1605 }
1606
1607 proc lineenter {x y id} {
1608 global hoverx hovery hoverid hovertimer
1609 global commitinfo canv
1610
1611 if {![info exists commitinfo($id)]} return
1612 set hoverx $x
1613 set hovery $y
1614 set hoverid $id
1615 if {[info exists hovertimer]} {
1616 after cancel $hovertimer
1617 }
1618 set hovertimer [after 500 linehover]
1619 $canv delete hover
1620 }
1621
1622 proc linemotion {x y id} {
1623 global hoverx hovery hoverid hovertimer
1624
1625 if {[info exists hoverid] && $id == $hoverid} {
1626 set hoverx $x
1627 set hovery $y
1628 if {[info exists hovertimer]} {
1629 after cancel $hovertimer
1630 }
1631 set hovertimer [after 500 linehover]
1632 }
1633 }
1634
1635 proc lineleave {id} {
1636 global hoverid hovertimer canv
1637
1638 if {[info exists hoverid] && $id == $hoverid} {
1639 $canv delete hover
1640 if {[info exists hovertimer]} {
1641 after cancel $hovertimer
1642 unset hovertimer
1643 }
1644 unset hoverid
1645 }
1646 }
1647
1648 proc linehover {} {
1649 global hoverx hovery hoverid hovertimer
1650 global canv linespc lthickness
1651 global commitinfo mainfont
1652
1653 set text [lindex $commitinfo($hoverid) 0]
1654 set ymax [lindex [$canv cget -scrollregion] 3]
1655 if {$ymax == {}} return
1656 set yfrac [lindex [$canv yview] 0]
1657 set x [expr {$hoverx + 2 * $linespc}]
1658 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1659 set x0 [expr {$x - 2 * $lthickness}]
1660 set y0 [expr {$y - 2 * $lthickness}]
1661 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1662 set y1 [expr {$y + $linespc + 2 * $lthickness}]
1663 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1664 -fill \#ffff80 -outline black -width 1 -tags hover]
1665 $canv raise $t
1666 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1667 $canv raise $t
1668 }
1669
1670 proc doquit {} {
1671 global stopped
1672 set stopped 100
1673 destroy .
1674 }
1675
1676 # defaults...
1677 set datemode 0
1678 set boldnames 0
1679 set diffopts "-U 5 -p"
1680
1681 set mainfont {Helvetica 9}
1682 set textfont {Courier 9}
1683
1684 set colors {green red blue magenta darkgrey brown orange}
1685
1686 catch {source ~/.gitk}
1687
1688 set namefont $mainfont
1689 if {$boldnames} {
1690 lappend namefont bold
1691 }
1692
1693 set revtreeargs {}
1694 foreach arg $argv {
1695 switch -regexp -- $arg {
1696 "^$" { }
1697 "^-b" { set boldnames 1 }
1698 "^-d" { set datemode 1 }
1699 default {
1700 lappend revtreeargs $arg
1701 }
1702 }
1703 }
1704
1705 set stopped 0
1706 set redisplaying 0
1707 set stuffsaved 0
1708 setcoords
1709 makewindow
1710 readrefs
1711 getcommits $revtreeargs