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