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