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