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