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