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