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