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