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