0767695e2a24286d54af2ff14968dc1c2ffe6b4f
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "${1+$@}"
5 # Copyright (C) 2005 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return ".git"
16 }
17 }
19 proc getcommits {rargs} {
20 global commits commfd phase canv mainfont env
21 global startmsecs nextupdate ncmupdate
22 global ctext maincursor textcursor leftover
24 # check that we can find a .git directory somewhere...
25 set gitdir [gitdir]
26 if {![file isdirectory $gitdir]} {
27 error_popup "Cannot find the git directory \"$gitdir\"."
28 exit 1
29 }
30 set commits {}
31 set phase getcommits
32 set startmsecs [clock clicks -milliseconds]
33 set nextupdate [expr $startmsecs + 100]
34 set ncmupdate 1
35 if [catch {
36 set parse_args [concat --default HEAD $rargs]
37 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
38 }] {
39 # if git-rev-parse failed for some reason...
40 if {$rargs == {}} {
41 set rargs HEAD
42 }
43 set parsed_args $rargs
44 }
45 if [catch {
46 set commfd [open "|git-rev-list --header --topo-order --parents $parsed_args" r]
47 } err] {
48 puts stderr "Error executing git-rev-list: $err"
49 exit 1
50 }
51 set leftover {}
52 fconfigure $commfd -blocking 0 -translation lf
53 fileevent $commfd readable [list getcommitlines $commfd]
54 $canv delete all
55 $canv create text 3 3 -anchor nw -text "Reading commits..." \
56 -font $mainfont -tags textitems
57 . config -cursor watch
58 settextcursor watch
59 }
61 proc getcommitlines {commfd} {
62 global commits parents cdate children
63 global commitlisted phase commitinfo nextupdate
64 global stopped redisplaying leftover
66 set stuff [read $commfd]
67 if {$stuff == {}} {
68 if {![eof $commfd]} return
69 # set it blocking so we wait for the process to terminate
70 fconfigure $commfd -blocking 1
71 if {![catch {close $commfd} err]} {
72 after idle finishcommits
73 return
74 }
75 if {[string range $err 0 4] == "usage"} {
76 set err \
77 {Gitk: error reading commits: bad arguments to git-rev-list.
78 (Note: arguments to gitk are passed to git-rev-list
79 to allow selection of commits to be displayed.)}
80 } else {
81 set err "Error reading commits: $err"
82 }
83 error_popup $err
84 exit 1
85 }
86 set start 0
87 while 1 {
88 set i [string first "\0" $stuff $start]
89 if {$i < 0} {
90 append leftover [string range $stuff $start end]
91 return
92 }
93 set cmit [string range $stuff $start [expr {$i - 1}]]
94 if {$start == 0} {
95 set cmit "$leftover$cmit"
96 set leftover {}
97 }
98 set start [expr {$i + 1}]
99 set j [string first "\n" $cmit]
100 set ok 0
101 if {$j >= 0} {
102 set ids [string range $cmit 0 [expr {$j - 1}]]
103 set ok 1
104 foreach id $ids {
105 if {![regexp {^[0-9a-f]{40}$} $id]} {
106 set ok 0
107 break
108 }
109 }
110 }
111 if {!$ok} {
112 set shortcmit $cmit
113 if {[string length $shortcmit] > 80} {
114 set shortcmit "[string range $shortcmit 0 80]..."
115 }
116 error_popup "Can't parse git-rev-list output: {$shortcmit}"
117 exit 1
118 }
119 set id [lindex $ids 0]
120 set olds [lrange $ids 1 end]
121 set cmit [string range $cmit [expr {$j + 1}] end]
122 lappend commits $id
123 set commitlisted($id) 1
124 parsecommit $id $cmit 1 [lrange $ids 1 end]
125 drawcommit $id
126 if {[clock clicks -milliseconds] >= $nextupdate} {
127 doupdate 1
128 }
129 while {$redisplaying} {
130 set redisplaying 0
131 if {$stopped == 1} {
132 set stopped 0
133 set phase "getcommits"
134 foreach id $commits {
135 drawcommit $id
136 if {$stopped} break
137 if {[clock clicks -milliseconds] >= $nextupdate} {
138 doupdate 1
139 }
140 }
141 }
142 }
143 }
144 }
146 proc doupdate {reading} {
147 global commfd nextupdate numcommits ncmupdate
149 if {$reading} {
150 fileevent $commfd readable {}
151 }
152 update
153 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
154 if {$numcommits < 100} {
155 set ncmupdate [expr {$numcommits + 1}]
156 } elseif {$numcommits < 10000} {
157 set ncmupdate [expr {$numcommits + 10}]
158 } else {
159 set ncmupdate [expr {$numcommits + 100}]
160 }
161 if {$reading} {
162 fileevent $commfd readable [list getcommitlines $commfd]
163 }
164 }
166 proc readcommit {id} {
167 if [catch {set contents [exec git-cat-file commit $id]}] return
168 parsecommit $id $contents 0 {}
169 }
171 proc parsecommit {id contents listed olds} {
172 global commitinfo children nchildren parents nparents cdate ncleft
174 set inhdr 1
175 set comment {}
176 set headline {}
177 set auname {}
178 set audate {}
179 set comname {}
180 set comdate {}
181 if {![info exists nchildren($id)]} {
182 set children($id) {}
183 set nchildren($id) 0
184 set ncleft($id) 0
185 }
186 set parents($id) $olds
187 set nparents($id) [llength $olds]
188 foreach p $olds {
189 if {![info exists nchildren($p)]} {
190 set children($p) [list $id]
191 set nchildren($p) 1
192 set ncleft($p) 1
193 } elseif {[lsearch -exact $children($p) $id] < 0} {
194 lappend children($p) $id
195 incr nchildren($p)
196 incr ncleft($p)
197 }
198 }
199 foreach line [split $contents "\n"] {
200 if {$inhdr} {
201 if {$line == {}} {
202 set inhdr 0
203 } else {
204 set tag [lindex $line 0]
205 if {$tag == "author"} {
206 set x [expr {[llength $line] - 2}]
207 set audate [lindex $line $x]
208 set auname [lrange $line 1 [expr {$x - 1}]]
209 } elseif {$tag == "committer"} {
210 set x [expr {[llength $line] - 2}]
211 set comdate [lindex $line $x]
212 set comname [lrange $line 1 [expr {$x - 1}]]
213 }
214 }
215 } else {
216 if {$comment == {}} {
217 set headline [string trim $line]
218 } else {
219 append comment "\n"
220 }
221 if {!$listed} {
222 # git-rev-list indents the comment by 4 spaces;
223 # if we got this via git-cat-file, add the indentation
224 append comment " "
225 }
226 append comment $line
227 }
228 }
229 if {$audate != {}} {
230 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
231 }
232 if {$comdate != {}} {
233 set cdate($id) $comdate
234 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
235 }
236 set commitinfo($id) [list $headline $auname $audate \
237 $comname $comdate $comment]
238 }
240 proc readrefs {} {
241 global tagids idtags headids idheads
242 set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
243 foreach f $tags {
244 catch {
245 set fd [open $f r]
246 set line [read $fd]
247 if {[regexp {^[0-9a-f]{40}} $line id]} {
248 set direct [file tail $f]
249 set tagids($direct) $id
250 lappend idtags($id) $direct
251 set contents [split [exec git-cat-file tag $id] "\n"]
252 set obj {}
253 set type {}
254 set tag {}
255 foreach l $contents {
256 if {$l == {}} break
257 switch -- [lindex $l 0] {
258 "object" {set obj [lindex $l 1]}
259 "type" {set type [lindex $l 1]}
260 "tag" {set tag [string range $l 4 end]}
261 }
262 }
263 if {$obj != {} && $type == "commit" && $tag != {}} {
264 set tagids($tag) $obj
265 lappend idtags($obj) $tag
266 }
267 }
268 close $fd
269 }
270 }
271 set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
272 foreach f $heads {
273 catch {
274 set fd [open $f r]
275 set line [read $fd 40]
276 if {[regexp {^[0-9a-f]{40}} $line id]} {
277 set head [file tail $f]
278 set headids($head) $line
279 lappend idheads($line) $head
280 }
281 close $fd
282 }
283 }
284 }
286 proc error_popup msg {
287 set w .error
288 toplevel $w
289 wm transient $w .
290 message $w.m -text $msg -justify center -aspect 400
291 pack $w.m -side top -fill x -padx 20 -pady 20
292 button $w.ok -text OK -command "destroy $w"
293 pack $w.ok -side bottom -fill x
294 bind $w <Visibility> "grab $w; focus $w"
295 tkwait window $w
296 }
298 proc makewindow {} {
299 global canv canv2 canv3 linespc charspc ctext cflist textfont
300 global findtype findtypemenu findloc findstring fstring geometry
301 global entries sha1entry sha1string sha1but
302 global maincursor textcursor curtextcursor
303 global rowctxmenu gaudydiff mergemax
305 menu .bar
306 .bar add cascade -label "File" -menu .bar.file
307 menu .bar.file
308 .bar.file add command -label "Quit" -command doquit
309 menu .bar.help
310 .bar add cascade -label "Help" -menu .bar.help
311 .bar.help add command -label "About gitk" -command about
312 . configure -menu .bar
314 if {![info exists geometry(canv1)]} {
315 set geometry(canv1) [expr 45 * $charspc]
316 set geometry(canv2) [expr 30 * $charspc]
317 set geometry(canv3) [expr 15 * $charspc]
318 set geometry(canvh) [expr 25 * $linespc + 4]
319 set geometry(ctextw) 80
320 set geometry(ctexth) 30
321 set geometry(cflistw) 30
322 }
323 panedwindow .ctop -orient vertical
324 if {[info exists geometry(width)]} {
325 .ctop conf -width $geometry(width) -height $geometry(height)
326 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
327 set geometry(ctexth) [expr {($texth - 8) /
328 [font metrics $textfont -linespace]}]
329 }
330 frame .ctop.top
331 frame .ctop.top.bar
332 pack .ctop.top.bar -side bottom -fill x
333 set cscroll .ctop.top.csb
334 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
335 pack $cscroll -side right -fill y
336 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
337 pack .ctop.top.clist -side top -fill both -expand 1
338 .ctop add .ctop.top
339 set canv .ctop.top.clist.canv
340 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
341 -bg white -bd 0 \
342 -yscrollincr $linespc -yscrollcommand "$cscroll set"
343 .ctop.top.clist add $canv
344 set canv2 .ctop.top.clist.canv2
345 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
346 -bg white -bd 0 -yscrollincr $linespc
347 .ctop.top.clist add $canv2
348 set canv3 .ctop.top.clist.canv3
349 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
350 -bg white -bd 0 -yscrollincr $linespc
351 .ctop.top.clist add $canv3
352 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
354 set sha1entry .ctop.top.bar.sha1
355 set entries $sha1entry
356 set sha1but .ctop.top.bar.sha1label
357 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
358 -command gotocommit -width 8
359 $sha1but conf -disabledforeground [$sha1but cget -foreground]
360 pack .ctop.top.bar.sha1label -side left
361 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
362 trace add variable sha1string write sha1change
363 pack $sha1entry -side left -pady 2
365 image create bitmap bm-left -data {
366 #define left_width 16
367 #define left_height 16
368 static unsigned char left_bits[] = {
369 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
370 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
371 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
372 }
373 image create bitmap bm-right -data {
374 #define right_width 16
375 #define right_height 16
376 static unsigned char right_bits[] = {
377 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
378 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
379 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
380 }
381 button .ctop.top.bar.leftbut -image bm-left -command goback \
382 -state disabled -width 26
383 pack .ctop.top.bar.leftbut -side left -fill y
384 button .ctop.top.bar.rightbut -image bm-right -command goforw \
385 -state disabled -width 26
386 pack .ctop.top.bar.rightbut -side left -fill y
388 button .ctop.top.bar.findbut -text "Find" -command dofind
389 pack .ctop.top.bar.findbut -side left
390 set findstring {}
391 set fstring .ctop.top.bar.findstring
392 lappend entries $fstring
393 entry $fstring -width 30 -font $textfont -textvariable findstring
394 pack $fstring -side left -expand 1 -fill x
395 set findtype Exact
396 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
397 findtype Exact IgnCase Regexp]
398 set findloc "All fields"
399 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
400 Comments Author Committer Files Pickaxe
401 pack .ctop.top.bar.findloc -side right
402 pack .ctop.top.bar.findtype -side right
403 # for making sure type==Exact whenever loc==Pickaxe
404 trace add variable findloc write findlocchange
406 panedwindow .ctop.cdet -orient horizontal
407 .ctop add .ctop.cdet
408 frame .ctop.cdet.left
409 set ctext .ctop.cdet.left.ctext
410 text $ctext -bg white -state disabled -font $textfont \
411 -width $geometry(ctextw) -height $geometry(ctexth) \
412 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
413 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
414 pack .ctop.cdet.left.sb -side right -fill y
415 pack $ctext -side left -fill both -expand 1
416 .ctop.cdet add .ctop.cdet.left
418 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
419 if {$gaudydiff} {
420 $ctext tag conf hunksep -back blue -fore white
421 $ctext tag conf d0 -back "#ff8080"
422 $ctext tag conf d1 -back green
423 } else {
424 $ctext tag conf hunksep -fore blue
425 $ctext tag conf d0 -fore red
426 $ctext tag conf d1 -fore "#00a000"
427 $ctext tag conf m0 -fore red
428 $ctext tag conf m1 -fore blue
429 $ctext tag conf m2 -fore green
430 $ctext tag conf m3 -fore purple
431 $ctext tag conf m4 -fore brown
432 $ctext tag conf mmax -fore darkgrey
433 set mergemax 5
434 $ctext tag conf mresult -font [concat $textfont bold]
435 $ctext tag conf msep -font [concat $textfont bold]
436 $ctext tag conf found -back yellow
437 }
439 frame .ctop.cdet.right
440 set cflist .ctop.cdet.right.cfiles
441 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
442 -yscrollcommand ".ctop.cdet.right.sb set"
443 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
444 pack .ctop.cdet.right.sb -side right -fill y
445 pack $cflist -side left -fill both -expand 1
446 .ctop.cdet add .ctop.cdet.right
447 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
449 pack .ctop -side top -fill both -expand 1
451 bindall <1> {selcanvline %W %x %y}
452 #bindall <B1-Motion> {selcanvline %W %x %y}
453 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
454 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
455 bindall <2> "allcanvs scan mark 0 %y"
456 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
457 bind . <Key-Up> "selnextline -1"
458 bind . <Key-Down> "selnextline 1"
459 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
460 bind . <Key-Next> "allcanvs yview scroll 1 pages"
461 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
462 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
463 bindkey <Key-space> "$ctext yview scroll 1 pages"
464 bindkey p "selnextline -1"
465 bindkey n "selnextline 1"
466 bindkey b "$ctext yview scroll -1 pages"
467 bindkey d "$ctext yview scroll 18 units"
468 bindkey u "$ctext yview scroll -18 units"
469 bindkey / {findnext 1}
470 bindkey <Key-Return> {findnext 0}
471 bindkey ? findprev
472 bindkey f nextfile
473 bind . <Control-q> doquit
474 bind . <Control-f> dofind
475 bind . <Control-g> {findnext 0}
476 bind . <Control-r> findprev
477 bind . <Control-equal> {incrfont 1}
478 bind . <Control-KP_Add> {incrfont 1}
479 bind . <Control-minus> {incrfont -1}
480 bind . <Control-KP_Subtract> {incrfont -1}
481 bind $cflist <<ListboxSelect>> listboxsel
482 bind . <Destroy> {savestuff %W}
483 bind . <Button-1> "click %W"
484 bind $fstring <Key-Return> dofind
485 bind $sha1entry <Key-Return> gotocommit
486 bind $sha1entry <<PasteSelection>> clearsha1
488 set maincursor [. cget -cursor]
489 set textcursor [$ctext cget -cursor]
490 set curtextcursor $textcursor
492 set rowctxmenu .rowctxmenu
493 menu $rowctxmenu -tearoff 0
494 $rowctxmenu add command -label "Diff this -> selected" \
495 -command {diffvssel 0}
496 $rowctxmenu add command -label "Diff selected -> this" \
497 -command {diffvssel 1}
498 $rowctxmenu add command -label "Make patch" -command mkpatch
499 $rowctxmenu add command -label "Create tag" -command mktag
500 $rowctxmenu add command -label "Write commit to file" -command writecommit
501 }
503 # when we make a key binding for the toplevel, make sure
504 # it doesn't get triggered when that key is pressed in the
505 # find string entry widget.
506 proc bindkey {ev script} {
507 global entries
508 bind . $ev $script
509 set escript [bind Entry $ev]
510 if {$escript == {}} {
511 set escript [bind Entry <Key>]
512 }
513 foreach e $entries {
514 bind $e $ev "$escript; break"
515 }
516 }
518 # set the focus back to the toplevel for any click outside
519 # the entry widgets
520 proc click {w} {
521 global entries
522 foreach e $entries {
523 if {$w == $e} return
524 }
525 focus .
526 }
528 proc savestuff {w} {
529 global canv canv2 canv3 ctext cflist mainfont textfont
530 global stuffsaved findmergefiles gaudydiff maxgraphpct
532 if {$stuffsaved} return
533 if {![winfo viewable .]} return
534 catch {
535 set f [open "~/.gitk-new" w]
536 puts $f [list set mainfont $mainfont]
537 puts $f [list set textfont $textfont]
538 puts $f [list set findmergefiles $findmergefiles]
539 puts $f [list set gaudydiff $gaudydiff]
540 puts $f [list set maxgraphpct $maxgraphpct]
541 puts $f "set geometry(width) [winfo width .ctop]"
542 puts $f "set geometry(height) [winfo height .ctop]"
543 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
544 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
545 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
546 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
547 set wid [expr {([winfo width $ctext] - 8) \
548 / [font measure $textfont "0"]}]
549 puts $f "set geometry(ctextw) $wid"
550 set wid [expr {([winfo width $cflist] - 11) \
551 / [font measure [$cflist cget -font] "0"]}]
552 puts $f "set geometry(cflistw) $wid"
553 close $f
554 file rename -force "~/.gitk-new" "~/.gitk"
555 }
556 set stuffsaved 1
557 }
559 proc resizeclistpanes {win w} {
560 global oldwidth
561 if [info exists oldwidth($win)] {
562 set s0 [$win sash coord 0]
563 set s1 [$win sash coord 1]
564 if {$w < 60} {
565 set sash0 [expr {int($w/2 - 2)}]
566 set sash1 [expr {int($w*5/6 - 2)}]
567 } else {
568 set factor [expr {1.0 * $w / $oldwidth($win)}]
569 set sash0 [expr {int($factor * [lindex $s0 0])}]
570 set sash1 [expr {int($factor * [lindex $s1 0])}]
571 if {$sash0 < 30} {
572 set sash0 30
573 }
574 if {$sash1 < $sash0 + 20} {
575 set sash1 [expr $sash0 + 20]
576 }
577 if {$sash1 > $w - 10} {
578 set sash1 [expr $w - 10]
579 if {$sash0 > $sash1 - 20} {
580 set sash0 [expr $sash1 - 20]
581 }
582 }
583 }
584 $win sash place 0 $sash0 [lindex $s0 1]
585 $win sash place 1 $sash1 [lindex $s1 1]
586 }
587 set oldwidth($win) $w
588 }
590 proc resizecdetpanes {win w} {
591 global oldwidth
592 if [info exists oldwidth($win)] {
593 set s0 [$win sash coord 0]
594 if {$w < 60} {
595 set sash0 [expr {int($w*3/4 - 2)}]
596 } else {
597 set factor [expr {1.0 * $w / $oldwidth($win)}]
598 set sash0 [expr {int($factor * [lindex $s0 0])}]
599 if {$sash0 < 45} {
600 set sash0 45
601 }
602 if {$sash0 > $w - 15} {
603 set sash0 [expr $w - 15]
604 }
605 }
606 $win sash place 0 $sash0 [lindex $s0 1]
607 }
608 set oldwidth($win) $w
609 }
611 proc allcanvs args {
612 global canv canv2 canv3
613 eval $canv $args
614 eval $canv2 $args
615 eval $canv3 $args
616 }
618 proc bindall {event action} {
619 global canv canv2 canv3
620 bind $canv $event $action
621 bind $canv2 $event $action
622 bind $canv3 $event $action
623 }
625 proc about {} {
626 set w .about
627 if {[winfo exists $w]} {
628 raise $w
629 return
630 }
631 toplevel $w
632 wm title $w "About gitk"
633 message $w.m -text {
634 Gitk version 1.2
636 Copyright © 2005 Paul Mackerras
638 Use and redistribute under the terms of the GNU General Public License} \
639 -justify center -aspect 400
640 pack $w.m -side top -fill x -padx 20 -pady 20
641 button $w.ok -text Close -command "destroy $w"
642 pack $w.ok -side bottom
643 }
645 proc assigncolor {id} {
646 global commitinfo colormap commcolors colors nextcolor
647 global parents nparents children nchildren
648 global cornercrossings crossings
650 if [info exists colormap($id)] return
651 set ncolors [llength $colors]
652 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
653 set child [lindex $children($id) 0]
654 if {[info exists colormap($child)]
655 && $nparents($child) == 1} {
656 set colormap($id) $colormap($child)
657 return
658 }
659 }
660 set badcolors {}
661 if {[info exists cornercrossings($id)]} {
662 foreach x $cornercrossings($id) {
663 if {[info exists colormap($x)]
664 && [lsearch -exact $badcolors $colormap($x)] < 0} {
665 lappend badcolors $colormap($x)
666 }
667 }
668 if {[llength $badcolors] >= $ncolors} {
669 set badcolors {}
670 }
671 }
672 set origbad $badcolors
673 if {[llength $badcolors] < $ncolors - 1} {
674 if {[info exists crossings($id)]} {
675 foreach x $crossings($id) {
676 if {[info exists colormap($x)]
677 && [lsearch -exact $badcolors $colormap($x)] < 0} {
678 lappend badcolors $colormap($x)
679 }
680 }
681 if {[llength $badcolors] >= $ncolors} {
682 set badcolors $origbad
683 }
684 }
685 set origbad $badcolors
686 }
687 if {[llength $badcolors] < $ncolors - 1} {
688 foreach child $children($id) {
689 if {[info exists colormap($child)]
690 && [lsearch -exact $badcolors $colormap($child)] < 0} {
691 lappend badcolors $colormap($child)
692 }
693 if {[info exists parents($child)]} {
694 foreach p $parents($child) {
695 if {[info exists colormap($p)]
696 && [lsearch -exact $badcolors $colormap($p)] < 0} {
697 lappend badcolors $colormap($p)
698 }
699 }
700 }
701 }
702 if {[llength $badcolors] >= $ncolors} {
703 set badcolors $origbad
704 }
705 }
706 for {set i 0} {$i <= $ncolors} {incr i} {
707 set c [lindex $colors $nextcolor]
708 if {[incr nextcolor] >= $ncolors} {
709 set nextcolor 0
710 }
711 if {[lsearch -exact $badcolors $c]} break
712 }
713 set colormap($id) $c
714 }
716 proc initgraph {} {
717 global canvy canvy0 lineno numcommits nextcolor linespc
718 global mainline mainlinearrow sidelines
719 global nchildren ncleft
720 global displist nhyperspace
722 allcanvs delete all
723 set nextcolor 0
724 set canvy $canvy0
725 set lineno -1
726 set numcommits 0
727 catch {unset mainline}
728 catch {unset mainlinearrow}
729 catch {unset sidelines}
730 foreach id [array names nchildren] {
731 set ncleft($id) $nchildren($id)
732 }
733 set displist {}
734 set nhyperspace 0
735 }
737 proc bindline {t id} {
738 global canv
740 $canv bind $t <Enter> "lineenter %x %y $id"
741 $canv bind $t <Motion> "linemotion %x %y $id"
742 $canv bind $t <Leave> "lineleave $id"
743 $canv bind $t <Button-1> "lineclick %x %y $id 1"
744 }
746 # level here is an index in displist
747 proc drawcommitline {level} {
748 global parents children nparents displist
749 global canv canv2 canv3 mainfont namefont canvy linespc
750 global lineid linehtag linentag linedtag commitinfo
751 global colormap numcommits currentparents dupparents
752 global idtags idline idheads
753 global lineno lthickness mainline mainlinearrow sidelines
754 global commitlisted rowtextx idpos lastuse displist
755 global oldnlines olddlevel olddisplist
757 incr numcommits
758 incr lineno
759 set id [lindex $displist $level]
760 set lastuse($id) $lineno
761 set lineid($lineno) $id
762 set idline($id) $lineno
763 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
764 if {![info exists commitinfo($id)]} {
765 readcommit $id
766 if {![info exists commitinfo($id)]} {
767 set commitinfo($id) {"No commit information available"}
768 set nparents($id) 0
769 }
770 }
771 assigncolor $id
772 set currentparents {}
773 set dupparents {}
774 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
775 foreach p $parents($id) {
776 if {[lsearch -exact $currentparents $p] < 0} {
777 lappend currentparents $p
778 } else {
779 # remember that this parent was listed twice
780 lappend dupparents $p
781 }
782 }
783 }
784 set x [xcoord $level $level $lineno]
785 set y1 $canvy
786 set canvy [expr $canvy + $linespc]
787 allcanvs conf -scrollregion \
788 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
789 if {[info exists mainline($id)]} {
790 lappend mainline($id) $x $y1
791 if {$mainlinearrow($id) ne "none"} {
792 set mainline($id) [trimdiagstart $mainline($id)]
793 }
794 set t [$canv create line $mainline($id) \
795 -width $lthickness -fill $colormap($id) \
796 -arrow $mainlinearrow($id)]
797 $canv lower $t
798 bindline $t $id
799 }
800 if {[info exists sidelines($id)]} {
801 foreach ls $sidelines($id) {
802 set coords [lindex $ls 0]
803 set thick [lindex $ls 1]
804 set arrow [lindex $ls 2]
805 set t [$canv create line $coords -fill $colormap($id) \
806 -width [expr {$thick * $lthickness}] -arrow $arrow]
807 $canv lower $t
808 bindline $t $id
809 }
810 }
811 set orad [expr {$linespc / 3}]
812 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
813 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
814 -fill $ofill -outline black -width 1]
815 $canv raise $t
816 $canv bind $t <1> {selcanvline {} %x %y}
817 set xt [xcoord [llength $displist] $level $lineno]
818 if {[llength $currentparents] > 2} {
819 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
820 }
821 set rowtextx($lineno) $xt
822 set idpos($id) [list $x $xt $y1]
823 if {[info exists idtags($id)] || [info exists idheads($id)]} {
824 set xt [drawtags $id $x $xt $y1]
825 }
826 set headline [lindex $commitinfo($id) 0]
827 set name [lindex $commitinfo($id) 1]
828 set date [lindex $commitinfo($id) 2]
829 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
830 -text $headline -font $mainfont ]
831 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
832 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
833 -text $name -font $namefont]
834 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
835 -text $date -font $mainfont]
837 set olddlevel $level
838 set olddisplist $displist
839 set oldnlines [llength $displist]
840 }
842 proc drawtags {id x xt y1} {
843 global idtags idheads
844 global linespc lthickness
845 global canv mainfont
847 set marks {}
848 set ntags 0
849 if {[info exists idtags($id)]} {
850 set marks $idtags($id)
851 set ntags [llength $marks]
852 }
853 if {[info exists idheads($id)]} {
854 set marks [concat $marks $idheads($id)]
855 }
856 if {$marks eq {}} {
857 return $xt
858 }
860 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
861 set yt [expr $y1 - 0.5 * $linespc]
862 set yb [expr $yt + $linespc - 1]
863 set xvals {}
864 set wvals {}
865 foreach tag $marks {
866 set wid [font measure $mainfont $tag]
867 lappend xvals $xt
868 lappend wvals $wid
869 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
870 }
871 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
872 -width $lthickness -fill black -tags tag.$id]
873 $canv lower $t
874 foreach tag $marks x $xvals wid $wvals {
875 set xl [expr $x + $delta]
876 set xr [expr $x + $delta + $wid + $lthickness]
877 if {[incr ntags -1] >= 0} {
878 # draw a tag
879 $canv create polygon $x [expr $yt + $delta] $xl $yt\
880 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
881 -width 1 -outline black -fill yellow -tags tag.$id
882 } else {
883 # draw a head
884 set xl [expr $xl - $delta/2]
885 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
886 -width 1 -outline black -fill green -tags tag.$id
887 }
888 $canv create text $xl $y1 -anchor w -text $tag \
889 -font $mainfont -tags tag.$id
890 }
891 return $xt
892 }
894 proc notecrossings {id lo hi corner} {
895 global olddisplist crossings cornercrossings
897 for {set i $lo} {[incr i] < $hi} {} {
898 set p [lindex $olddisplist $i]
899 if {$p == {}} continue
900 if {$i == $corner} {
901 if {![info exists cornercrossings($id)]
902 || [lsearch -exact $cornercrossings($id) $p] < 0} {
903 lappend cornercrossings($id) $p
904 }
905 if {![info exists cornercrossings($p)]
906 || [lsearch -exact $cornercrossings($p) $id] < 0} {
907 lappend cornercrossings($p) $id
908 }
909 } else {
910 if {![info exists crossings($id)]
911 || [lsearch -exact $crossings($id) $p] < 0} {
912 lappend crossings($id) $p
913 }
914 if {![info exists crossings($p)]
915 || [lsearch -exact $crossings($p) $id] < 0} {
916 lappend crossings($p) $id
917 }
918 }
919 }
920 }
922 proc xcoord {i level ln} {
923 global canvx0 xspc1 xspc2
925 set x [expr {$canvx0 + $i * $xspc1($ln)}]
926 if {$i > 0 && $i == $level} {
927 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
928 } elseif {$i > $level} {
929 set x [expr {$x + $xspc2 - $xspc1($ln)}]
930 }
931 return $x
932 }
934 # it seems Tk can't draw arrows on the end of diagonal line segments...
935 proc trimdiagend {line} {
936 while {[llength $line] > 4} {
937 set x1 [lindex $line end-3]
938 set y1 [lindex $line end-2]
939 set x2 [lindex $line end-1]
940 set y2 [lindex $line end]
941 if {($x1 == $x2) != ($y1 == $y2)} break
942 set line [lreplace $line end-1 end]
943 }
944 return $line
945 }
947 proc trimdiagstart {line} {
948 while {[llength $line] > 4} {
949 set x1 [lindex $line 0]
950 set y1 [lindex $line 1]
951 set x2 [lindex $line 2]
952 set y2 [lindex $line 3]
953 if {($x1 == $x2) != ($y1 == $y2)} break
954 set line [lreplace $line 0 1]
955 }
956 return $line
957 }
959 proc drawslants {id needonscreen nohs} {
960 global canv mainline mainlinearrow sidelines
961 global canvx0 canvy xspc1 xspc2 lthickness
962 global currentparents dupparents
963 global lthickness linespc canvy colormap lineno geometry
964 global maxgraphpct maxwidth
965 global displist onscreen lastuse
966 global parents commitlisted
967 global oldnlines olddlevel olddisplist
968 global nhyperspace numcommits nnewparents
970 if {$lineno < 0} {
971 lappend displist $id
972 set onscreen($id) 1
973 return 0
974 }
976 set y1 [expr {$canvy - $linespc}]
977 set y2 $canvy
979 # work out what we need to get back on screen
980 set reins {}
981 if {$onscreen($id) < 0} {
982 # next to do isn't displayed, better get it on screen...
983 lappend reins [list $id 0]
984 }
985 # make sure all the previous commits's parents are on the screen
986 foreach p $currentparents {
987 if {$onscreen($p) < 0} {
988 lappend reins [list $p 0]
989 }
990 }
991 # bring back anything requested by caller
992 if {$needonscreen ne {}} {
993 lappend reins $needonscreen
994 }
996 # try the shortcut
997 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
998 set dlevel $olddlevel
999 set x [xcoord $dlevel $dlevel $lineno]
1000 set mainline($id) [list $x $y1]
1001 set mainlinearrow($id) none
1002 set lastuse($id) $lineno
1003 set displist [lreplace $displist $dlevel $dlevel $id]
1004 set onscreen($id) 1
1005 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1006 return $dlevel
1007 }
1009 # update displist
1010 set displist [lreplace $displist $olddlevel $olddlevel]
1011 set j $olddlevel
1012 foreach p $currentparents {
1013 set lastuse($p) $lineno
1014 if {$onscreen($p) == 0} {
1015 set displist [linsert $displist $j $p]
1016 set onscreen($p) 1
1017 incr j
1018 }
1019 }
1020 if {$onscreen($id) == 0} {
1021 lappend displist $id
1022 set onscreen($id) 1
1023 }
1025 # remove the null entry if present
1026 set nullentry [lsearch -exact $displist {}]
1027 if {$nullentry >= 0} {
1028 set displist [lreplace $displist $nullentry $nullentry]
1029 }
1031 # bring back the ones we need now (if we did it earlier
1032 # it would change displist and invalidate olddlevel)
1033 foreach pi $reins {
1034 # test again in case of duplicates in reins
1035 set p [lindex $pi 0]
1036 if {$onscreen($p) < 0} {
1037 set onscreen($p) 1
1038 set lastuse($p) $lineno
1039 set displist [linsert $displist [lindex $pi 1] $p]
1040 incr nhyperspace -1
1041 }
1042 }
1044 set lastuse($id) $lineno
1046 # see if we need to make any lines jump off into hyperspace
1047 set displ [llength $displist]
1048 if {$displ > $maxwidth} {
1049 set ages {}
1050 foreach x $displist {
1051 lappend ages [list $lastuse($x) $x]
1052 }
1053 set ages [lsort -integer -index 0 $ages]
1054 set k 0
1055 while {$displ > $maxwidth} {
1056 set use [lindex $ages $k 0]
1057 set victim [lindex $ages $k 1]
1058 if {$use >= $lineno - 5} break
1059 incr k
1060 if {[lsearch -exact $nohs $victim] >= 0} continue
1061 set i [lsearch -exact $displist $victim]
1062 set displist [lreplace $displist $i $i]
1063 set onscreen($victim) -1
1064 incr nhyperspace
1065 incr displ -1
1066 if {$i < $nullentry} {
1067 incr nullentry -1
1068 }
1069 set x [lindex $mainline($victim) end-1]
1070 lappend mainline($victim) $x $y1
1071 set line [trimdiagend $mainline($victim)]
1072 set arrow "last"
1073 if {$mainlinearrow($victim) ne "none"} {
1074 set line [trimdiagstart $line]
1075 set arrow "both"
1076 }
1077 lappend sidelines($victim) [list $line 1 $arrow]
1078 unset mainline($victim)
1079 }
1080 }
1082 set dlevel [lsearch -exact $displist $id]
1084 # If we are reducing, put in a null entry
1085 if {$displ < $oldnlines} {
1086 # does the next line look like a merge?
1087 # i.e. does it have > 1 new parent?
1088 if {$nnewparents($id) > 1} {
1089 set i [expr {$dlevel + 1}]
1090 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1091 set i $olddlevel
1092 if {$nullentry >= 0 && $nullentry < $i} {
1093 incr i -1
1094 }
1095 } elseif {$nullentry >= 0} {
1096 set i $nullentry
1097 while {$i < $displ
1098 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1099 incr i
1100 }
1101 } else {
1102 set i $olddlevel
1103 if {$dlevel >= $i} {
1104 incr i
1105 }
1106 }
1107 if {$i < $displ} {
1108 set displist [linsert $displist $i {}]
1109 incr displ
1110 if {$dlevel >= $i} {
1111 incr dlevel
1112 }
1113 }
1114 }
1116 # decide on the line spacing for the next line
1117 set lj [expr {$lineno + 1}]
1118 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1119 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1120 set xspc1($lj) $xspc2
1121 } else {
1122 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1123 if {$xspc1($lj) < $lthickness} {
1124 set xspc1($lj) $lthickness
1125 }
1126 }
1128 foreach idi $reins {
1129 set id [lindex $idi 0]
1130 set j [lsearch -exact $displist $id]
1131 set xj [xcoord $j $dlevel $lj]
1132 set mainline($id) [list $xj $y2]
1133 set mainlinearrow($id) first
1134 }
1136 set i -1
1137 foreach id $olddisplist {
1138 incr i
1139 if {$id == {}} continue
1140 if {$onscreen($id) <= 0} continue
1141 set xi [xcoord $i $olddlevel $lineno]
1142 if {$i == $olddlevel} {
1143 foreach p $currentparents {
1144 set j [lsearch -exact $displist $p]
1145 set coords [list $xi $y1]
1146 set xj [xcoord $j $dlevel $lj]
1147 if {$xj < $xi - $linespc} {
1148 lappend coords [expr {$xj + $linespc}] $y1
1149 notecrossings $p $j $i [expr {$j + 1}]
1150 } elseif {$xj > $xi + $linespc} {
1151 lappend coords [expr {$xj - $linespc}] $y1
1152 notecrossings $p $i $j [expr {$j - 1}]
1153 }
1154 if {[lsearch -exact $dupparents $p] >= 0} {
1155 # draw a double-width line to indicate the doubled parent
1156 lappend coords $xj $y2
1157 lappend sidelines($p) [list $coords 2 none]
1158 if {![info exists mainline($p)]} {
1159 set mainline($p) [list $xj $y2]
1160 set mainlinearrow($p) none
1161 }
1162 } else {
1163 # normal case, no parent duplicated
1164 set yb $y2
1165 set dx [expr {abs($xi - $xj)}]
1166 if {0 && $dx < $linespc} {
1167 set yb [expr {$y1 + $dx}]
1168 }
1169 if {![info exists mainline($p)]} {
1170 if {$xi != $xj} {
1171 lappend coords $xj $yb
1172 }
1173 set mainline($p) $coords
1174 set mainlinearrow($p) none
1175 } else {
1176 lappend coords $xj $yb
1177 if {$yb < $y2} {
1178 lappend coords $xj $y2
1179 }
1180 lappend sidelines($p) [list $coords 1 none]
1181 }
1182 }
1183 }
1184 } else {
1185 set j $i
1186 if {[lindex $displist $i] != $id} {
1187 set j [lsearch -exact $displist $id]
1188 }
1189 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1190 || ($olddlevel < $i && $i < $dlevel)
1191 || ($dlevel < $i && $i < $olddlevel)} {
1192 set xj [xcoord $j $dlevel $lj]
1193 lappend mainline($id) $xi $y1 $xj $y2
1194 }
1195 }
1196 }
1197 return $dlevel
1198 }
1200 # search for x in a list of lists
1201 proc llsearch {llist x} {
1202 set i 0
1203 foreach l $llist {
1204 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1205 return $i
1206 }
1207 incr i
1208 }
1209 return -1
1210 }
1212 proc drawmore {reading} {
1213 global displayorder numcommits ncmupdate nextupdate
1214 global stopped nhyperspace parents commitlisted
1215 global maxwidth onscreen displist currentparents olddlevel
1217 set n [llength $displayorder]
1218 while {$numcommits < $n} {
1219 set id [lindex $displayorder $numcommits]
1220 set ctxend [expr {$numcommits + 10}]
1221 if {!$reading && $ctxend > $n} {
1222 set ctxend $n
1223 }
1224 set dlist {}
1225 if {$numcommits > 0} {
1226 set dlist [lreplace $displist $olddlevel $olddlevel]
1227 set i $olddlevel
1228 foreach p $currentparents {
1229 if {$onscreen($p) == 0} {
1230 set dlist [linsert $dlist $i $p]
1231 incr i
1232 }
1233 }
1234 }
1235 set nohs {}
1236 set reins {}
1237 set isfat [expr {[llength $dlist] > $maxwidth}]
1238 if {$nhyperspace > 0 || $isfat} {
1239 if {$ctxend > $n} break
1240 # work out what to bring back and
1241 # what we want to don't want to send into hyperspace
1242 set room 1
1243 for {set k $numcommits} {$k < $ctxend} {incr k} {
1244 set x [lindex $displayorder $k]
1245 set i [llsearch $dlist $x]
1246 if {$i < 0} {
1247 set i [llength $dlist]
1248 lappend dlist $x
1249 }
1250 if {[lsearch -exact $nohs $x] < 0} {
1251 lappend nohs $x
1252 }
1253 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1254 set reins [list $x $i]
1255 }
1256 set newp {}
1257 if {[info exists commitlisted($x)]} {
1258 set right 0
1259 foreach p $parents($x) {
1260 if {[llsearch $dlist $p] < 0} {
1261 lappend newp $p
1262 if {[lsearch -exact $nohs $p] < 0} {
1263 lappend nohs $p
1264 }
1265 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1266 set reins [list $p [expr {$i + $right}]]
1267 }
1268 }
1269 set right 1
1270 }
1271 }
1272 set l [lindex $dlist $i]
1273 if {[llength $l] == 1} {
1274 set l $newp
1275 } else {
1276 set j [lsearch -exact $l $x]
1277 set l [concat [lreplace $l $j $j] $newp]
1278 }
1279 set dlist [lreplace $dlist $i $i $l]
1280 if {$room && $isfat && [llength $newp] <= 1} {
1281 set room 0
1282 }
1283 }
1284 }
1286 set dlevel [drawslants $id $reins $nohs]
1287 drawcommitline $dlevel
1288 if {[clock clicks -milliseconds] >= $nextupdate
1289 && $numcommits >= $ncmupdate} {
1290 doupdate $reading
1291 if {$stopped} break
1292 }
1293 }
1294 }
1296 # level here is an index in todo
1297 proc updatetodo {level noshortcut} {
1298 global ncleft todo nnewparents
1299 global commitlisted parents onscreen
1301 set id [lindex $todo $level]
1302 set olds {}
1303 if {[info exists commitlisted($id)]} {
1304 foreach p $parents($id) {
1305 if {[lsearch -exact $olds $p] < 0} {
1306 lappend olds $p
1307 }
1308 }
1309 }
1310 if {!$noshortcut && [llength $olds] == 1} {
1311 set p [lindex $olds 0]
1312 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1313 set ncleft($p) 0
1314 set todo [lreplace $todo $level $level $p]
1315 set onscreen($p) 0
1316 set nnewparents($id) 1
1317 return 0
1318 }
1319 }
1321 set todo [lreplace $todo $level $level]
1322 set i $level
1323 set n 0
1324 foreach p $olds {
1325 incr ncleft($p) -1
1326 set k [lsearch -exact $todo $p]
1327 if {$k < 0} {
1328 set todo [linsert $todo $i $p]
1329 set onscreen($p) 0
1330 incr i
1331 incr n
1332 }
1333 }
1334 set nnewparents($id) $n
1336 return 1
1337 }
1339 proc decidenext {{noread 0}} {
1340 global ncleft todo
1341 global datemode cdate
1342 global commitinfo
1344 # choose which one to do next time around
1345 set todol [llength $todo]
1346 set level -1
1347 set latest {}
1348 for {set k $todol} {[incr k -1] >= 0} {} {
1349 set p [lindex $todo $k]
1350 if {$ncleft($p) == 0} {
1351 if {$datemode} {
1352 if {![info exists commitinfo($p)]} {
1353 if {$noread} {
1354 return {}
1355 }
1356 readcommit $p
1357 }
1358 if {$latest == {} || $cdate($p) > $latest} {
1359 set level $k
1360 set latest $cdate($p)
1361 }
1362 } else {
1363 set level $k
1364 break
1365 }
1366 }
1367 }
1368 if {$level < 0} {
1369 if {$todo != {}} {
1370 puts "ERROR: none of the pending commits can be done yet:"
1371 foreach p $todo {
1372 puts " $p ($ncleft($p))"
1373 }
1374 }
1375 return -1
1376 }
1378 return $level
1379 }
1381 proc drawcommit {id} {
1382 global phase todo nchildren datemode nextupdate
1383 global numcommits ncmupdate displayorder todo onscreen
1385 if {$phase != "incrdraw"} {
1386 set phase incrdraw
1387 set displayorder {}
1388 set todo {}
1389 initgraph
1390 }
1391 if {$nchildren($id) == 0} {
1392 lappend todo $id
1393 set onscreen($id) 0
1394 }
1395 set level [decidenext 1]
1396 if {$level == {} || $id != [lindex $todo $level]} {
1397 return
1398 }
1399 while 1 {
1400 lappend displayorder [lindex $todo $level]
1401 if {[updatetodo $level $datemode]} {
1402 set level [decidenext 1]
1403 if {$level == {}} break
1404 }
1405 set id [lindex $todo $level]
1406 if {![info exists commitlisted($id)]} {
1407 break
1408 }
1409 }
1410 drawmore 1
1411 }
1413 proc finishcommits {} {
1414 global phase
1415 global canv mainfont ctext maincursor textcursor
1417 if {$phase != "incrdraw"} {
1418 $canv delete all
1419 $canv create text 3 3 -anchor nw -text "No commits selected" \
1420 -font $mainfont -tags textitems
1421 set phase {}
1422 } else {
1423 drawrest
1424 }
1425 . config -cursor $maincursor
1426 settextcursor $textcursor
1427 }
1429 # Don't change the text pane cursor if it is currently the hand cursor,
1430 # showing that we are over a sha1 ID link.
1431 proc settextcursor {c} {
1432 global ctext curtextcursor
1434 if {[$ctext cget -cursor] == $curtextcursor} {
1435 $ctext config -cursor $c
1436 }
1437 set curtextcursor $c
1438 }
1440 proc drawgraph {} {
1441 global nextupdate startmsecs ncmupdate
1442 global displayorder onscreen
1444 if {$displayorder == {}} return
1445 set startmsecs [clock clicks -milliseconds]
1446 set nextupdate [expr $startmsecs + 100]
1447 set ncmupdate 1
1448 initgraph
1449 foreach id $displayorder {
1450 set onscreen($id) 0
1451 }
1452 drawmore 0
1453 }
1455 proc drawrest {} {
1456 global phase stopped redisplaying selectedline
1457 global datemode todo displayorder
1458 global numcommits ncmupdate
1459 global nextupdate startmsecs idline
1461 set level [decidenext]
1462 if {$level >= 0} {
1463 set phase drawgraph
1464 while 1 {
1465 lappend displayorder [lindex $todo $level]
1466 set hard [updatetodo $level $datemode]
1467 if {$hard} {
1468 set level [decidenext]
1469 if {$level < 0} break
1470 }
1471 }
1472 drawmore 0
1473 }
1474 set phase {}
1475 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1476 #puts "overall $drawmsecs ms for $numcommits commits"
1477 if {$redisplaying} {
1478 if {$stopped == 0 && [info exists selectedline]} {
1479 selectline $selectedline 0
1480 }
1481 if {$stopped == 1} {
1482 set stopped 0
1483 after idle drawgraph
1484 } else {
1485 set redisplaying 0
1486 }
1487 }
1488 }
1490 proc findmatches {f} {
1491 global findtype foundstring foundstrlen
1492 if {$findtype == "Regexp"} {
1493 set matches [regexp -indices -all -inline $foundstring $f]
1494 } else {
1495 if {$findtype == "IgnCase"} {
1496 set str [string tolower $f]
1497 } else {
1498 set str $f
1499 }
1500 set matches {}
1501 set i 0
1502 while {[set j [string first $foundstring $str $i]] >= 0} {
1503 lappend matches [list $j [expr $j+$foundstrlen-1]]
1504 set i [expr $j + $foundstrlen]
1505 }
1506 }
1507 return $matches
1508 }
1510 proc dofind {} {
1511 global findtype findloc findstring markedmatches commitinfo
1512 global numcommits lineid linehtag linentag linedtag
1513 global mainfont namefont canv canv2 canv3 selectedline
1514 global matchinglines foundstring foundstrlen
1516 stopfindproc
1517 unmarkmatches
1518 focus .
1519 set matchinglines {}
1520 if {$findloc == "Pickaxe"} {
1521 findpatches
1522 return
1523 }
1524 if {$findtype == "IgnCase"} {
1525 set foundstring [string tolower $findstring]
1526 } else {
1527 set foundstring $findstring
1528 }
1529 set foundstrlen [string length $findstring]
1530 if {$foundstrlen == 0} return
1531 if {$findloc == "Files"} {
1532 findfiles
1533 return
1534 }
1535 if {![info exists selectedline]} {
1536 set oldsel -1
1537 } else {
1538 set oldsel $selectedline
1539 }
1540 set didsel 0
1541 set fldtypes {Headline Author Date Committer CDate Comment}
1542 for {set l 0} {$l < $numcommits} {incr l} {
1543 set id $lineid($l)
1544 set info $commitinfo($id)
1545 set doesmatch 0
1546 foreach f $info ty $fldtypes {
1547 if {$findloc != "All fields" && $findloc != $ty} {
1548 continue
1549 }
1550 set matches [findmatches $f]
1551 if {$matches == {}} continue
1552 set doesmatch 1
1553 if {$ty == "Headline"} {
1554 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1555 } elseif {$ty == "Author"} {
1556 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1557 } elseif {$ty == "Date"} {
1558 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1559 }
1560 }
1561 if {$doesmatch} {
1562 lappend matchinglines $l
1563 if {!$didsel && $l > $oldsel} {
1564 findselectline $l
1565 set didsel 1
1566 }
1567 }
1568 }
1569 if {$matchinglines == {}} {
1570 bell
1571 } elseif {!$didsel} {
1572 findselectline [lindex $matchinglines 0]
1573 }
1574 }
1576 proc findselectline {l} {
1577 global findloc commentend ctext
1578 selectline $l 1
1579 if {$findloc == "All fields" || $findloc == "Comments"} {
1580 # highlight the matches in the comments
1581 set f [$ctext get 1.0 $commentend]
1582 set matches [findmatches $f]
1583 foreach match $matches {
1584 set start [lindex $match 0]
1585 set end [expr [lindex $match 1] + 1]
1586 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1587 }
1588 }
1589 }
1591 proc findnext {restart} {
1592 global matchinglines selectedline
1593 if {![info exists matchinglines]} {
1594 if {$restart} {
1595 dofind
1596 }
1597 return
1598 }
1599 if {![info exists selectedline]} return
1600 foreach l $matchinglines {
1601 if {$l > $selectedline} {
1602 findselectline $l
1603 return
1604 }
1605 }
1606 bell
1607 }
1609 proc findprev {} {
1610 global matchinglines selectedline
1611 if {![info exists matchinglines]} {
1612 dofind
1613 return
1614 }
1615 if {![info exists selectedline]} return
1616 set prev {}
1617 foreach l $matchinglines {
1618 if {$l >= $selectedline} break
1619 set prev $l
1620 }
1621 if {$prev != {}} {
1622 findselectline $prev
1623 } else {
1624 bell
1625 }
1626 }
1628 proc findlocchange {name ix op} {
1629 global findloc findtype findtypemenu
1630 if {$findloc == "Pickaxe"} {
1631 set findtype Exact
1632 set state disabled
1633 } else {
1634 set state normal
1635 }
1636 $findtypemenu entryconf 1 -state $state
1637 $findtypemenu entryconf 2 -state $state
1638 }
1640 proc stopfindproc {{done 0}} {
1641 global findprocpid findprocfile findids
1642 global ctext findoldcursor phase maincursor textcursor
1643 global findinprogress
1645 catch {unset findids}
1646 if {[info exists findprocpid]} {
1647 if {!$done} {
1648 catch {exec kill $findprocpid}
1649 }
1650 catch {close $findprocfile}
1651 unset findprocpid
1652 }
1653 if {[info exists findinprogress]} {
1654 unset findinprogress
1655 if {$phase != "incrdraw"} {
1656 . config -cursor $maincursor
1657 settextcursor $textcursor
1658 }
1659 }
1660 }
1662 proc findpatches {} {
1663 global findstring selectedline numcommits
1664 global findprocpid findprocfile
1665 global finddidsel ctext lineid findinprogress
1666 global findinsertpos
1668 if {$numcommits == 0} return
1670 # make a list of all the ids to search, starting at the one
1671 # after the selected line (if any)
1672 if {[info exists selectedline]} {
1673 set l $selectedline
1674 } else {
1675 set l -1
1676 }
1677 set inputids {}
1678 for {set i 0} {$i < $numcommits} {incr i} {
1679 if {[incr l] >= $numcommits} {
1680 set l 0
1681 }
1682 append inputids $lineid($l) "\n"
1683 }
1685 if {[catch {
1686 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1687 << $inputids] r]
1688 } err]} {
1689 error_popup "Error starting search process: $err"
1690 return
1691 }
1693 set findinsertpos end
1694 set findprocfile $f
1695 set findprocpid [pid $f]
1696 fconfigure $f -blocking 0
1697 fileevent $f readable readfindproc
1698 set finddidsel 0
1699 . config -cursor watch
1700 settextcursor watch
1701 set findinprogress 1
1702 }
1704 proc readfindproc {} {
1705 global findprocfile finddidsel
1706 global idline matchinglines findinsertpos
1708 set n [gets $findprocfile line]
1709 if {$n < 0} {
1710 if {[eof $findprocfile]} {
1711 stopfindproc 1
1712 if {!$finddidsel} {
1713 bell
1714 }
1715 }
1716 return
1717 }
1718 if {![regexp {^[0-9a-f]{40}} $line id]} {
1719 error_popup "Can't parse git-diff-tree output: $line"
1720 stopfindproc
1721 return
1722 }
1723 if {![info exists idline($id)]} {
1724 puts stderr "spurious id: $id"
1725 return
1726 }
1727 set l $idline($id)
1728 insertmatch $l $id
1729 }
1731 proc insertmatch {l id} {
1732 global matchinglines findinsertpos finddidsel
1734 if {$findinsertpos == "end"} {
1735 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1736 set matchinglines [linsert $matchinglines 0 $l]
1737 set findinsertpos 1
1738 } else {
1739 lappend matchinglines $l
1740 }
1741 } else {
1742 set matchinglines [linsert $matchinglines $findinsertpos $l]
1743 incr findinsertpos
1744 }
1745 markheadline $l $id
1746 if {!$finddidsel} {
1747 findselectline $l
1748 set finddidsel 1
1749 }
1750 }
1752 proc findfiles {} {
1753 global selectedline numcommits lineid ctext
1754 global ffileline finddidsel parents nparents
1755 global findinprogress findstartline findinsertpos
1756 global treediffs fdiffids fdiffsneeded fdiffpos
1757 global findmergefiles
1759 if {$numcommits == 0} return
1761 if {[info exists selectedline]} {
1762 set l [expr {$selectedline + 1}]
1763 } else {
1764 set l 0
1765 }
1766 set ffileline $l
1767 set findstartline $l
1768 set diffsneeded {}
1769 set fdiffsneeded {}
1770 while 1 {
1771 set id $lineid($l)
1772 if {$findmergefiles || $nparents($id) == 1} {
1773 foreach p $parents($id) {
1774 if {![info exists treediffs([list $id $p])]} {
1775 append diffsneeded "$id $p\n"
1776 lappend fdiffsneeded [list $id $p]
1777 }
1778 }
1779 }
1780 if {[incr l] >= $numcommits} {
1781 set l 0
1782 }
1783 if {$l == $findstartline} break
1784 }
1786 # start off a git-diff-tree process if needed
1787 if {$diffsneeded ne {}} {
1788 if {[catch {
1789 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1790 } err ]} {
1791 error_popup "Error starting search process: $err"
1792 return
1793 }
1794 catch {unset fdiffids}
1795 set fdiffpos 0
1796 fconfigure $df -blocking 0
1797 fileevent $df readable [list readfilediffs $df]
1798 }
1800 set finddidsel 0
1801 set findinsertpos end
1802 set id $lineid($l)
1803 set p [lindex $parents($id) 0]
1804 . config -cursor watch
1805 settextcursor watch
1806 set findinprogress 1
1807 findcont [list $id $p]
1808 update
1809 }
1811 proc readfilediffs {df} {
1812 global findids fdiffids fdiffs
1814 set n [gets $df line]
1815 if {$n < 0} {
1816 if {[eof $df]} {
1817 donefilediff
1818 if {[catch {close $df} err]} {
1819 stopfindproc
1820 bell
1821 error_popup "Error in git-diff-tree: $err"
1822 } elseif {[info exists findids]} {
1823 set ids $findids
1824 stopfindproc
1825 bell
1826 error_popup "Couldn't find diffs for {$ids}"
1827 }
1828 }
1829 return
1830 }
1831 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1832 # start of a new string of diffs
1833 donefilediff
1834 set fdiffids [list $id $p]
1835 set fdiffs {}
1836 } elseif {[string match ":*" $line]} {
1837 lappend fdiffs [lindex $line 5]
1838 }
1839 }
1841 proc donefilediff {} {
1842 global fdiffids fdiffs treediffs findids
1843 global fdiffsneeded fdiffpos
1845 if {[info exists fdiffids]} {
1846 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1847 && $fdiffpos < [llength $fdiffsneeded]} {
1848 # git-diff-tree doesn't output anything for a commit
1849 # which doesn't change anything
1850 set nullids [lindex $fdiffsneeded $fdiffpos]
1851 set treediffs($nullids) {}
1852 if {[info exists findids] && $nullids eq $findids} {
1853 unset findids
1854 findcont $nullids
1855 }
1856 incr fdiffpos
1857 }
1858 incr fdiffpos
1860 if {![info exists treediffs($fdiffids)]} {
1861 set treediffs($fdiffids) $fdiffs
1862 }
1863 if {[info exists findids] && $fdiffids eq $findids} {
1864 unset findids
1865 findcont $fdiffids
1866 }
1867 }
1868 }
1870 proc findcont {ids} {
1871 global findids treediffs parents nparents
1872 global ffileline findstartline finddidsel
1873 global lineid numcommits matchinglines findinprogress
1874 global findmergefiles
1876 set id [lindex $ids 0]
1877 set p [lindex $ids 1]
1878 set pi [lsearch -exact $parents($id) $p]
1879 set l $ffileline
1880 while 1 {
1881 if {$findmergefiles || $nparents($id) == 1} {
1882 if {![info exists treediffs($ids)]} {
1883 set findids $ids
1884 set ffileline $l
1885 return
1886 }
1887 set doesmatch 0
1888 foreach f $treediffs($ids) {
1889 set x [findmatches $f]
1890 if {$x != {}} {
1891 set doesmatch 1
1892 break
1893 }
1894 }
1895 if {$doesmatch} {
1896 insertmatch $l $id
1897 set pi $nparents($id)
1898 }
1899 } else {
1900 set pi $nparents($id)
1901 }
1902 if {[incr pi] >= $nparents($id)} {
1903 set pi 0
1904 if {[incr l] >= $numcommits} {
1905 set l 0
1906 }
1907 if {$l == $findstartline} break
1908 set id $lineid($l)
1909 }
1910 set p [lindex $parents($id) $pi]
1911 set ids [list $id $p]
1912 }
1913 stopfindproc
1914 if {!$finddidsel} {
1915 bell
1916 }
1917 }
1919 # mark a commit as matching by putting a yellow background
1920 # behind the headline
1921 proc markheadline {l id} {
1922 global canv mainfont linehtag commitinfo
1924 set bbox [$canv bbox $linehtag($l)]
1925 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1926 $canv lower $t
1927 }
1929 # mark the bits of a headline, author or date that match a find string
1930 proc markmatches {canv l str tag matches font} {
1931 set bbox [$canv bbox $tag]
1932 set x0 [lindex $bbox 0]
1933 set y0 [lindex $bbox 1]
1934 set y1 [lindex $bbox 3]
1935 foreach match $matches {
1936 set start [lindex $match 0]
1937 set end [lindex $match 1]
1938 if {$start > $end} continue
1939 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1940 set xlen [font measure $font [string range $str 0 [expr $end]]]
1941 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1942 -outline {} -tags matches -fill yellow]
1943 $canv lower $t
1944 }
1945 }
1947 proc unmarkmatches {} {
1948 global matchinglines findids
1949 allcanvs delete matches
1950 catch {unset matchinglines}
1951 catch {unset findids}
1952 }
1954 proc selcanvline {w x y} {
1955 global canv canvy0 ctext linespc
1956 global lineid linehtag linentag linedtag rowtextx
1957 set ymax [lindex [$canv cget -scrollregion] 3]
1958 if {$ymax == {}} return
1959 set yfrac [lindex [$canv yview] 0]
1960 set y [expr {$y + $yfrac * $ymax}]
1961 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1962 if {$l < 0} {
1963 set l 0
1964 }
1965 if {$w eq $canv} {
1966 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1967 }
1968 unmarkmatches
1969 selectline $l 1
1970 }
1972 proc commit_descriptor {p} {
1973 global commitinfo
1974 set l "..."
1975 if {[info exists commitinfo($p)]} {
1976 set l [lindex $commitinfo($p) 0]
1977 }
1978 return "$p ($l)"
1979 }
1981 proc selectline {l isnew} {
1982 global canv canv2 canv3 ctext commitinfo selectedline
1983 global lineid linehtag linentag linedtag
1984 global canvy0 linespc parents nparents children
1985 global cflist currentid sha1entry
1986 global commentend idtags idline
1988 $canv delete hover
1989 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1990 $canv delete secsel
1991 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1992 -tags secsel -fill [$canv cget -selectbackground]]
1993 $canv lower $t
1994 $canv2 delete secsel
1995 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1996 -tags secsel -fill [$canv2 cget -selectbackground]]
1997 $canv2 lower $t
1998 $canv3 delete secsel
1999 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2000 -tags secsel -fill [$canv3 cget -selectbackground]]
2001 $canv3 lower $t
2002 set y [expr {$canvy0 + $l * $linespc}]
2003 set ymax [lindex [$canv cget -scrollregion] 3]
2004 set ytop [expr {$y - $linespc - 1}]
2005 set ybot [expr {$y + $linespc + 1}]
2006 set wnow [$canv yview]
2007 set wtop [expr [lindex $wnow 0] * $ymax]
2008 set wbot [expr [lindex $wnow 1] * $ymax]
2009 set wh [expr {$wbot - $wtop}]
2010 set newtop $wtop
2011 if {$ytop < $wtop} {
2012 if {$ybot < $wtop} {
2013 set newtop [expr {$y - $wh / 2.0}]
2014 } else {
2015 set newtop $ytop
2016 if {$newtop > $wtop - $linespc} {
2017 set newtop [expr {$wtop - $linespc}]
2018 }
2019 }
2020 } elseif {$ybot > $wbot} {
2021 if {$ytop > $wbot} {
2022 set newtop [expr {$y - $wh / 2.0}]
2023 } else {
2024 set newtop [expr {$ybot - $wh}]
2025 if {$newtop < $wtop + $linespc} {
2026 set newtop [expr {$wtop + $linespc}]
2027 }
2028 }
2029 }
2030 if {$newtop != $wtop} {
2031 if {$newtop < 0} {
2032 set newtop 0
2033 }
2034 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
2035 }
2037 if {$isnew} {
2038 addtohistory [list selectline $l 0]
2039 }
2041 set selectedline $l
2043 set id $lineid($l)
2044 set currentid $id
2045 $sha1entry delete 0 end
2046 $sha1entry insert 0 $id
2047 $sha1entry selection from 0
2048 $sha1entry selection to end
2050 $ctext conf -state normal
2051 $ctext delete 0.0 end
2052 $ctext mark set fmark.0 0.0
2053 $ctext mark gravity fmark.0 left
2054 set info $commitinfo($id)
2055 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
2056 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
2057 if {[info exists idtags($id)]} {
2058 $ctext insert end "Tags:"
2059 foreach tag $idtags($id) {
2060 $ctext insert end " $tag"
2061 }
2062 $ctext insert end "\n"
2063 }
2065 set commentstart [$ctext index "end - 1c"]
2066 set comment {}
2067 if {[info exists parents($id)]} {
2068 foreach p $parents($id) {
2069 append comment "Parent: [commit_descriptor $p]\n"
2070 }
2071 }
2072 if {[info exists children($id)]} {
2073 foreach c $children($id) {
2074 append comment "Child: [commit_descriptor $c]\n"
2075 }
2076 }
2077 append comment "\n"
2078 append comment [lindex $info 5]
2079 $ctext insert end $comment
2080 $ctext insert end "\n"
2082 # make anything that looks like a SHA1 ID be a clickable link
2083 set links [regexp -indices -all -inline {[0-9a-f]{40}} $comment]
2084 set i 0
2085 foreach l $links {
2086 set s [lindex $l 0]
2087 set e [lindex $l 1]
2088 set linkid [string range $comment $s $e]
2089 if {![info exists idline($linkid)]} continue
2090 incr e
2091 $ctext tag add link "$commentstart + $s c" "$commentstart + $e c"
2092 $ctext tag add link$i "$commentstart + $s c" "$commentstart + $e c"
2093 $ctext tag bind link$i <1> [list selectline $idline($linkid) 1]
2094 incr i
2095 }
2096 $ctext tag conf link -foreground blue -underline 1
2097 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2098 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2100 $ctext tag delete Comments
2101 $ctext tag remove found 1.0 end
2102 $ctext conf -state disabled
2103 set commentend [$ctext index "end - 1c"]
2105 $cflist delete 0 end
2106 $cflist insert end "Comments"
2107 if {$nparents($id) == 1} {
2108 startdiff [concat $id $parents($id)]
2109 } elseif {$nparents($id) > 1} {
2110 mergediff $id
2111 }
2112 }
2114 proc selnextline {dir} {
2115 global selectedline
2116 if {![info exists selectedline]} return
2117 set l [expr $selectedline + $dir]
2118 unmarkmatches
2119 selectline $l 1
2120 }
2122 proc unselectline {} {
2123 global selectedline
2125 catch {unset selectedline}
2126 allcanvs delete secsel
2127 }
2129 proc addtohistory {cmd} {
2130 global history historyindex
2132 if {$historyindex > 0
2133 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2134 return
2135 }
2137 if {$historyindex < [llength $history]} {
2138 set history [lreplace $history $historyindex end $cmd]
2139 } else {
2140 lappend history $cmd
2141 }
2142 incr historyindex
2143 if {$historyindex > 1} {
2144 .ctop.top.bar.leftbut conf -state normal
2145 } else {
2146 .ctop.top.bar.leftbut conf -state disabled
2147 }
2148 .ctop.top.bar.rightbut conf -state disabled
2149 }
2151 proc goback {} {
2152 global history historyindex
2154 if {$historyindex > 1} {
2155 incr historyindex -1
2156 set cmd [lindex $history [expr {$historyindex - 1}]]
2157 eval $cmd
2158 .ctop.top.bar.rightbut conf -state normal
2159 }
2160 if {$historyindex <= 1} {
2161 .ctop.top.bar.leftbut conf -state disabled
2162 }
2163 }
2165 proc goforw {} {
2166 global history historyindex
2168 if {$historyindex < [llength $history]} {
2169 set cmd [lindex $history $historyindex]
2170 incr historyindex
2171 eval $cmd
2172 .ctop.top.bar.leftbut conf -state normal
2173 }
2174 if {$historyindex >= [llength $history]} {
2175 .ctop.top.bar.rightbut conf -state disabled
2176 }
2177 }
2179 proc mergediff {id} {
2180 global parents diffmergeid diffmergegca mergefilelist diffpindex
2182 set diffmergeid $id
2183 set diffpindex -1
2184 set diffmergegca [findgca $parents($id)]
2185 if {[info exists mergefilelist($id)]} {
2186 if {$mergefilelist($id) ne {}} {
2187 showmergediff
2188 }
2189 } else {
2190 contmergediff {}
2191 }
2192 }
2194 proc findgca {ids} {
2195 set gca {}
2196 foreach id $ids {
2197 if {$gca eq {}} {
2198 set gca $id
2199 } else {
2200 if {[catch {
2201 set gca [exec git-merge-base $gca $id]
2202 } err]} {
2203 return {}
2204 }
2205 }
2206 }
2207 return $gca
2208 }
2210 proc contmergediff {ids} {
2211 global diffmergeid diffpindex parents nparents diffmergegca
2212 global treediffs mergefilelist diffids treepending
2214 # diff the child against each of the parents, and diff
2215 # each of the parents against the GCA.
2216 while 1 {
2217 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2218 set ids [list [lindex $ids 1] $diffmergegca]
2219 } else {
2220 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2221 set p [lindex $parents($diffmergeid) $diffpindex]
2222 set ids [list $diffmergeid $p]
2223 }
2224 if {![info exists treediffs($ids)]} {
2225 set diffids $ids
2226 if {![info exists treepending]} {
2227 gettreediffs $ids
2228 }
2229 return
2230 }
2231 }
2233 # If a file in some parent is different from the child and also
2234 # different from the GCA, then it's interesting.
2235 # If we don't have a GCA, then a file is interesting if it is
2236 # different from the child in all the parents.
2237 if {$diffmergegca ne {}} {
2238 set files {}
2239 foreach p $parents($diffmergeid) {
2240 set gcadiffs $treediffs([list $p $diffmergegca])
2241 foreach f $treediffs([list $diffmergeid $p]) {
2242 if {[lsearch -exact $files $f] < 0
2243 && [lsearch -exact $gcadiffs $f] >= 0} {
2244 lappend files $f
2245 }
2246 }
2247 }
2248 set files [lsort $files]
2249 } else {
2250 set p [lindex $parents($diffmergeid) 0]
2251 set files $treediffs([list $diffmergeid $p])
2252 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2253 set p [lindex $parents($diffmergeid) $i]
2254 set df $treediffs([list $diffmergeid $p])
2255 set nf {}
2256 foreach f $files {
2257 if {[lsearch -exact $df $f] >= 0} {
2258 lappend nf $f
2259 }
2260 }
2261 set files $nf
2262 }
2263 }
2265 set mergefilelist($diffmergeid) $files
2266 if {$files ne {}} {
2267 showmergediff
2268 }
2269 }
2271 proc showmergediff {} {
2272 global cflist diffmergeid mergefilelist parents
2273 global diffopts diffinhunk currentfile currenthunk filelines
2274 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2276 set files $mergefilelist($diffmergeid)
2277 foreach f $files {
2278 $cflist insert end $f
2279 }
2280 set env(GIT_DIFF_OPTS) $diffopts
2281 set flist {}
2282 catch {unset currentfile}
2283 catch {unset currenthunk}
2284 catch {unset filelines}
2285 catch {unset groupfilenum}
2286 catch {unset grouphunks}
2287 set groupfilelast -1
2288 foreach p $parents($diffmergeid) {
2289 set cmd [list | git-diff-tree -p $p $diffmergeid]
2290 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2291 if {[catch {set f [open $cmd r]} err]} {
2292 error_popup "Error getting diffs: $err"
2293 foreach f $flist {
2294 catch {close $f}
2295 }
2296 return
2297 }
2298 lappend flist $f
2299 set ids [list $diffmergeid $p]
2300 set mergefds($ids) $f
2301 set diffinhunk($ids) 0
2302 set diffblocked($ids) 0
2303 fconfigure $f -blocking 0
2304 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2305 }
2306 }
2308 proc getmergediffline {f ids id} {
2309 global diffmergeid diffinhunk diffoldlines diffnewlines
2310 global currentfile currenthunk
2311 global diffoldstart diffnewstart diffoldlno diffnewlno
2312 global diffblocked mergefilelist
2313 global noldlines nnewlines difflcounts filelines
2315 set n [gets $f line]
2316 if {$n < 0} {
2317 if {![eof $f]} return
2318 }
2320 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2321 if {$n < 0} {
2322 close $f
2323 }
2324 return
2325 }
2327 if {$diffinhunk($ids) != 0} {
2328 set fi $currentfile($ids)
2329 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2330 # continuing an existing hunk
2331 set line [string range $line 1 end]
2332 set p [lindex $ids 1]
2333 if {$match eq "-" || $match eq " "} {
2334 set filelines($p,$fi,$diffoldlno($ids)) $line
2335 incr diffoldlno($ids)
2336 }
2337 if {$match eq "+" || $match eq " "} {
2338 set filelines($id,$fi,$diffnewlno($ids)) $line
2339 incr diffnewlno($ids)
2340 }
2341 if {$match eq " "} {
2342 if {$diffinhunk($ids) == 2} {
2343 lappend difflcounts($ids) \
2344 [list $noldlines($ids) $nnewlines($ids)]
2345 set noldlines($ids) 0
2346 set diffinhunk($ids) 1
2347 }
2348 incr noldlines($ids)
2349 } elseif {$match eq "-" || $match eq "+"} {
2350 if {$diffinhunk($ids) == 1} {
2351 lappend difflcounts($ids) [list $noldlines($ids)]
2352 set noldlines($ids) 0
2353 set nnewlines($ids) 0
2354 set diffinhunk($ids) 2
2355 }
2356 if {$match eq "-"} {
2357 incr noldlines($ids)
2358 } else {
2359 incr nnewlines($ids)
2360 }
2361 }
2362 # and if it's \ No newline at end of line, then what?
2363 return
2364 }
2365 # end of a hunk
2366 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2367 lappend difflcounts($ids) [list $noldlines($ids)]
2368 } elseif {$diffinhunk($ids) == 2
2369 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2370 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2371 }
2372 set currenthunk($ids) [list $currentfile($ids) \
2373 $diffoldstart($ids) $diffnewstart($ids) \
2374 $diffoldlno($ids) $diffnewlno($ids) \
2375 $difflcounts($ids)]
2376 set diffinhunk($ids) 0
2377 # -1 = need to block, 0 = unblocked, 1 = is blocked
2378 set diffblocked($ids) -1
2379 processhunks
2380 if {$diffblocked($ids) == -1} {
2381 fileevent $f readable {}
2382 set diffblocked($ids) 1
2383 }
2384 }
2386 if {$n < 0} {
2387 # eof
2388 if {!$diffblocked($ids)} {
2389 close $f
2390 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2391 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2392 processhunks
2393 }
2394 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2395 # start of a new file
2396 set currentfile($ids) \
2397 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2398 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2399 $line match f1l f1c f2l f2c rest]} {
2400 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2401 # start of a new hunk
2402 if {$f1l == 0 && $f1c == 0} {
2403 set f1l 1
2404 }
2405 if {$f2l == 0 && $f2c == 0} {
2406 set f2l 1
2407 }
2408 set diffinhunk($ids) 1
2409 set diffoldstart($ids) $f1l
2410 set diffnewstart($ids) $f2l
2411 set diffoldlno($ids) $f1l
2412 set diffnewlno($ids) $f2l
2413 set difflcounts($ids) {}
2414 set noldlines($ids) 0
2415 set nnewlines($ids) 0
2416 }
2417 }
2418 }
2420 proc processhunks {} {
2421 global diffmergeid parents nparents currenthunk
2422 global mergefilelist diffblocked mergefds
2423 global grouphunks grouplinestart grouplineend groupfilenum
2425 set nfiles [llength $mergefilelist($diffmergeid)]
2426 while 1 {
2427 set fi $nfiles
2428 set lno 0
2429 # look for the earliest hunk
2430 foreach p $parents($diffmergeid) {
2431 set ids [list $diffmergeid $p]
2432 if {![info exists currenthunk($ids)]} return
2433 set i [lindex $currenthunk($ids) 0]
2434 set l [lindex $currenthunk($ids) 2]
2435 if {$i < $fi || ($i == $fi && $l < $lno)} {
2436 set fi $i
2437 set lno $l
2438 set pi $p
2439 }
2440 }
2442 if {$fi < $nfiles} {
2443 set ids [list $diffmergeid $pi]
2444 set hunk $currenthunk($ids)
2445 unset currenthunk($ids)
2446 if {$diffblocked($ids) > 0} {
2447 fileevent $mergefds($ids) readable \
2448 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2449 }
2450 set diffblocked($ids) 0
2452 if {[info exists groupfilenum] && $groupfilenum == $fi
2453 && $lno <= $grouplineend} {
2454 # add this hunk to the pending group
2455 lappend grouphunks($pi) $hunk
2456 set endln [lindex $hunk 4]
2457 if {$endln > $grouplineend} {
2458 set grouplineend $endln
2459 }
2460 continue
2461 }
2462 }
2464 # succeeding stuff doesn't belong in this group, so
2465 # process the group now
2466 if {[info exists groupfilenum]} {
2467 processgroup
2468 unset groupfilenum
2469 unset grouphunks
2470 }
2472 if {$fi >= $nfiles} break
2474 # start a new group
2475 set groupfilenum $fi
2476 set grouphunks($pi) [list $hunk]
2477 set grouplinestart $lno
2478 set grouplineend [lindex $hunk 4]
2479 }
2480 }
2482 proc processgroup {} {
2483 global groupfilelast groupfilenum difffilestart
2484 global mergefilelist diffmergeid ctext filelines
2485 global parents diffmergeid diffoffset
2486 global grouphunks grouplinestart grouplineend nparents
2487 global mergemax
2489 $ctext conf -state normal
2490 set id $diffmergeid
2491 set f $groupfilenum
2492 if {$groupfilelast != $f} {
2493 $ctext insert end "\n"
2494 set here [$ctext index "end - 1c"]
2495 set difffilestart($f) $here
2496 set mark fmark.[expr {$f + 1}]
2497 $ctext mark set $mark $here
2498 $ctext mark gravity $mark left
2499 set header [lindex $mergefilelist($id) $f]
2500 set l [expr {(78 - [string length $header]) / 2}]
2501 set pad [string range "----------------------------------------" 1 $l]
2502 $ctext insert end "$pad $header $pad\n" filesep
2503 set groupfilelast $f
2504 foreach p $parents($id) {
2505 set diffoffset($p) 0
2506 }
2507 }
2509 $ctext insert end "@@" msep
2510 set nlines [expr {$grouplineend - $grouplinestart}]
2511 set events {}
2512 set pnum 0
2513 foreach p $parents($id) {
2514 set startline [expr {$grouplinestart + $diffoffset($p)}]
2515 set ol $startline
2516 set nl $grouplinestart
2517 if {[info exists grouphunks($p)]} {
2518 foreach h $grouphunks($p) {
2519 set l [lindex $h 2]
2520 if {$nl < $l} {
2521 for {} {$nl < $l} {incr nl} {
2522 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2523 incr ol
2524 }
2525 }
2526 foreach chunk [lindex $h 5] {
2527 if {[llength $chunk] == 2} {
2528 set olc [lindex $chunk 0]
2529 set nlc [lindex $chunk 1]
2530 set nnl [expr {$nl + $nlc}]
2531 lappend events [list $nl $nnl $pnum $olc $nlc]
2532 incr ol $olc
2533 set nl $nnl
2534 } else {
2535 incr ol [lindex $chunk 0]
2536 incr nl [lindex $chunk 0]
2537 }
2538 }
2539 }
2540 }
2541 if {$nl < $grouplineend} {
2542 for {} {$nl < $grouplineend} {incr nl} {
2543 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2544 incr ol
2545 }
2546 }
2547 set nlines [expr {$ol - $startline}]
2548 $ctext insert end " -$startline,$nlines" msep
2549 incr pnum
2550 }
2552 set nlines [expr {$grouplineend - $grouplinestart}]
2553 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2555 set events [lsort -integer -index 0 $events]
2556 set nevents [llength $events]
2557 set nmerge $nparents($diffmergeid)
2558 set l $grouplinestart
2559 for {set i 0} {$i < $nevents} {set i $j} {
2560 set nl [lindex $events $i 0]
2561 while {$l < $nl} {
2562 $ctext insert end " $filelines($id,$f,$l)\n"
2563 incr l
2564 }
2565 set e [lindex $events $i]
2566 set enl [lindex $e 1]
2567 set j $i
2568 set active {}
2569 while 1 {
2570 set pnum [lindex $e 2]
2571 set olc [lindex $e 3]
2572 set nlc [lindex $e 4]
2573 if {![info exists delta($pnum)]} {
2574 set delta($pnum) [expr {$olc - $nlc}]
2575 lappend active $pnum
2576 } else {
2577 incr delta($pnum) [expr {$olc - $nlc}]
2578 }
2579 if {[incr j] >= $nevents} break
2580 set e [lindex $events $j]
2581 if {[lindex $e 0] >= $enl} break
2582 if {[lindex $e 1] > $enl} {
2583 set enl [lindex $e 1]
2584 }
2585 }
2586 set nlc [expr {$enl - $l}]
2587 set ncol mresult
2588 set bestpn -1
2589 if {[llength $active] == $nmerge - 1} {
2590 # no diff for one of the parents, i.e. it's identical
2591 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2592 if {![info exists delta($pnum)]} {
2593 if {$pnum < $mergemax} {
2594 lappend ncol m$pnum
2595 } else {
2596 lappend ncol mmax
2597 }
2598 break
2599 }
2600 }
2601 } elseif {[llength $active] == $nmerge} {
2602 # all parents are different, see if one is very similar
2603 set bestsim 30
2604 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2605 set sim [similarity $pnum $l $nlc $f \
2606 [lrange $events $i [expr {$j-1}]]]
2607 if {$sim > $bestsim} {
2608 set bestsim $sim
2609 set bestpn $pnum
2610 }
2611 }
2612 if {$bestpn >= 0} {
2613 lappend ncol m$bestpn
2614 }
2615 }
2616 set pnum -1
2617 foreach p $parents($id) {
2618 incr pnum
2619 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2620 set olc [expr {$nlc + $delta($pnum)}]
2621 set ol [expr {$l + $diffoffset($p)}]
2622 incr diffoffset($p) $delta($pnum)
2623 unset delta($pnum)
2624 for {} {$olc > 0} {incr olc -1} {
2625 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2626 incr ol
2627 }
2628 }
2629 set endl [expr {$l + $nlc}]
2630 if {$bestpn >= 0} {
2631 # show this pretty much as a normal diff
2632 set p [lindex $parents($id) $bestpn]
2633 set ol [expr {$l + $diffoffset($p)}]
2634 incr diffoffset($p) $delta($bestpn)
2635 unset delta($bestpn)
2636 for {set k $i} {$k < $j} {incr k} {
2637 set e [lindex $events $k]
2638 if {[lindex $e 2] != $bestpn} continue
2639 set nl [lindex $e 0]
2640 set ol [expr {$ol + $nl - $l}]
2641 for {} {$l < $nl} {incr l} {
2642 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2643 }
2644 set c [lindex $e 3]
2645 for {} {$c > 0} {incr c -1} {
2646 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2647 incr ol
2648 }
2649 set nl [lindex $e 1]
2650 for {} {$l < $nl} {incr l} {
2651 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2652 }
2653 }
2654 }
2655 for {} {$l < $endl} {incr l} {
2656 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2657 }
2658 }
2659 while {$l < $grouplineend} {
2660 $ctext insert end " $filelines($id,$f,$l)\n"
2661 incr l
2662 }
2663 $ctext conf -state disabled
2664 }
2666 proc similarity {pnum l nlc f events} {
2667 global diffmergeid parents diffoffset filelines
2669 set id $diffmergeid
2670 set p [lindex $parents($id) $pnum]
2671 set ol [expr {$l + $diffoffset($p)}]
2672 set endl [expr {$l + $nlc}]
2673 set same 0
2674 set diff 0
2675 foreach e $events {
2676 if {[lindex $e 2] != $pnum} continue
2677 set nl [lindex $e 0]
2678 set ol [expr {$ol + $nl - $l}]
2679 for {} {$l < $nl} {incr l} {
2680 incr same [string length $filelines($id,$f,$l)]
2681 incr same
2682 }
2683 set oc [lindex $e 3]
2684 for {} {$oc > 0} {incr oc -1} {
2685 incr diff [string length $filelines($p,$f,$ol)]
2686 incr diff
2687 incr ol
2688 }
2689 set nl [lindex $e 1]
2690 for {} {$l < $nl} {incr l} {
2691 incr diff [string length $filelines($id,$f,$l)]
2692 incr diff
2693 }
2694 }
2695 for {} {$l < $endl} {incr l} {
2696 incr same [string length $filelines($id,$f,$l)]
2697 incr same
2698 }
2699 if {$same == 0} {
2700 return 0
2701 }
2702 return [expr {200 * $same / (2 * $same + $diff)}]
2703 }
2705 proc startdiff {ids} {
2706 global treediffs diffids treepending diffmergeid
2708 set diffids $ids
2709 catch {unset diffmergeid}
2710 if {![info exists treediffs($ids)]} {
2711 if {![info exists treepending]} {
2712 gettreediffs $ids
2713 }
2714 } else {
2715 addtocflist $ids
2716 }
2717 }
2719 proc addtocflist {ids} {
2720 global treediffs cflist
2721 foreach f $treediffs($ids) {
2722 $cflist insert end $f
2723 }
2724 getblobdiffs $ids
2725 }
2727 proc gettreediffs {ids} {
2728 global treediff parents treepending
2729 set treepending $ids
2730 set treediff {}
2731 set id [lindex $ids 0]
2732 set p [lindex $ids 1]
2733 if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2734 fconfigure $gdtf -blocking 0
2735 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2736 }
2738 proc gettreediffline {gdtf ids} {
2739 global treediff treediffs treepending diffids diffmergeid
2741 set n [gets $gdtf line]
2742 if {$n < 0} {
2743 if {![eof $gdtf]} return
2744 close $gdtf
2745 set treediffs($ids) $treediff
2746 unset treepending
2747 if {$ids != $diffids} {
2748 gettreediffs $diffids
2749 } else {
2750 if {[info exists diffmergeid]} {
2751 contmergediff $ids
2752 } else {
2753 addtocflist $ids
2754 }
2755 }
2756 return
2757 }
2758 set file [lindex $line 5]
2759 lappend treediff $file
2760 }
2762 proc getblobdiffs {ids} {
2763 global diffopts blobdifffd diffids env curdifftag curtagstart
2764 global difffilestart nextupdate diffinhdr treediffs
2766 set id [lindex $ids 0]
2767 set p [lindex $ids 1]
2768 set env(GIT_DIFF_OPTS) $diffopts
2769 set cmd [list | git-diff-tree -r -p -C $p $id]
2770 if {[catch {set bdf [open $cmd r]} err]} {
2771 puts "error getting diffs: $err"
2772 return
2773 }
2774 set diffinhdr 0
2775 fconfigure $bdf -blocking 0
2776 set blobdifffd($ids) $bdf
2777 set curdifftag Comments
2778 set curtagstart 0.0
2779 catch {unset difffilestart}
2780 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2781 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2782 }
2784 proc getblobdiffline {bdf ids} {
2785 global diffids blobdifffd ctext curdifftag curtagstart
2786 global diffnexthead diffnextnote difffilestart
2787 global nextupdate diffinhdr treediffs
2788 global gaudydiff
2790 set n [gets $bdf line]
2791 if {$n < 0} {
2792 if {[eof $bdf]} {
2793 close $bdf
2794 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2795 $ctext tag add $curdifftag $curtagstart end
2796 }
2797 }
2798 return
2799 }
2800 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2801 return
2802 }
2803 $ctext conf -state normal
2804 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2805 # start of a new file
2806 $ctext insert end "\n"
2807 $ctext tag add $curdifftag $curtagstart end
2808 set curtagstart [$ctext index "end - 1c"]
2809 set header $newname
2810 set here [$ctext index "end - 1c"]
2811 set i [lsearch -exact $treediffs($diffids) $fname]
2812 if {$i >= 0} {
2813 set difffilestart($i) $here
2814 incr i
2815 $ctext mark set fmark.$i $here
2816 $ctext mark gravity fmark.$i left
2817 }
2818 if {$newname != $fname} {
2819 set i [lsearch -exact $treediffs($diffids) $newname]
2820 if {$i >= 0} {
2821 set difffilestart($i) $here
2822 incr i
2823 $ctext mark set fmark.$i $here
2824 $ctext mark gravity fmark.$i left
2825 }
2826 }
2827 set curdifftag "f:$fname"
2828 $ctext tag delete $curdifftag
2829 set l [expr {(78 - [string length $header]) / 2}]
2830 set pad [string range "----------------------------------------" 1 $l]
2831 $ctext insert end "$pad $header $pad\n" filesep
2832 set diffinhdr 1
2833 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2834 set diffinhdr 0
2835 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2836 $line match f1l f1c f2l f2c rest]} {
2837 if {$gaudydiff} {
2838 $ctext insert end "\t" hunksep
2839 $ctext insert end " $f1l " d0 " $f2l " d1
2840 $ctext insert end " $rest \n" hunksep
2841 } else {
2842 $ctext insert end "$line\n" hunksep
2843 }
2844 set diffinhdr 0
2845 } else {
2846 set x [string range $line 0 0]
2847 if {$x == "-" || $x == "+"} {
2848 set tag [expr {$x == "+"}]
2849 if {$gaudydiff} {
2850 set line [string range $line 1 end]
2851 }
2852 $ctext insert end "$line\n" d$tag
2853 } elseif {$x == " "} {
2854 if {$gaudydiff} {
2855 set line [string range $line 1 end]
2856 }
2857 $ctext insert end "$line\n"
2858 } elseif {$diffinhdr || $x == "\\"} {
2859 # e.g. "\ No newline at end of file"
2860 $ctext insert end "$line\n" filesep
2861 } else {
2862 # Something else we don't recognize
2863 if {$curdifftag != "Comments"} {
2864 $ctext insert end "\n"
2865 $ctext tag add $curdifftag $curtagstart end
2866 set curtagstart [$ctext index "end - 1c"]
2867 set curdifftag Comments
2868 }
2869 $ctext insert end "$line\n" filesep
2870 }
2871 }
2872 $ctext conf -state disabled
2873 if {[clock clicks -milliseconds] >= $nextupdate} {
2874 incr nextupdate 100
2875 fileevent $bdf readable {}
2876 update
2877 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2878 }
2879 }
2881 proc nextfile {} {
2882 global difffilestart ctext
2883 set here [$ctext index @0,0]
2884 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2885 if {[$ctext compare $difffilestart($i) > $here]} {
2886 if {![info exists pos]
2887 || [$ctext compare $difffilestart($i) < $pos]} {
2888 set pos $difffilestart($i)
2889 }
2890 }
2891 }
2892 if {[info exists pos]} {
2893 $ctext yview $pos
2894 }
2895 }
2897 proc listboxsel {} {
2898 global ctext cflist currentid
2899 if {![info exists currentid]} return
2900 set sel [lsort [$cflist curselection]]
2901 if {$sel eq {}} return
2902 set first [lindex $sel 0]
2903 catch {$ctext yview fmark.$first}
2904 }
2906 proc setcoords {} {
2907 global linespc charspc canvx0 canvy0 mainfont
2908 global xspc1 xspc2 lthickness
2910 set linespc [font metrics $mainfont -linespace]
2911 set charspc [font measure $mainfont "m"]
2912 set canvy0 [expr 3 + 0.5 * $linespc]
2913 set canvx0 [expr 3 + 0.5 * $linespc]
2914 set lthickness [expr {int($linespc / 9) + 1}]
2915 set xspc1(0) $linespc
2916 set xspc2 $linespc
2917 }
2919 proc redisplay {} {
2920 global stopped redisplaying phase
2921 if {$stopped > 1} return
2922 if {$phase == "getcommits"} return
2923 set redisplaying 1
2924 if {$phase == "drawgraph" || $phase == "incrdraw"} {
2925 set stopped 1
2926 } else {
2927 drawgraph
2928 }
2929 }
2931 proc incrfont {inc} {
2932 global mainfont namefont textfont ctext canv phase
2933 global stopped entries
2934 unmarkmatches
2935 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2936 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2937 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2938 setcoords
2939 $ctext conf -font $textfont
2940 $ctext tag conf filesep -font [concat $textfont bold]
2941 foreach e $entries {
2942 $e conf -font $mainfont
2943 }
2944 if {$phase == "getcommits"} {
2945 $canv itemconf textitems -font $mainfont
2946 }
2947 redisplay
2948 }
2950 proc clearsha1 {} {
2951 global sha1entry sha1string
2952 if {[string length $sha1string] == 40} {
2953 $sha1entry delete 0 end
2954 }
2955 }
2957 proc sha1change {n1 n2 op} {
2958 global sha1string currentid sha1but
2959 if {$sha1string == {}
2960 || ([info exists currentid] && $sha1string == $currentid)} {
2961 set state disabled
2962 } else {
2963 set state normal
2964 }
2965 if {[$sha1but cget -state] == $state} return
2966 if {$state == "normal"} {
2967 $sha1but conf -state normal -relief raised -text "Goto: "
2968 } else {
2969 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2970 }
2971 }
2973 proc gotocommit {} {
2974 global sha1string currentid idline tagids
2975 global lineid numcommits
2977 if {$sha1string == {}
2978 || ([info exists currentid] && $sha1string == $currentid)} return
2979 if {[info exists tagids($sha1string)]} {
2980 set id $tagids($sha1string)
2981 } else {
2982 set id [string tolower $sha1string]
2983 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2984 set matches {}
2985 for {set l 0} {$l < $numcommits} {incr l} {
2986 if {[string match $id* $lineid($l)]} {
2987 lappend matches $lineid($l)
2988 }
2989 }
2990 if {$matches ne {}} {
2991 if {[llength $matches] > 1} {
2992 error_popup "Short SHA1 id $id is ambiguous"
2993 return
2994 }
2995 set id [lindex $matches 0]
2996 }
2997 }
2998 }
2999 if {[info exists idline($id)]} {
3000 selectline $idline($id) 1
3001 return
3002 }
3003 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3004 set type "SHA1 id"
3005 } else {
3006 set type "Tag"
3007 }
3008 error_popup "$type $sha1string is not known"
3009 }
3011 proc lineenter {x y id} {
3012 global hoverx hovery hoverid hovertimer
3013 global commitinfo canv
3015 if {![info exists commitinfo($id)]} return
3016 set hoverx $x
3017 set hovery $y
3018 set hoverid $id
3019 if {[info exists hovertimer]} {
3020 after cancel $hovertimer
3021 }
3022 set hovertimer [after 500 linehover]
3023 $canv delete hover
3024 }
3026 proc linemotion {x y id} {
3027 global hoverx hovery hoverid hovertimer
3029 if {[info exists hoverid] && $id == $hoverid} {
3030 set hoverx $x
3031 set hovery $y
3032 if {[info exists hovertimer]} {
3033 after cancel $hovertimer
3034 }
3035 set hovertimer [after 500 linehover]
3036 }
3037 }
3039 proc lineleave {id} {
3040 global hoverid hovertimer canv
3042 if {[info exists hoverid] && $id == $hoverid} {
3043 $canv delete hover
3044 if {[info exists hovertimer]} {
3045 after cancel $hovertimer
3046 unset hovertimer
3047 }
3048 unset hoverid
3049 }
3050 }
3052 proc linehover {} {
3053 global hoverx hovery hoverid hovertimer
3054 global canv linespc lthickness
3055 global commitinfo mainfont
3057 set text [lindex $commitinfo($hoverid) 0]
3058 set ymax [lindex [$canv cget -scrollregion] 3]
3059 if {$ymax == {}} return
3060 set yfrac [lindex [$canv yview] 0]
3061 set x [expr {$hoverx + 2 * $linespc}]
3062 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3063 set x0 [expr {$x - 2 * $lthickness}]
3064 set y0 [expr {$y - 2 * $lthickness}]
3065 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3066 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3067 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3068 -fill \#ffff80 -outline black -width 1 -tags hover]
3069 $canv raise $t
3070 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
3071 $canv raise $t
3072 }
3074 proc lineclick {x y id isnew} {
3075 global ctext commitinfo children cflist canv
3077 unmarkmatches
3078 unselectline
3079 if {$isnew} {
3080 addtohistory [list lineclick $x $x $id 0]
3081 }
3082 $canv delete hover
3083 # fill the details pane with info about this line
3084 $ctext conf -state normal
3085 $ctext delete 0.0 end
3086 $ctext tag conf link -foreground blue -underline 1
3087 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3088 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3089 $ctext insert end "Parent:\t"
3090 $ctext insert end $id [list link link0]
3091 $ctext tag bind link0 <1> [list selbyid $id]
3092 set info $commitinfo($id)
3093 $ctext insert end "\n\t[lindex $info 0]\n"
3094 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3095 $ctext insert end "\tDate:\t[lindex $info 2]\n"
3096 if {[info exists children($id)]} {
3097 $ctext insert end "\nChildren:"
3098 set i 0
3099 foreach child $children($id) {
3100 incr i
3101 set info $commitinfo($child)
3102 $ctext insert end "\n\t"
3103 $ctext insert end $child [list link link$i]
3104 $ctext tag bind link$i <1> [list selbyid $child]
3105 $ctext insert end "\n\t[lindex $info 0]"
3106 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3107 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
3108 }
3109 }
3110 $ctext conf -state disabled
3112 $cflist delete 0 end
3113 }
3115 proc selbyid {id} {
3116 global idline
3117 if {[info exists idline($id)]} {
3118 selectline $idline($id) 1
3119 }
3120 }
3122 proc mstime {} {
3123 global startmstime
3124 if {![info exists startmstime]} {
3125 set startmstime [clock clicks -milliseconds]
3126 }
3127 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3128 }
3130 proc rowmenu {x y id} {
3131 global rowctxmenu idline selectedline rowmenuid
3133 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3134 set state disabled
3135 } else {
3136 set state normal
3137 }
3138 $rowctxmenu entryconfigure 0 -state $state
3139 $rowctxmenu entryconfigure 1 -state $state
3140 $rowctxmenu entryconfigure 2 -state $state
3141 set rowmenuid $id
3142 tk_popup $rowctxmenu $x $y
3143 }
3145 proc diffvssel {dirn} {
3146 global rowmenuid selectedline lineid
3148 if {![info exists selectedline]} return
3149 if {$dirn} {
3150 set oldid $lineid($selectedline)
3151 set newid $rowmenuid
3152 } else {
3153 set oldid $rowmenuid
3154 set newid $lineid($selectedline)
3155 }
3156 addtohistory [list doseldiff $oldid $newid]
3157 doseldiff $oldid $newid
3158 }
3160 proc doseldiff {oldid newid} {
3161 global ctext cflist
3162 global commitinfo
3164 $ctext conf -state normal
3165 $ctext delete 0.0 end
3166 $ctext mark set fmark.0 0.0
3167 $ctext mark gravity fmark.0 left
3168 $cflist delete 0 end
3169 $cflist insert end "Top"
3170 $ctext insert end "From "
3171 $ctext tag conf link -foreground blue -underline 1
3172 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3173 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3174 $ctext tag bind link0 <1> [list selbyid $oldid]
3175 $ctext insert end $oldid [list link link0]
3176 $ctext insert end "\n "
3177 $ctext insert end [lindex $commitinfo($oldid) 0]
3178 $ctext insert end "\n\nTo "
3179 $ctext tag bind link1 <1> [list selbyid $newid]
3180 $ctext insert end $newid [list link link1]
3181 $ctext insert end "\n "
3182 $ctext insert end [lindex $commitinfo($newid) 0]
3183 $ctext insert end "\n"
3184 $ctext conf -state disabled
3185 $ctext tag delete Comments
3186 $ctext tag remove found 1.0 end
3187 startdiff [list $newid $oldid]
3188 }
3190 proc mkpatch {} {
3191 global rowmenuid currentid commitinfo patchtop patchnum
3193 if {![info exists currentid]} return
3194 set oldid $currentid
3195 set oldhead [lindex $commitinfo($oldid) 0]
3196 set newid $rowmenuid
3197 set newhead [lindex $commitinfo($newid) 0]
3198 set top .patch
3199 set patchtop $top
3200 catch {destroy $top}
3201 toplevel $top
3202 label $top.title -text "Generate patch"
3203 grid $top.title - -pady 10
3204 label $top.from -text "From:"
3205 entry $top.fromsha1 -width 40 -relief flat
3206 $top.fromsha1 insert 0 $oldid
3207 $top.fromsha1 conf -state readonly
3208 grid $top.from $top.fromsha1 -sticky w
3209 entry $top.fromhead -width 60 -relief flat
3210 $top.fromhead insert 0 $oldhead
3211 $top.fromhead conf -state readonly
3212 grid x $top.fromhead -sticky w
3213 label $top.to -text "To:"
3214 entry $top.tosha1 -width 40 -relief flat
3215 $top.tosha1 insert 0 $newid
3216 $top.tosha1 conf -state readonly
3217 grid $top.to $top.tosha1 -sticky w
3218 entry $top.tohead -width 60 -relief flat
3219 $top.tohead insert 0 $newhead
3220 $top.tohead conf -state readonly
3221 grid x $top.tohead -sticky w
3222 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3223 grid $top.rev x -pady 10
3224 label $top.flab -text "Output file:"
3225 entry $top.fname -width 60
3226 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3227 incr patchnum
3228 grid $top.flab $top.fname -sticky w
3229 frame $top.buts
3230 button $top.buts.gen -text "Generate" -command mkpatchgo
3231 button $top.buts.can -text "Cancel" -command mkpatchcan
3232 grid $top.buts.gen $top.buts.can
3233 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3234 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3235 grid $top.buts - -pady 10 -sticky ew
3236 focus $top.fname
3237 }
3239 proc mkpatchrev {} {
3240 global patchtop
3242 set oldid [$patchtop.fromsha1 get]
3243 set oldhead [$patchtop.fromhead get]
3244 set newid [$patchtop.tosha1 get]
3245 set newhead [$patchtop.tohead get]
3246 foreach e [list fromsha1 fromhead tosha1 tohead] \
3247 v [list $newid $newhead $oldid $oldhead] {
3248 $patchtop.$e conf -state normal
3249 $patchtop.$e delete 0 end
3250 $patchtop.$e insert 0 $v
3251 $patchtop.$e conf -state readonly
3252 }
3253 }
3255 proc mkpatchgo {} {
3256 global patchtop
3258 set oldid [$patchtop.fromsha1 get]
3259 set newid [$patchtop.tosha1 get]
3260 set fname [$patchtop.fname get]
3261 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3262 error_popup "Error creating patch: $err"
3263 }
3264 catch {destroy $patchtop}
3265 unset patchtop
3266 }
3268 proc mkpatchcan {} {
3269 global patchtop
3271 catch {destroy $patchtop}
3272 unset patchtop
3273 }
3275 proc mktag {} {
3276 global rowmenuid mktagtop commitinfo
3278 set top .maketag
3279 set mktagtop $top
3280 catch {destroy $top}
3281 toplevel $top
3282 label $top.title -text "Create tag"
3283 grid $top.title - -pady 10
3284 label $top.id -text "ID:"
3285 entry $top.sha1 -width 40 -relief flat
3286 $top.sha1 insert 0 $rowmenuid
3287 $top.sha1 conf -state readonly
3288 grid $top.id $top.sha1 -sticky w
3289 entry $top.head -width 60 -relief flat
3290 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3291 $top.head conf -state readonly
3292 grid x $top.head -sticky w
3293 label $top.tlab -text "Tag name:"
3294 entry $top.tag -width 60
3295 grid $top.tlab $top.tag -sticky w
3296 frame $top.buts
3297 button $top.buts.gen -text "Create" -command mktaggo
3298 button $top.buts.can -text "Cancel" -command mktagcan
3299 grid $top.buts.gen $top.buts.can
3300 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3301 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3302 grid $top.buts - -pady 10 -sticky ew
3303 focus $top.tag
3304 }
3306 proc domktag {} {
3307 global mktagtop env tagids idtags
3308 global idpos idline linehtag canv selectedline
3310 set id [$mktagtop.sha1 get]
3311 set tag [$mktagtop.tag get]
3312 if {$tag == {}} {
3313 error_popup "No tag name specified"
3314 return
3315 }
3316 if {[info exists tagids($tag)]} {
3317 error_popup "Tag \"$tag\" already exists"
3318 return
3319 }
3320 if {[catch {
3321 set dir [gitdir]
3322 set fname [file join $dir "refs/tags" $tag]
3323 set f [open $fname w]
3324 puts $f $id
3325 close $f
3326 } err]} {
3327 error_popup "Error creating tag: $err"
3328 return
3329 }
3331 set tagids($tag) $id
3332 lappend idtags($id) $tag
3333 $canv delete tag.$id
3334 set xt [eval drawtags $id $idpos($id)]
3335 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3336 if {[info exists selectedline] && $selectedline == $idline($id)} {
3337 selectline $selectedline 0
3338 }
3339 }
3341 proc mktagcan {} {
3342 global mktagtop
3344 catch {destroy $mktagtop}
3345 unset mktagtop
3346 }
3348 proc mktaggo {} {
3349 domktag
3350 mktagcan
3351 }
3353 proc writecommit {} {
3354 global rowmenuid wrcomtop commitinfo wrcomcmd
3356 set top .writecommit
3357 set wrcomtop $top
3358 catch {destroy $top}
3359 toplevel $top
3360 label $top.title -text "Write commit to file"
3361 grid $top.title - -pady 10
3362 label $top.id -text "ID:"
3363 entry $top.sha1 -width 40 -relief flat
3364 $top.sha1 insert 0 $rowmenuid
3365 $top.sha1 conf -state readonly
3366 grid $top.id $top.sha1 -sticky w
3367 entry $top.head -width 60 -relief flat
3368 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3369 $top.head conf -state readonly
3370 grid x $top.head -sticky w
3371 label $top.clab -text "Command:"
3372 entry $top.cmd -width 60 -textvariable wrcomcmd
3373 grid $top.clab $top.cmd -sticky w -pady 10
3374 label $top.flab -text "Output file:"
3375 entry $top.fname -width 60
3376 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3377 grid $top.flab $top.fname -sticky w
3378 frame $top.buts
3379 button $top.buts.gen -text "Write" -command wrcomgo
3380 button $top.buts.can -text "Cancel" -command wrcomcan
3381 grid $top.buts.gen $top.buts.can
3382 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3383 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3384 grid $top.buts - -pady 10 -sticky ew
3385 focus $top.fname
3386 }
3388 proc wrcomgo {} {
3389 global wrcomtop
3391 set id [$wrcomtop.sha1 get]
3392 set cmd "echo $id | [$wrcomtop.cmd get]"
3393 set fname [$wrcomtop.fname get]
3394 if {[catch {exec sh -c $cmd >$fname &} err]} {
3395 error_popup "Error writing commit: $err"
3396 }
3397 catch {destroy $wrcomtop}
3398 unset wrcomtop
3399 }
3401 proc wrcomcan {} {
3402 global wrcomtop
3404 catch {destroy $wrcomtop}
3405 unset wrcomtop
3406 }
3408 proc doquit {} {
3409 global stopped
3410 set stopped 100
3411 destroy .
3412 }
3414 # defaults...
3415 set datemode 0
3416 set boldnames 0
3417 set diffopts "-U 5 -p"
3418 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3420 set mainfont {Helvetica 9}
3421 set textfont {Courier 9}
3422 set findmergefiles 0
3423 set gaudydiff 0
3424 set maxgraphpct 50
3425 set maxwidth 16
3427 set colors {green red blue magenta darkgrey brown orange}
3429 catch {source ~/.gitk}
3431 set namefont $mainfont
3432 if {$boldnames} {
3433 lappend namefont bold
3434 }
3436 set revtreeargs {}
3437 foreach arg $argv {
3438 switch -regexp -- $arg {
3439 "^$" { }
3440 "^-b" { set boldnames 1 }
3441 "^-d" { set datemode 1 }
3442 default {
3443 lappend revtreeargs $arg
3444 }
3445 }
3446 }
3448 set history {}
3449 set historyindex 0
3451 set stopped 0
3452 set redisplaying 0
3453 set stuffsaved 0
3454 set patchnum 0
3455 setcoords
3456 makewindow
3457 readrefs
3458 getcommits $revtreeargs