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