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