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