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