2 # Tcl ignores the next line -*- tcl -*- \
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.
12 if {[info exists env
(GIT_DIR
)]} {
19 proc getcommits
{rargs
} {
20 global commits commfd phase canv mainfont env
21 global startmsecs nextupdate ncmupdate
22 global ctext maincursor textcursor leftover gitencoding
24 # check that we can find a .git directory somewhere...
26 if {![file isdirectory
$gitdir]} {
27 error_popup
"Cannot find the git directory \"$gitdir\"."
32 set startmsecs
[clock clicks
-milliseconds]
33 set nextupdate
[expr {$startmsecs + 100}]
36 set parse_args
[concat
--default HEAD
$rargs]
37 set parsed_args
[split [eval exec git-rev-parse
$parse_args] "\n"]
39 # if git-rev-parse failed for some reason...
43 set parsed_args
$rargs
46 set commfd
[open
"|git-rev-list --header --topo-order --parents $parsed_args" r
]
48 puts stderr
"Error executing git-rev-list: $err"
52 fconfigure
$commfd -blocking 0 -translation lf
-encoding $gitencoding
53 fileevent
$commfd readable
[list getcommitlines
$commfd]
55 $canv create text
3 3 -anchor nw
-text "Reading commits..." \
56 -font $mainfont -tags textitems
57 . config
-cursor watch
61 proc getcommitlines
{commfd
} {
62 global commits parents cdate children
63 global commitlisted phase nextupdate
64 global stopped redisplaying leftover
66 set stuff
[read $commfd]
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
75 if {[string range
$err 0 4] == "usage"} {
77 "Gitk: error reading commits: bad arguments to git-rev-list.\
78 (Note: arguments to gitk are passed to git-rev-list\
79 to allow selection of commits to be displayed.)"
81 set err
"Error reading commits: $err"
88 set i
[string first
"\0" $stuff $start]
90 append leftover
[string range
$stuff $start end
]
93 set cmit
[string range
$stuff $start [expr {$i - 1}]]
95 set cmit
"$leftover$cmit"
98 set start
[expr {$i + 1}]
99 set j
[string first
"\n" $cmit]
102 set ids
[string range
$cmit 0 [expr {$j - 1}]]
105 if {![regexp
{^
[0-9a-f]{40}$
} $id]} {
113 if {[string length
$shortcmit] > 80} {
114 set shortcmit
"[string range $shortcmit 0 80]..."
116 error_popup
"Can't parse git-rev-list output: {$shortcmit}"
119 set id
[lindex
$ids 0]
120 set olds
[lrange
$ids 1 end
]
121 set cmit
[string range
$cmit [expr {$j + 1}] end
]
123 set commitlisted
($id) 1
124 parsecommit
$id $cmit 1 [lrange
$ids 1 end
]
126 if {[clock clicks
-milliseconds] >= $nextupdate} {
129 while {$redisplaying} {
133 set phase
"getcommits"
134 foreach id
$commits {
137 if {[clock clicks
-milliseconds] >= $nextupdate} {
146 proc doupdate
{reading
} {
147 global commfd nextupdate numcommits ncmupdate
150 fileevent
$commfd readable
{}
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}]
159 set ncmupdate
[expr {$numcommits + 100}]
162 fileevent
$commfd readable
[list getcommitlines
$commfd]
166 proc readcommit
{id
} {
167 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
168 parsecommit
$id $contents 0 {}
171 proc parsecommit
{id contents listed olds
} {
172 global commitinfo children nchildren parents nparents cdate ncleft
181 if {![info exists nchildren
($id)]} {
186 set parents
($id) $olds
187 set nparents
($id) [llength
$olds]
189 if {![info exists nchildren
($p)]} {
190 set children
($p) [list
$id]
193 } elseif
{[lsearch
-exact $children($p) $id] < 0} {
194 lappend children
($p) $id
199 set hdrend
[string first
"\n\n" $contents]
201 # should never happen...
202 set hdrend
[string length
$contents]
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
]
217 # take the first line of the comment as the headline
218 set i
[string first
"\n" $comment]
220 set headline
[string trim
[string range
$comment 0 $i]]
222 set headline
$comment
225 # git-rev-list indents the comment by 4 spaces;
226 # if we got this via git-cat-file, add the indentation
228 foreach line
[split $comment "\n"] {
229 append newcomment
" "
230 append newcomment
$line
231 append newcomment
"\n"
233 set comment
$newcomment
235 if {$comdate != {}} {
236 set cdate
($id) $comdate
238 set commitinfo
($id) [list
$headline $auname $audate \
239 $comname $comdate $comment]
243 global tagids idtags headids idheads tagcontents
244 global otherrefids idotherrefs
246 set refd
[open
[list | git-ls-remote
[gitdir
]] r
]
247 while {0 <= [set n
[gets
$refd line
]]} {
248 if {![regexp
{^
([0-9a-f]{40}) refs
/([^^
]*)$
} $line \
252 if {![regexp
{^
(tags|heads
)/(.
*)$
} $path match
type name
]} {
256 if {$type == "tags"} {
257 set tagids
($name) $id
258 lappend idtags
($id) $name
263 set commit
[exec git-rev-parse
"$id^0"]
264 if {"$commit" != "$id"} {
265 set tagids
($name) $commit
266 lappend idtags
($commit) $name
270 set tagcontents
($name) [exec git-cat-file tag
"$id"]
272 } elseif
{ $type == "heads" } {
273 set headids
($name) $id
274 lappend idheads
($id) $name
276 set otherrefids
($name) $id
277 lappend idotherrefs
($id) $name
283 proc error_popup msg
{
287 message
$w.m
-text $msg -justify center
-aspect 400
288 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
289 button
$w.ok
-text OK
-command "destroy $w"
290 pack
$w.ok
-side bottom
-fill x
291 bind $w <Visibility
> "grab $w; focus $w"
296 global canv canv2 canv3 linespc charspc ctext cflist textfont
297 global findtype findtypemenu findloc findstring fstring geometry
298 global entries sha1entry sha1string sha1but
299 global maincursor textcursor curtextcursor
300 global rowctxmenu gaudydiff mergemax
303 .bar add cascade
-label "File" -menu .bar.
file
305 .bar.
file add
command -label "Reread references" -command rereadrefs
306 .bar.
file add
command -label "Quit" -command doquit
308 .bar add cascade
-label "Help" -menu .bar.
help
309 .bar.
help add
command -label "About gitk" -command about
310 . configure
-menu .bar
312 if {![info exists geometry
(canv1
)]} {
313 set geometry
(canv1
) [expr {45 * $charspc}]
314 set geometry
(canv2
) [expr {30 * $charspc}]
315 set geometry
(canv3
) [expr {15 * $charspc}]
316 set geometry
(canvh
) [expr {25 * $linespc + 4}]
317 set geometry
(ctextw
) 80
318 set geometry
(ctexth
) 30
319 set geometry
(cflistw
) 30
321 panedwindow .ctop
-orient vertical
322 if {[info exists geometry
(width
)]} {
323 .ctop conf
-width $geometry(width
) -height $geometry(height
)
324 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
325 set geometry
(ctexth
) [expr {($texth - 8) /
326 [font metrics
$textfont -linespace]}]
330 pack .ctop.top.bar
-side bottom
-fill x
331 set cscroll .ctop.top.csb
332 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
333 pack
$cscroll -side right
-fill y
334 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
335 pack .ctop.top.clist
-side top
-fill both
-expand 1
337 set canv .ctop.top.clist.canv
338 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
340 -yscrollincr $linespc -yscrollcommand "$cscroll set"
341 .ctop.top.clist add
$canv
342 set canv2 .ctop.top.clist.canv2
343 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
344 -bg white
-bd 0 -yscrollincr $linespc
345 .ctop.top.clist add
$canv2
346 set canv3 .ctop.top.clist.canv3
347 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
348 -bg white
-bd 0 -yscrollincr $linespc
349 .ctop.top.clist add
$canv3
350 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
352 set sha1entry .ctop.top.bar.sha1
353 set entries
$sha1entry
354 set sha1but .ctop.top.bar.sha1label
355 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
356 -command gotocommit
-width 8
357 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
358 pack .ctop.top.bar.sha1label
-side left
359 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
360 trace add variable sha1string
write sha1change
361 pack
$sha1entry -side left
-pady 2
363 image create bitmap bm-left
-data {
364 #define left_width 16
365 #define left_height 16
366 static unsigned char left_bits
[] = {
367 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
368 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
369 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
371 image create bitmap bm-right
-data {
372 #define right_width 16
373 #define right_height 16
374 static unsigned char right_bits
[] = {
375 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
376 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
377 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
379 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
380 -state disabled
-width 26
381 pack .ctop.top.bar.leftbut
-side left
-fill y
382 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
383 -state disabled
-width 26
384 pack .ctop.top.bar.rightbut
-side left
-fill y
386 button .ctop.top.bar.findbut
-text "Find" -command dofind
387 pack .ctop.top.bar.findbut
-side left
389 set fstring .ctop.top.bar.findstring
390 lappend entries
$fstring
391 entry
$fstring -width 30 -font $textfont -textvariable findstring
392 pack
$fstring -side left
-expand 1 -fill x
394 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
395 findtype Exact IgnCase Regexp
]
396 set findloc
"All fields"
397 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
398 Comments Author Committer Files Pickaxe
399 pack .ctop.top.bar.findloc
-side right
400 pack .ctop.top.bar.findtype
-side right
401 # for making sure type==Exact whenever loc==Pickaxe
402 trace add variable findloc
write findlocchange
404 panedwindow .ctop.cdet
-orient horizontal
406 frame .ctop.cdet.left
407 set ctext .ctop.cdet.left.ctext
408 text
$ctext -bg white
-state disabled
-font $textfont \
409 -width $geometry(ctextw
) -height $geometry(ctexth
) \
410 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
411 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
412 pack .ctop.cdet.left.sb
-side right
-fill y
413 pack
$ctext -side left
-fill both
-expand 1
414 .ctop.cdet add .ctop.cdet.left
416 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
418 $ctext tag conf hunksep
-back blue
-fore white
419 $ctext tag conf d0
-back "#ff8080"
420 $ctext tag conf d1
-back green
422 $ctext tag conf hunksep
-fore blue
423 $ctext tag conf d0
-fore red
424 $ctext tag conf d1
-fore "#00a000"
425 $ctext tag conf m0
-fore red
426 $ctext tag conf m1
-fore blue
427 $ctext tag conf m2
-fore green
428 $ctext tag conf m3
-fore purple
429 $ctext tag conf
m4 -fore brown
430 $ctext tag conf mmax
-fore darkgrey
432 $ctext tag conf mresult
-font [concat
$textfont bold
]
433 $ctext tag conf msep
-font [concat
$textfont bold
]
434 $ctext tag conf found
-back yellow
437 frame .ctop.cdet.right
438 set cflist .ctop.cdet.right.cfiles
439 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
440 -yscrollcommand ".ctop.cdet.right.sb set"
441 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
442 pack .ctop.cdet.right.sb
-side right
-fill y
443 pack
$cflist -side left
-fill both
-expand 1
444 .ctop.cdet add .ctop.cdet.right
445 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
447 pack .ctop
-side top
-fill both
-expand 1
449 bindall
<1> {selcanvline
%W
%x
%y
}
450 #bindall <B1-Motion> {selcanvline %W %x %y}
451 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
452 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
453 bindall
<2> "allcanvs scan mark 0 %y"
454 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
455 bind .
<Key-Up
> "selnextline -1"
456 bind .
<Key-Down
> "selnextline 1"
457 bind .
<Key-Right
> "goforw"
458 bind .
<Key-Left
> "goback"
459 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
460 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
461 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
462 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
463 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
464 bindkey p
"selnextline -1"
465 bindkey n
"selnextline 1"
468 bindkey i
"selnextline -1"
469 bindkey k
"selnextline 1"
472 bindkey b
"$ctext yview scroll -1 pages"
473 bindkey d
"$ctext yview scroll 18 units"
474 bindkey u
"$ctext yview scroll -18 units"
475 bindkey
/ {findnext
1}
476 bindkey
<Key-Return
> {findnext
0}
479 bind .
<Control-q
> doquit
480 bind .
<Control-f
> dofind
481 bind .
<Control-g
> {findnext
0}
482 bind .
<Control-r
> findprev
483 bind .
<Control-equal
> {incrfont
1}
484 bind .
<Control-KP_Add
> {incrfont
1}
485 bind .
<Control-minus
> {incrfont
-1}
486 bind .
<Control-KP_Subtract
> {incrfont
-1}
487 bind $cflist <<ListboxSelect>> listboxsel
488 bind . <Destroy> {savestuff %W}
489 bind . <Button-1> "click %W"
490 bind $fstring <Key-Return> dofind
491 bind $sha1entry <Key-Return> gotocommit
492 bind $sha1entry <<PasteSelection>> clearsha1
494 set maincursor [. cget -cursor]
495 set textcursor [$ctext cget -cursor]
496 set curtextcursor $textcursor
498 set rowctxmenu .rowctxmenu
499 menu $rowctxmenu -tearoff 0
500 $rowctxmenu add command -label "Diff this -> selected" \
501 -command {diffvssel 0}
502 $rowctxmenu add command -label "Diff selected -> this" \
503 -command {diffvssel 1}
504 $rowctxmenu add command -label "Make patch" -command mkpatch
505 $rowctxmenu add command -label "Create tag" -command mktag
506 $rowctxmenu add command -label "Write commit to file" -command writecommit
509 # when we make a key binding for the toplevel, make sure
510 # it doesn't get triggered when that key is pressed in the
511 # find string entry widget.
512 proc bindkey {ev script} {
515 set escript [bind Entry $ev]
516 if {$escript == {}} {
517 set escript [bind Entry <Key>]
520 bind $e $ev "$escript; break"
524 # set the focus back to the toplevel for any click outside
535 global canv canv2 canv3 ctext cflist mainfont textfont
536 global stuffsaved findmergefiles gaudydiff maxgraphpct
539 if {$stuffsaved} return
540 if {![winfo viewable .]} return
542 set f [open "~/.gitk-new" w]
543 puts $f [list set mainfont $mainfont]
544 puts $f [list set textfont $textfont]
545 puts $f [list set findmergefiles $findmergefiles]
546 puts $f [list set gaudydiff $gaudydiff]
547 puts $f [list set maxgraphpct $maxgraphpct]
548 puts $f [list set maxwidth $maxwidth]
549 puts $f "set geometry(width) [winfo width .ctop]"
550 puts $f "set geometry(height) [winfo height .ctop]"
551 puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]"
552 puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]"
553 puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]"
554 puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]"
555 set wid [expr {([winfo width $ctext] - 8) \
556 / [font measure $textfont "0"]}]
557 puts $f "set geometry(ctextw) $wid"
558 set wid [expr {([winfo width $cflist] - 11) \
559 / [font measure [$cflist cget -font] "0"]}]
560 puts $f "set geometry(cflistw) $wid"
562 file rename -force "~/.gitk-new" "~/.gitk"
567 proc resizeclistpanes {win w} {
569 if [info exists oldwidth($win)] {
570 set s0 [$win sash coord 0]
571 set s1 [$win sash coord 1]
573 set sash0 [expr {int($w/2 - 2)}]
574 set sash1 [expr {int($w*5/6 - 2)}]
576 set factor [expr {1.0 * $w / $oldwidth($win)}]
577 set sash0 [expr {int($factor * [lindex $s0 0])}]
578 set sash1 [expr {int($factor * [lindex $s1 0])}]
582 if {$sash1 < $sash0 + 20} {
583 set sash1 [expr {$sash0 + 20}]
585 if {$sash1 > $w - 10} {
586 set sash1 [expr {$w - 10}]
587 if {$sash0 > $sash1 - 20} {
588 set sash0 [expr {$sash1 - 20}]
592 $win sash place 0 $sash0 [lindex $s0 1]
593 $win sash place 1 $sash1 [lindex $s1 1]
595 set oldwidth($win) $w
598 proc resizecdetpanes {win w} {
600 if [info exists oldwidth($win)] {
601 set s0 [$win sash coord 0]
603 set sash0 [expr {int($w*3/4 - 2)}]
605 set factor [expr {1.0 * $w / $oldwidth($win)}]
606 set sash0 [expr {int($factor * [lindex $s0 0])}]
610 if {$sash0 > $w - 15} {
611 set sash0 [expr {$w - 15}]
614 $win sash place 0 $sash0 [lindex $s0 1]
616 set oldwidth($win) $w
620 global canv canv2 canv3
626 proc bindall {event action} {
627 global canv canv2 canv3
628 bind $canv $event $action
629 bind $canv2 $event $action
630 bind $canv3 $event $action
635 if {[winfo exists $w]} {
640 wm title $w "About gitk"
644 Copyright © 2005 Paul Mackerras
646 Use and redistribute under the terms of the GNU General Public License} \
647 -justify center -aspect 400
648 pack $w.m -side top -fill x -padx 20 -pady 20
649 button $w.ok -text Close -command "destroy $w"
650 pack $w.ok -side bottom
653 proc assigncolor {id} {
654 global colormap commcolors colors nextcolor
655 global parents nparents children nchildren
656 global cornercrossings crossings
658 if [info exists colormap($id)] return
659 set ncolors [llength $colors]
660 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
661 set child [lindex $children($id) 0]
662 if {[info exists colormap($child)]
663 && $nparents($child) == 1} {
664 set colormap($id) $colormap($child)
669 if {[info exists cornercrossings($id)]} {
670 foreach x $cornercrossings($id) {
671 if {[info exists colormap($x)]
672 && [lsearch -exact $badcolors $colormap($x)] < 0} {
673 lappend badcolors $colormap($x)
676 if {[llength $badcolors] >= $ncolors} {
680 set origbad $badcolors
681 if {[llength $badcolors] < $ncolors - 1} {
682 if {[info exists crossings($id)]} {
683 foreach x $crossings($id) {
684 if {[info exists colormap($x)]
685 && [lsearch -exact $badcolors $colormap($x)] < 0} {
686 lappend badcolors $colormap($x)
689 if {[llength $badcolors] >= $ncolors} {
690 set badcolors $origbad
693 set origbad $badcolors
695 if {[llength $badcolors] < $ncolors - 1} {
696 foreach child $children($id) {
697 if {[info exists colormap($child)]
698 && [lsearch -exact $badcolors $colormap($child)] < 0} {
699 lappend badcolors $colormap($child)
701 if {[info exists parents($child)]} {
702 foreach p $parents($child) {
703 if {[info exists colormap($p)]
704 && [lsearch -exact $badcolors $colormap($p)] < 0} {
705 lappend badcolors $colormap($p)
710 if {[llength $badcolors] >= $ncolors} {
711 set badcolors $origbad
714 for {set i 0} {$i <= $ncolors} {incr i} {
715 set c [lindex $colors $nextcolor]
716 if {[incr nextcolor] >= $ncolors} {
719 if {[lsearch -exact $badcolors $c]} break
725 global canvy canvy0 lineno numcommits nextcolor linespc
726 global mainline mainlinearrow sidelines
727 global nchildren ncleft
728 global displist nhyperspace
735 catch {unset mainline}
736 catch {unset mainlinearrow}
737 catch {unset sidelines}
738 foreach id [array names nchildren] {
739 set ncleft($id) $nchildren($id)
745 proc bindline {t id} {
748 $canv bind $t <Enter> "lineenter %x %y $id"
749 $canv bind $t <Motion> "linemotion %x %y $id"
750 $canv bind $t <Leave> "lineleave $id"
751 $canv bind $t <Button-1> "lineclick %x %y $id 1"
754 proc drawlines {id xtra delold} {
755 global mainline mainlinearrow sidelines lthickness colormap canv
758 $canv delete lines.$id
760 if {[info exists mainline($id)]} {
761 set t [$canv create line $mainline($id) \
762 -width [expr {($xtra + 1) * $lthickness}] \
763 -fill $colormap($id) -tags lines.$id \
764 -arrow $mainlinearrow($id)]
768 if {[info exists sidelines($id)]} {
769 foreach ls $sidelines($id) {
770 set coords [lindex $ls 0]
771 set thick [lindex $ls 1]
772 set arrow [lindex $ls 2]
773 set t [$canv create line $coords -fill $colormap($id) \
774 -width [expr {($thick + $xtra) * $lthickness}] \
775 -arrow $arrow -tags lines.$id]
782 # level here is an index in displist
783 proc drawcommitline {level} {
784 global parents children nparents displist
785 global canv canv2 canv3 mainfont namefont canvy linespc
786 global lineid linehtag linentag linedtag commitinfo
787 global colormap numcommits currentparents dupparents
788 global idtags idline idheads idotherrefs
789 global lineno lthickness mainline mainlinearrow sidelines
790 global commitlisted rowtextx idpos lastuse displist
791 global oldnlines olddlevel olddisplist
795 set id [lindex $displist $level]
796 set lastuse($id) $lineno
797 set lineid($lineno) $id
798 set idline($id) $lineno
799 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
800 if {![info exists commitinfo($id)]} {
802 if {![info exists commitinfo($id)]} {
803 set commitinfo($id) {"No commit information available"}
808 set currentparents {}
810 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
811 foreach p $parents($id) {
812 if {[lsearch -exact $currentparents $p] < 0} {
813 lappend currentparents $p
815 # remember that this parent was listed twice
816 lappend dupparents $p
820 set x [xcoord $level $level $lineno]
822 set canvy [expr {$canvy + $linespc}]
823 allcanvs conf -scrollregion \
824 [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]]
825 if {[info exists mainline($id)]} {
826 lappend mainline($id) $x $y1
827 if {$mainlinearrow($id) ne "none"} {
828 set mainline($id) [trimdiagstart $mainline($id)]
832 set orad [expr {$linespc / 3}]
833 set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \
834 [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \
835 -fill $ofill -outline black -width 1]
837 $canv bind $t <1> {selcanvline {} %x %y}
838 set xt [xcoord [llength $displist] $level $lineno]
839 if {[llength $currentparents] > 2} {
840 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
842 set rowtextx($lineno) $xt
843 set idpos($id) [list $x $xt $y1]
844 if {[info exists idtags($id)] || [info exists idheads($id)]
845 || [info exists idotherrefs($id)]} {
846 set xt [drawtags $id $x $xt $y1]
848 set headline [lindex $commitinfo($id) 0]
849 set name [lindex $commitinfo($id) 1]
850 set date [lindex $commitinfo($id) 2]
851 set date [formatdate $date]
852 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
853 -text $headline -font $mainfont ]
854 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
855 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
856 -text $name -font $namefont]
857 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
858 -text $date -font $mainfont]
861 set olddisplist $displist
862 set oldnlines [llength $displist]
865 proc drawtags {id x xt y1} {
866 global idtags idheads idotherrefs
867 global linespc lthickness
868 global canv mainfont idline rowtextx
873 if {[info exists idtags($id)]} {
874 set marks $idtags($id)
875 set ntags [llength $marks]
877 if {[info exists idheads($id)]} {
878 set marks [concat $marks $idheads($id)]
879 set nheads [llength $idheads($id)]
881 if {[info exists idotherrefs($id)]} {
882 set marks [concat $marks $idotherrefs($id)]
888 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
889 set yt [expr {$y1 - 0.5 * $linespc}]
890 set yb [expr {$yt + $linespc - 1}]
894 set wid [font measure $mainfont $tag]
897 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
899 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
900 -width $lthickness -fill black -tags tag.$id]
902 foreach tag $marks x $xvals wid $wvals {
903 set xl [expr {$x + $delta}]
904 set xr [expr {$x + $delta + $wid + $lthickness}]
905 if {[incr ntags -1] >= 0} {
907 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
908 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
909 -width 1 -outline black -fill yellow -tags tag.$id]
910 $canv bind $t <1> [list showtag $tag 1]
911 set rowtextx($idline($id)) [expr {$xr + $linespc}]
913 # draw a head or other ref
914 if {[incr nheads -1] >= 0} {
919 set xl [expr {$xl - $delta/2}]
920 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
921 -width 1 -outline black -fill $col -tags tag.$id
923 set t [$canv create text $xl $y1 -anchor w -text $tag \
924 -font $mainfont -tags tag.$id]
926 $canv bind $t <1> [list showtag $tag 1]
932 proc notecrossings {id lo hi corner} {
933 global olddisplist crossings cornercrossings
935 for {set i $lo} {[incr i] < $hi} {} {
936 set p [lindex $olddisplist $i]
937 if {$p == {}} continue
939 if {![info exists cornercrossings($id)]
940 || [lsearch -exact $cornercrossings($id) $p] < 0} {
941 lappend cornercrossings($id) $p
943 if {![info exists cornercrossings($p)]
944 || [lsearch -exact $cornercrossings($p) $id] < 0} {
945 lappend cornercrossings($p) $id
948 if {![info exists crossings($id)]
949 || [lsearch -exact $crossings($id) $p] < 0} {
950 lappend crossings($id) $p
952 if {![info exists crossings($p)]
953 || [lsearch -exact $crossings($p) $id] < 0} {
954 lappend crossings($p) $id
960 proc xcoord {i level ln} {
961 global canvx0 xspc1 xspc2
963 set x [expr {$canvx0 + $i * $xspc1($ln)}]
964 if {$i > 0 && $i == $level} {
965 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
966 } elseif {$i > $level} {
967 set x [expr {$x + $xspc2 - $xspc1($ln)}]
972 # it seems Tk can't draw arrows on the end of diagonal line segments...
973 proc trimdiagend {line} {
974 while {[llength $line] > 4} {
975 set x1 [lindex $line end-3]
976 set y1 [lindex $line end-2]
977 set x2 [lindex $line end-1]
978 set y2 [lindex $line end]
979 if {($x1 == $x2) != ($y1 == $y2)} break
980 set line [lreplace $line end-1 end]
985 proc trimdiagstart {line} {
986 while {[llength $line] > 4} {
987 set x1 [lindex $line 0]
988 set y1 [lindex $line 1]
989 set x2 [lindex $line 2]
990 set y2 [lindex $line 3]
991 if {($x1 == $x2) != ($y1 == $y2)} break
992 set line [lreplace $line 0 1]
997 proc drawslants {id needonscreen nohs} {
998 global canv mainline mainlinearrow sidelines
999 global canvx0 canvy xspc1 xspc2 lthickness
1000 global currentparents dupparents
1001 global lthickness linespc canvy colormap lineno geometry
1002 global maxgraphpct maxwidth
1003 global displist onscreen lastuse
1004 global parents commitlisted
1005 global oldnlines olddlevel olddisplist
1006 global nhyperspace numcommits nnewparents
1009 lappend displist $id
1014 set y1 [expr {$canvy - $linespc}]
1017 # work out what we need to get back on screen
1019 if {$onscreen($id) < 0} {
1020 # next to do isn't displayed, better get it on screen...
1021 lappend reins [list $id 0]
1023 # make sure all the previous commits's parents are on the screen
1024 foreach p $currentparents {
1025 if {$onscreen($p) < 0} {
1026 lappend reins [list $p 0]
1029 # bring back anything requested by caller
1030 if {$needonscreen ne {}} {
1031 lappend reins $needonscreen
1035 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1036 set dlevel $olddlevel
1037 set x [xcoord $dlevel $dlevel $lineno]
1038 set mainline($id) [list $x $y1]
1039 set mainlinearrow($id) none
1040 set lastuse($id) $lineno
1041 set displist [lreplace $displist $dlevel $dlevel $id]
1043 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1048 set displist [lreplace $displist $olddlevel $olddlevel]
1050 foreach p $currentparents {
1051 set lastuse($p) $lineno
1052 if {$onscreen($p) == 0} {
1053 set displist [linsert $displist $j $p]
1058 if {$onscreen($id) == 0} {
1059 lappend displist $id
1063 # remove the null entry if present
1064 set nullentry [lsearch -exact $displist {}]
1065 if {$nullentry >= 0} {
1066 set displist [lreplace $displist $nullentry $nullentry]
1069 # bring back the ones we need now (if we did it earlier
1070 # it would change displist and invalidate olddlevel)
1072 # test again in case of duplicates in reins
1073 set p [lindex $pi 0]
1074 if {$onscreen($p) < 0} {
1076 set lastuse($p) $lineno
1077 set displist [linsert $displist [lindex $pi 1] $p]
1082 set lastuse($id) $lineno
1084 # see if we need to make any lines jump off into hyperspace
1085 set displ [llength $displist]
1086 if {$displ > $maxwidth} {
1088 foreach x $displist {
1089 lappend ages [list $lastuse($x) $x]
1091 set ages [lsort -integer -index 0 $ages]
1093 while {$displ > $maxwidth} {
1094 set use [lindex $ages $k 0]
1095 set victim [lindex $ages $k 1]
1096 if {$use >= $lineno - 5} break
1098 if {[lsearch -exact $nohs $victim] >= 0} continue
1099 set i [lsearch -exact $displist $victim]
1100 set displist [lreplace $displist $i $i]
1101 set onscreen($victim) -1
1104 if {$i < $nullentry} {
1107 set x [lindex $mainline($victim) end-1]
1108 lappend mainline($victim) $x $y1
1109 set line [trimdiagend $mainline($victim)]
1111 if {$mainlinearrow($victim) ne "none"} {
1112 set line [trimdiagstart $line]
1115 lappend sidelines($victim) [list $line 1 $arrow]
1116 unset mainline($victim)
1120 set dlevel [lsearch -exact $displist $id]
1122 # If we are reducing, put in a null entry
1123 if {$displ < $oldnlines} {
1124 # does the next line look like a merge?
1125 # i.e. does it have > 1 new parent?
1126 if {$nnewparents($id) > 1} {
1127 set i [expr {$dlevel + 1}]
1128 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1130 if {$nullentry >= 0 && $nullentry < $i} {
1133 } elseif {$nullentry >= 0} {
1136 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1141 if {$dlevel >= $i} {
1146 set displist [linsert $displist $i {}]
1148 if {$dlevel >= $i} {
1154 # decide on the line spacing for the next line
1155 set lj [expr {$lineno + 1}]
1156 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1157 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1158 set xspc1($lj) $xspc2
1160 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1161 if {$xspc1($lj) < $lthickness} {
1162 set xspc1($lj) $lthickness
1166 foreach idi $reins {
1167 set id [lindex $idi 0]
1168 set j [lsearch -exact $displist $id]
1169 set xj [xcoord $j $dlevel $lj]
1170 set mainline($id) [list $xj $y2]
1171 set mainlinearrow($id) first
1175 foreach id $olddisplist {
1177 if {$id == {}} continue
1178 if {$onscreen($id) <= 0} continue
1179 set xi [xcoord $i $olddlevel $lineno]
1180 if {$i == $olddlevel} {
1181 foreach p $currentparents {
1182 set j [lsearch -exact $displist $p]
1183 set coords [list $xi $y1]
1184 set xj [xcoord $j $dlevel $lj]
1185 if {$xj < $xi - $linespc} {
1186 lappend coords [expr {$xj + $linespc}] $y1
1187 notecrossings $p $j $i [expr {$j + 1}]
1188 } elseif {$xj > $xi + $linespc} {
1189 lappend coords [expr {$xj - $linespc}] $y1
1190 notecrossings $p $i $j [expr {$j - 1}]
1192 if {[lsearch -exact $dupparents $p] >= 0} {
1193 # draw a double-width line to indicate the doubled parent
1194 lappend coords $xj $y2
1195 lappend sidelines($p) [list $coords 2 none]
1196 if {![info exists mainline($p)]} {
1197 set mainline($p) [list $xj $y2]
1198 set mainlinearrow($p) none
1201 # normal case, no parent duplicated
1203 set dx [expr {abs($xi - $xj)}]
1204 if {0 && $dx < $linespc} {
1205 set yb [expr {$y1 + $dx}]
1207 if {![info exists mainline($p)]} {
1209 lappend coords $xj $yb
1211 set mainline($p) $coords
1212 set mainlinearrow($p) none
1214 lappend coords $xj $yb
1216 lappend coords $xj $y2
1218 lappend sidelines($p) [list $coords 1 none]
1224 if {[lindex $displist $i] != $id} {
1225 set j [lsearch -exact $displist $id]
1227 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1228 || ($olddlevel < $i && $i < $dlevel)
1229 || ($dlevel < $i && $i < $olddlevel)} {
1230 set xj [xcoord $j $dlevel $lj]
1231 lappend mainline($id) $xi $y1 $xj $y2
1238 # search for x in a list of lists
1239 proc llsearch {llist x} {
1242 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1250 proc drawmore {reading} {
1251 global displayorder numcommits ncmupdate nextupdate
1252 global stopped nhyperspace parents commitlisted
1253 global maxwidth onscreen displist currentparents olddlevel
1255 set n [llength $displayorder]
1256 while {$numcommits < $n} {
1257 set id [lindex $displayorder $numcommits]
1258 set ctxend [expr {$numcommits + 10}]
1259 if {!$reading && $ctxend > $n} {
1263 if {$numcommits > 0} {
1264 set dlist [lreplace $displist $olddlevel $olddlevel]
1266 foreach p $currentparents {
1267 if {$onscreen($p) == 0} {
1268 set dlist [linsert $dlist $i $p]
1275 set isfat [expr {[llength $dlist] > $maxwidth}]
1276 if {$nhyperspace > 0 || $isfat} {
1277 if {$ctxend > $n} break
1278 # work out what to bring back and
1279 # what we want to don't want to send into hyperspace
1281 for {set k $numcommits} {$k < $ctxend} {incr k} {
1282 set x [lindex $displayorder $k]
1283 set i [llsearch $dlist $x]
1285 set i [llength $dlist]
1288 if {[lsearch -exact $nohs $x] < 0} {
1291 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1292 set reins [list $x $i]
1295 if {[info exists commitlisted($x)]} {
1297 foreach p $parents($x) {
1298 if {[llsearch $dlist $p] < 0} {
1300 if {[lsearch -exact $nohs $p] < 0} {
1303 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1304 set reins [list $p [expr {$i + $right}]]
1310 set l [lindex $dlist $i]
1311 if {[llength $l] == 1} {
1314 set j [lsearch -exact $l $x]
1315 set l [concat [lreplace $l $j $j] $newp]
1317 set dlist [lreplace $dlist $i $i $l]
1318 if {$room && $isfat && [llength $newp] <= 1} {
1324 set dlevel [drawslants $id $reins $nohs]
1325 drawcommitline $dlevel
1326 if {[clock clicks -milliseconds] >= $nextupdate
1327 && $numcommits >= $ncmupdate} {
1334 # level here is an index in todo
1335 proc updatetodo {level noshortcut} {
1336 global ncleft todo nnewparents
1337 global commitlisted parents onscreen
1339 set id [lindex $todo $level]
1341 if {[info exists commitlisted($id)]} {
1342 foreach p $parents($id) {
1343 if {[lsearch -exact $olds $p] < 0} {
1348 if {!$noshortcut && [llength $olds] == 1} {
1349 set p [lindex $olds 0]
1350 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1352 set todo [lreplace $todo $level $level $p]
1354 set nnewparents($id) 1
1359 set todo [lreplace $todo $level $level]
1364 set k [lsearch -exact $todo $p]
1366 set todo [linsert $todo $i $p]
1372 set nnewparents($id) $n
1377 proc decidenext {{noread 0}} {
1379 global datemode cdate
1382 # choose which one to do next time around
1383 set todol [llength $todo]
1386 for {set k $todol} {[incr k -1] >= 0} {} {
1387 set p [lindex $todo $k]
1388 if {$ncleft($p) == 0} {
1390 if {![info exists commitinfo($p)]} {
1396 if {$latest == {} || $cdate($p) > $latest} {
1398 set latest $cdate($p)
1408 puts "ERROR: none of the pending commits can be done yet:"
1410 puts " $p ($ncleft($p))"
1419 proc drawcommit {id} {
1420 global phase todo nchildren datemode nextupdate revlistorder
1421 global numcommits ncmupdate displayorder todo onscreen parents
1423 if {$phase != "incrdraw"} {
1429 if {$nchildren($id) == 0} {
1433 if {$revlistorder} {
1434 set level [lsearch -exact $todo $id]
1436 error_popup "oops, $id isn't in todo"
1439 lappend displayorder $id
1442 set level [decidenext 1]
1443 if {$level == {} || $id != [lindex $todo $level]} {
1447 lappend displayorder [lindex $todo $level]
1448 if {[updatetodo $level $datemode]} {
1449 set level [decidenext 1]
1450 if {$level == {}} break
1452 set id [lindex $todo $level]
1453 if {![info exists commitlisted($id)]} {
1461 proc finishcommits {} {
1463 global canv mainfont ctext maincursor textcursor
1465 if {$phase != "incrdraw"} {
1467 $canv create text 3 3 -anchor nw -text "No commits selected" \
1468 -font $mainfont -tags textitems
1473 . config -cursor $maincursor
1474 settextcursor $textcursor
1477 # Don't change the text pane cursor if it is currently the hand cursor,
1478 # showing that we are over a sha1 ID link.
1479 proc settextcursor {c} {
1480 global ctext curtextcursor
1482 if {[$ctext cget -cursor] == $curtextcursor} {
1483 $ctext config -cursor $c
1485 set curtextcursor $c
1489 global nextupdate startmsecs ncmupdate
1490 global displayorder onscreen
1492 if {$displayorder == {}} return
1493 set startmsecs [clock clicks -milliseconds]
1494 set nextupdate [expr {$startmsecs + 100}]
1497 foreach id $displayorder {
1504 global phase stopped redisplaying selectedline
1505 global datemode todo displayorder
1506 global numcommits ncmupdate
1507 global nextupdate startmsecs revlistorder
1509 set level [decidenext]
1513 lappend displayorder [lindex $todo $level]
1514 set hard [updatetodo $level $datemode]
1516 set level [decidenext]
1517 if {$level < 0} break
1523 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
1524 #puts "overall $drawmsecs ms for $numcommits commits"
1525 if {$redisplaying} {
1526 if {$stopped == 0 && [info exists selectedline]} {
1527 selectline $selectedline 0
1529 if {$stopped == 1} {
1531 after idle drawgraph
1538 proc findmatches {f} {
1539 global findtype foundstring foundstrlen
1540 if {$findtype == "Regexp"} {
1541 set matches [regexp -indices -all -inline $foundstring $f]
1543 if {$findtype == "IgnCase"} {
1544 set str [string tolower $f]
1550 while {[set j [string first $foundstring $str $i]] >= 0} {
1551 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
1552 set i [expr {$j + $foundstrlen}]
1559 global findtype findloc findstring markedmatches commitinfo
1560 global numcommits lineid linehtag linentag linedtag
1561 global mainfont namefont canv canv2 canv3 selectedline
1562 global matchinglines foundstring foundstrlen
1567 set matchinglines {}
1568 if {$findloc == "Pickaxe"} {
1572 if {$findtype == "IgnCase"} {
1573 set foundstring [string tolower $findstring]
1575 set foundstring $findstring
1577 set foundstrlen [string length $findstring]
1578 if {$foundstrlen == 0} return
1579 if {$findloc == "Files"} {
1583 if {![info exists selectedline]} {
1586 set oldsel $selectedline
1589 set fldtypes {Headline Author Date Committer CDate Comment}
1590 for {set l 0} {$l < $numcommits} {incr l} {
1592 set info $commitinfo($id)
1594 foreach f $info ty $fldtypes {
1595 if {$findloc != "All fields" && $findloc != $ty} {
1598 set matches [findmatches $f]
1599 if {$matches == {}} continue
1601 if {$ty == "Headline"} {
1602 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1603 } elseif {$ty == "Author"} {
1604 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1605 } elseif {$ty == "Date"} {
1606 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1610 lappend matchinglines $l
1611 if {!$didsel && $l > $oldsel} {
1617 if {$matchinglines == {}} {
1619 } elseif {!$didsel} {
1620 findselectline [lindex $matchinglines 0]
1624 proc findselectline {l} {
1625 global findloc commentend ctext
1627 if {$findloc == "All fields" || $findloc == "Comments"} {
1628 # highlight the matches in the comments
1629 set f [$ctext get 1.0 $commentend]
1630 set matches [findmatches $f]
1631 foreach match $matches {
1632 set start [lindex $match 0]
1633 set end [expr {[lindex $match 1] + 1}]
1634 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1639 proc findnext {restart} {
1640 global matchinglines selectedline
1641 if {![info exists matchinglines]} {
1647 if {![info exists selectedline]} return
1648 foreach l $matchinglines {
1649 if {$l > $selectedline} {
1658 global matchinglines selectedline
1659 if {![info exists matchinglines]} {
1663 if {![info exists selectedline]} return
1665 foreach l $matchinglines {
1666 if {$l >= $selectedline} break
1670 findselectline $prev
1676 proc findlocchange {name ix op} {
1677 global findloc findtype findtypemenu
1678 if {$findloc == "Pickaxe"} {
1684 $findtypemenu entryconf 1 -state $state
1685 $findtypemenu entryconf 2 -state $state
1688 proc stopfindproc {{done 0}} {
1689 global findprocpid findprocfile findids
1690 global ctext findoldcursor phase maincursor textcursor
1691 global findinprogress
1693 catch {unset findids}
1694 if {[info exists findprocpid]} {
1696 catch {exec kill $findprocpid}
1698 catch {close $findprocfile}
1701 if {[info exists findinprogress]} {
1702 unset findinprogress
1703 if {$phase != "incrdraw"} {
1704 . config -cursor $maincursor
1705 settextcursor $textcursor
1710 proc findpatches {} {
1711 global findstring selectedline numcommits
1712 global findprocpid findprocfile
1713 global finddidsel ctext lineid findinprogress
1714 global findinsertpos
1716 if {$numcommits == 0} return
1718 # make a list of all the ids to search, starting at the one
1719 # after the selected line (if any)
1720 if {[info exists selectedline]} {
1726 for {set i 0} {$i < $numcommits} {incr i} {
1727 if {[incr l] >= $numcommits} {
1730 append inputids $lineid($l) "\n"
1734 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1737 error_popup "Error starting search process: $err"
1741 set findinsertpos end
1743 set findprocpid [pid $f]
1744 fconfigure $f -blocking 0
1745 fileevent $f readable readfindproc
1747 . config -cursor watch
1749 set findinprogress 1
1752 proc readfindproc {} {
1753 global findprocfile finddidsel
1754 global idline matchinglines findinsertpos
1756 set n [gets $findprocfile line]
1758 if {[eof $findprocfile]} {
1766 if {![regexp {^[0-9a-f]{40}} $line id]} {
1767 error_popup "Can't parse git-diff-tree output: $line"
1771 if {![info exists idline($id)]} {
1772 puts stderr "spurious id: $id"
1779 proc insertmatch {l id} {
1780 global matchinglines findinsertpos finddidsel
1782 if {$findinsertpos == "end"} {
1783 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1784 set matchinglines [linsert $matchinglines 0 $l]
1787 lappend matchinglines $l
1790 set matchinglines [linsert $matchinglines $findinsertpos $l]
1801 global selectedline numcommits lineid ctext
1802 global ffileline finddidsel parents nparents
1803 global findinprogress findstartline findinsertpos
1804 global treediffs fdiffids fdiffsneeded fdiffpos
1805 global findmergefiles
1807 if {$numcommits == 0} return
1809 if {[info exists selectedline]} {
1810 set l [expr {$selectedline + 1}]
1815 set findstartline $l
1820 if {$findmergefiles || $nparents($id) == 1} {
1821 foreach p $parents($id) {
1822 if {![info exists treediffs([list $id $p])]} {
1823 append diffsneeded "$id $p\n"
1824 lappend fdiffsneeded [list $id $p]
1828 if {[incr l] >= $numcommits} {
1831 if {$l == $findstartline} break
1834 # start off a git-diff-tree process if needed
1835 if {$diffsneeded ne {}} {
1837 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1839 error_popup "Error starting search process: $err"
1842 catch {unset fdiffids}
1844 fconfigure $df -blocking 0
1845 fileevent $df readable [list readfilediffs $df]
1849 set findinsertpos end
1851 set p [lindex $parents($id) 0]
1852 . config -cursor watch
1854 set findinprogress 1
1855 findcont [list $id $p]
1859 proc readfilediffs {df} {
1860 global findids fdiffids fdiffs
1862 set n [gets $df line]
1866 if {[catch {close $df} err]} {
1869 error_popup "Error in git-diff-tree: $err"
1870 } elseif {[info exists findids]} {
1874 error_popup "Couldn't find diffs for {$ids}"
1879 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1880 # start of a new string of diffs
1882 set fdiffids [list $id $p]
1884 } elseif {[string match ":*" $line]} {
1885 lappend fdiffs [lindex $line 5]
1889 proc donefilediff {} {
1890 global fdiffids fdiffs treediffs findids
1891 global fdiffsneeded fdiffpos
1893 if {[info exists fdiffids]} {
1894 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1895 && $fdiffpos < [llength $fdiffsneeded]} {
1896 # git-diff-tree doesn't output anything for a commit
1897 # which doesn't change anything
1898 set nullids [lindex $fdiffsneeded $fdiffpos]
1899 set treediffs($nullids) {}
1900 if {[info exists findids] && $nullids eq $findids} {
1908 if {![info exists treediffs($fdiffids)]} {
1909 set treediffs($fdiffids) $fdiffs
1911 if {[info exists findids] && $fdiffids eq $findids} {
1918 proc findcont {ids} {
1919 global findids treediffs parents nparents
1920 global ffileline findstartline finddidsel
1921 global lineid numcommits matchinglines findinprogress
1922 global findmergefiles
1924 set id [lindex $ids 0]
1925 set p [lindex $ids 1]
1926 set pi [lsearch -exact $parents($id) $p]
1929 if {$findmergefiles || $nparents($id) == 1} {
1930 if {![info exists treediffs($ids)]} {
1936 foreach f $treediffs($ids) {
1937 set x [findmatches $f]
1945 set pi $nparents($id)
1948 set pi $nparents($id)
1950 if {[incr pi] >= $nparents($id)} {
1952 if {[incr l] >= $numcommits} {
1955 if {$l == $findstartline} break
1958 set p [lindex $parents($id) $pi]
1959 set ids [list $id $p]
1967 # mark a commit as matching by putting a yellow background
1968 # behind the headline
1969 proc markheadline {l id} {
1970 global canv mainfont linehtag commitinfo
1972 set bbox [$canv bbox $linehtag($l)]
1973 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1977 # mark the bits of a headline, author or date that match a find string
1978 proc markmatches {canv l str tag matches font} {
1979 set bbox [$canv bbox $tag]
1980 set x0 [lindex $bbox 0]
1981 set y0 [lindex $bbox 1]
1982 set y1 [lindex $bbox 3]
1983 foreach match $matches {
1984 set start [lindex $match 0]
1985 set end [lindex $match 1]
1986 if {$start > $end} continue
1987 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
1988 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
1989 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
1990 [expr {$x0+$xlen+2}] $y1 \
1991 -outline {} -tags matches -fill yellow]
1996 proc unmarkmatches {} {
1997 global matchinglines findids
1998 allcanvs delete matches
1999 catch {unset matchinglines}
2000 catch {unset findids}
2003 proc selcanvline {w x y} {
2004 global canv canvy0 ctext linespc
2005 global lineid linehtag linentag linedtag rowtextx
2006 set ymax [lindex [$canv cget -scrollregion] 3]
2007 if {$ymax == {}} return
2008 set yfrac [lindex [$canv yview] 0]
2009 set y [expr {$y + $yfrac * $ymax}]
2010 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2015 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2021 proc commit_descriptor {p} {
2024 if {[info exists commitinfo($p)]} {
2025 set l [lindex $commitinfo($p) 0]
2030 # append some text to the ctext widget, and make any SHA1 ID
2031 # that we know about be a clickable link.
2032 proc appendwithlinks {text} {
2033 global ctext idline linknum
2035 set start [$ctext index "end - 1c"]
2036 $ctext insert end $text
2037 $ctext insert end "\n"
2038 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2042 set linkid [string range $text $s $e]
2043 if {![info exists idline($linkid)]} continue
2045 $ctext tag add link "$start + $s c" "$start + $e c"
2046 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2047 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2050 $ctext tag conf link -foreground blue -underline 1
2051 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2052 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2055 proc selectline {l isnew} {
2056 global canv canv2 canv3 ctext commitinfo selectedline
2057 global lineid linehtag linentag linedtag
2058 global canvy0 linespc parents nparents children
2059 global cflist currentid sha1entry
2060 global commentend idtags idline linknum
2064 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2066 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2067 -tags secsel -fill [$canv cget -selectbackground]]
2069 $canv2 delete secsel
2070 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2071 -tags secsel -fill [$canv2 cget -selectbackground]]
2073 $canv3 delete secsel
2074 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2075 -tags secsel -fill [$canv3 cget -selectbackground]]
2077 set y [expr {$canvy0 + $l * $linespc}]
2078 set ymax [lindex [$canv cget -scrollregion] 3]
2079 set ytop [expr {$y - $linespc - 1}]
2080 set ybot [expr {$y + $linespc + 1}]
2081 set wnow [$canv yview]
2082 set wtop [expr {[lindex $wnow 0] * $ymax}]
2083 set wbot [expr {[lindex $wnow 1] * $ymax}]
2084 set wh [expr {$wbot - $wtop}]
2086 if {$ytop < $wtop} {
2087 if {$ybot < $wtop} {
2088 set newtop [expr {$y - $wh / 2.0}]
2091 if {$newtop > $wtop - $linespc} {
2092 set newtop [expr {$wtop - $linespc}]
2095 } elseif {$ybot > $wbot} {
2096 if {$ytop > $wbot} {
2097 set newtop [expr {$y - $wh / 2.0}]
2099 set newtop [expr {$ybot - $wh}]
2100 if {$newtop < $wtop + $linespc} {
2101 set newtop [expr {$wtop + $linespc}]
2105 if {$newtop != $wtop} {
2109 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
2113 addtohistory [list selectline $l 0]
2120 $sha1entry delete 0 end
2121 $sha1entry insert 0 $id
2122 $sha1entry selection from 0
2123 $sha1entry selection to end
2125 $ctext conf -state normal
2126 $ctext delete 0.0 end
2128 $ctext mark set fmark.0 0.0
2129 $ctext mark gravity fmark.0 left
2130 set info $commitinfo($id)
2131 set date [formatdate [lindex $info 2]]
2132 $ctext insert end "Author: [lindex $info 1] $date\n"
2133 set date [formatdate [lindex $info 4]]
2134 $ctext insert end "Committer: [lindex $info 3] $date\n"
2135 if {[info exists idtags($id)]} {
2136 $ctext insert end "Tags:"
2137 foreach tag $idtags($id) {
2138 $ctext insert end " $tag"
2140 $ctext insert end "\n"
2144 if {[info exists parents($id)]} {
2145 foreach p $parents($id) {
2146 append comment "Parent: [commit_descriptor $p]\n"
2149 if {[info exists children($id)]} {
2150 foreach c $children($id) {
2151 append comment "Child: [commit_descriptor $c]\n"
2155 append comment [lindex $info 5]
2157 # make anything that looks like a SHA1 ID be a clickable link
2158 appendwithlinks $comment
2160 $ctext tag delete Comments
2161 $ctext tag remove found 1.0 end
2162 $ctext conf -state disabled
2163 set commentend [$ctext index "end - 1c"]
2165 $cflist delete 0 end
2166 $cflist insert end "Comments"
2167 if {$nparents($id) == 1} {
2168 startdiff [concat $id $parents($id)] 1
2169 } elseif {$nparents($id) > 1} {
2174 proc selnextline {dir} {
2176 if {![info exists selectedline]} return
2177 set l [expr {$selectedline + $dir}]
2182 proc unselectline {} {
2185 catch {unset selectedline}
2186 allcanvs delete secsel
2189 proc addtohistory {cmd} {
2190 global history historyindex
2192 if {$historyindex > 0
2193 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2197 if {$historyindex < [llength $history]} {
2198 set history [lreplace $history $historyindex end $cmd]
2200 lappend history $cmd
2203 if {$historyindex > 1} {
2204 .ctop.top.bar.leftbut conf -state normal
2206 .ctop.top.bar.leftbut conf -state disabled
2208 .ctop.top.bar.rightbut conf -state disabled
2212 global history historyindex
2214 if {$historyindex > 1} {
2215 incr historyindex -1
2216 set cmd [lindex $history [expr {$historyindex - 1}]]
2218 .ctop.top.bar.rightbut conf -state normal
2220 if {$historyindex <= 1} {
2221 .ctop.top.bar.leftbut conf -state disabled
2226 global history historyindex
2228 if {$historyindex < [llength $history]} {
2229 set cmd [lindex $history $historyindex]
2232 .ctop.top.bar.leftbut conf -state normal
2234 if {$historyindex >= [llength $history]} {
2235 .ctop.top.bar.rightbut conf -state disabled
2239 proc mergediff {id singlecommit} {
2240 global parents diffmergeid diffmergegca mergefilelist diffpindex
2244 set diffmergegca [findgca $parents($id)]
2245 if {[info exists mergefilelist($id)]} {
2246 if {$mergefilelist($id) ne {}} {
2250 contmergediff {} $singlecommit
2254 proc findgca {ids} {
2261 set gca [exec git-merge-base $gca $id]
2270 proc contmergediff {ids singlecommit} {
2271 global diffmergeid diffpindex parents nparents diffmergegca
2272 global treediffs mergefilelist diffids treepending
2274 # diff the child against each of the parents, and diff
2275 # each of the parents against the GCA.
2277 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2278 set ids [list [lindex $ids 1] $diffmergegca]
2280 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2281 set p [lindex $parents($diffmergeid) $diffpindex]
2282 set ids [list $diffmergeid $p]
2284 if {![info exists treediffs($ids)]} {
2286 if {![info exists treepending]} {
2287 gettreediffs $ids $singlecommit
2293 # If a file in some parent is different from the child and also
2294 # different from the GCA, then it's interesting.
2295 # If we don't have a GCA, then a file is interesting if it is
2296 # different from the child in all the parents.
2297 if {$diffmergegca ne {}} {
2299 foreach p $parents($diffmergeid) {
2300 set gcadiffs $treediffs([list $p $diffmergegca])
2301 foreach f $treediffs([list $diffmergeid $p]) {
2302 if {[lsearch -exact $files $f] < 0
2303 && [lsearch -exact $gcadiffs $f] >= 0} {
2308 set files [lsort $files]
2310 set p [lindex $parents($diffmergeid) 0]
2311 set files $treediffs([list $diffmergeid $p])
2312 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2313 set p [lindex $parents($diffmergeid) $i]
2314 set df $treediffs([list $diffmergeid $p])
2317 if {[lsearch -exact $df $f] >= 0} {
2325 set mergefilelist($diffmergeid) $files
2331 proc showmergediff {} {
2332 global cflist diffmergeid mergefilelist parents
2333 global diffopts diffinhunk currentfile currenthunk filelines
2334 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2336 set files $mergefilelist($diffmergeid)
2338 $cflist insert end $f
2340 set env(GIT_DIFF_OPTS) $diffopts
2342 catch {unset currentfile}
2343 catch {unset currenthunk}
2344 catch {unset filelines}
2345 catch {unset groupfilenum}
2346 catch {unset grouphunks}
2347 set groupfilelast -1
2348 foreach p $parents($diffmergeid) {
2349 set cmd [list | git-diff-tree -p $p $diffmergeid]
2350 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2351 if {[catch {set f [open $cmd r]} err]} {
2352 error_popup "Error getting diffs: $err"
2359 set ids [list $diffmergeid $p]
2360 set mergefds($ids) $f
2361 set diffinhunk($ids) 0
2362 set diffblocked($ids) 0
2363 fconfigure $f -blocking 0
2364 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2368 proc getmergediffline {f ids id} {
2369 global diffmergeid diffinhunk diffoldlines diffnewlines
2370 global currentfile currenthunk
2371 global diffoldstart diffnewstart diffoldlno diffnewlno
2372 global diffblocked mergefilelist
2373 global noldlines nnewlines difflcounts filelines
2375 set n [gets $f line]
2377 if {![eof $f]} return
2380 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2387 if {$diffinhunk($ids) != 0} {
2388 set fi $currentfile($ids)
2389 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2390 # continuing an existing hunk
2391 set line [string range $line 1 end]
2392 set p [lindex $ids 1]
2393 if {$match eq "-" || $match eq " "} {
2394 set filelines($p,$fi,$diffoldlno($ids)) $line
2395 incr diffoldlno($ids)
2397 if {$match eq "+" || $match eq " "} {
2398 set filelines($id,$fi,$diffnewlno($ids)) $line
2399 incr diffnewlno($ids)
2401 if {$match eq " "} {
2402 if {$diffinhunk($ids) == 2} {
2403 lappend difflcounts($ids) \
2404 [list $noldlines($ids) $nnewlines($ids)]
2405 set noldlines($ids) 0
2406 set diffinhunk($ids) 1
2408 incr noldlines($ids)
2409 } elseif {$match eq "-" || $match eq "+"} {
2410 if {$diffinhunk($ids) == 1} {
2411 lappend difflcounts($ids) [list $noldlines($ids)]
2412 set noldlines($ids) 0
2413 set nnewlines($ids) 0
2414 set diffinhunk($ids) 2
2416 if {$match eq "-"} {
2417 incr noldlines($ids)
2419 incr nnewlines($ids)
2422 # and if it's \ No newline at end of line, then what?
2426 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2427 lappend difflcounts($ids) [list $noldlines($ids)]
2428 } elseif {$diffinhunk($ids) == 2
2429 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2430 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2432 set currenthunk($ids) [list $currentfile($ids) \
2433 $diffoldstart($ids) $diffnewstart($ids) \
2434 $diffoldlno($ids) $diffnewlno($ids) \
2436 set diffinhunk($ids) 0
2437 # -1 = need to block, 0 = unblocked, 1 = is blocked
2438 set diffblocked($ids) -1
2440 if {$diffblocked($ids) == -1} {
2441 fileevent $f readable {}
2442 set diffblocked($ids) 1
2448 if {!$diffblocked($ids)} {
2450 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2451 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2454 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2455 # start of a new file
2456 set currentfile($ids) \
2457 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2458 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2459 $line match f1l f1c f2l f2c rest]} {
2460 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2461 # start of a new hunk
2462 if {$f1l == 0 && $f1c == 0} {
2465 if {$f2l == 0 && $f2c == 0} {
2468 set diffinhunk($ids) 1
2469 set diffoldstart($ids) $f1l
2470 set diffnewstart($ids) $f2l
2471 set diffoldlno($ids) $f1l
2472 set diffnewlno($ids) $f2l
2473 set difflcounts($ids) {}
2474 set noldlines($ids) 0
2475 set nnewlines($ids) 0
2480 proc processhunks {} {
2481 global diffmergeid parents nparents currenthunk
2482 global mergefilelist diffblocked mergefds
2483 global grouphunks grouplinestart grouplineend groupfilenum
2485 set nfiles [llength $mergefilelist($diffmergeid)]
2489 # look for the earliest hunk
2490 foreach p $parents($diffmergeid) {
2491 set ids [list $diffmergeid $p]
2492 if {![info exists currenthunk($ids)]} return
2493 set i [lindex $currenthunk($ids) 0]
2494 set l [lindex $currenthunk($ids) 2]
2495 if {$i < $fi || ($i == $fi && $l < $lno)} {
2502 if {$fi < $nfiles} {
2503 set ids [list $diffmergeid $pi]
2504 set hunk $currenthunk($ids)
2505 unset currenthunk($ids)
2506 if {$diffblocked($ids) > 0} {
2507 fileevent $mergefds($ids) readable \
2508 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2510 set diffblocked($ids) 0
2512 if {[info exists groupfilenum] && $groupfilenum == $fi
2513 && $lno <= $grouplineend} {
2514 # add this hunk to the pending group
2515 lappend grouphunks($pi) $hunk
2516 set endln [lindex $hunk 4]
2517 if {$endln > $grouplineend} {
2518 set grouplineend $endln
2524 # succeeding stuff doesn't belong in this group, so
2525 # process the group now
2526 if {[info exists groupfilenum]} {
2532 if {$fi >= $nfiles} break
2535 set groupfilenum $fi
2536 set grouphunks($pi) [list $hunk]
2537 set grouplinestart $lno
2538 set grouplineend [lindex $hunk 4]
2542 proc processgroup {} {
2543 global groupfilelast groupfilenum difffilestart
2544 global mergefilelist diffmergeid ctext filelines
2545 global parents diffmergeid diffoffset
2546 global grouphunks grouplinestart grouplineend nparents
2549 $ctext conf -state normal
2552 if {$groupfilelast != $f} {
2553 $ctext insert end "\n"
2554 set here [$ctext index "end - 1c"]
2555 set difffilestart($f) $here
2556 set mark fmark.[expr {$f + 1}]
2557 $ctext mark set $mark $here
2558 $ctext mark gravity $mark left
2559 set header [lindex $mergefilelist($id) $f]
2560 set l [expr {(78 - [string length $header]) / 2}]
2561 set pad [string range "----------------------------------------" 1 $l]
2562 $ctext insert end "$pad $header $pad\n" filesep
2563 set groupfilelast $f
2564 foreach p $parents($id) {
2565 set diffoffset($p) 0
2569 $ctext insert end "@@" msep
2570 set nlines [expr {$grouplineend - $grouplinestart}]
2573 foreach p $parents($id) {
2574 set startline [expr {$grouplinestart + $diffoffset($p)}]
2576 set nl $grouplinestart
2577 if {[info exists grouphunks($p)]} {
2578 foreach h $grouphunks($p) {
2581 for {} {$nl < $l} {incr nl} {
2582 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2586 foreach chunk [lindex $h 5] {
2587 if {[llength $chunk] == 2} {
2588 set olc [lindex $chunk 0]
2589 set nlc [lindex $chunk 1]
2590 set nnl [expr {$nl + $nlc}]
2591 lappend events [list $nl $nnl $pnum $olc $nlc]
2595 incr ol [lindex $chunk 0]
2596 incr nl [lindex $chunk 0]
2601 if {$nl < $grouplineend} {
2602 for {} {$nl < $grouplineend} {incr nl} {
2603 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2607 set nlines [expr {$ol - $startline}]
2608 $ctext insert end " -$startline,$nlines" msep
2612 set nlines [expr {$grouplineend - $grouplinestart}]
2613 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2615 set events [lsort -integer -index 0 $events]
2616 set nevents [llength $events]
2617 set nmerge $nparents($diffmergeid)
2618 set l $grouplinestart
2619 for {set i 0} {$i < $nevents} {set i $j} {
2620 set nl [lindex $events $i 0]
2622 $ctext insert end " $filelines($id,$f,$l)\n"
2625 set e [lindex $events $i]
2626 set enl [lindex $e 1]
2630 set pnum [lindex $e 2]
2631 set olc [lindex $e 3]
2632 set nlc [lindex $e 4]
2633 if {![info exists delta($pnum)]} {
2634 set delta($pnum) [expr {$olc - $nlc}]
2635 lappend active $pnum
2637 incr delta($pnum) [expr {$olc - $nlc}]
2639 if {[incr j] >= $nevents} break
2640 set e [lindex $events $j]
2641 if {[lindex $e 0] >= $enl} break
2642 if {[lindex $e 1] > $enl} {
2643 set enl [lindex $e 1]
2646 set nlc [expr {$enl - $l}]
2649 if {[llength $active] == $nmerge - 1} {
2650 # no diff for one of the parents, i.e. it's identical
2651 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2652 if {![info exists delta($pnum)]} {
2653 if {$pnum < $mergemax} {
2661 } elseif {[llength $active] == $nmerge} {
2662 # all parents are different, see if one is very similar
2664 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2665 set sim [similarity $pnum $l $nlc $f \
2666 [lrange $events $i [expr {$j-1}]]]
2667 if {$sim > $bestsim} {
2673 lappend ncol m$bestpn
2677 foreach p $parents($id) {
2679 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2680 set olc [expr {$nlc + $delta($pnum)}]
2681 set ol [expr {$l + $diffoffset($p)}]
2682 incr diffoffset($p) $delta($pnum)
2684 for {} {$olc > 0} {incr olc -1} {
2685 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2689 set endl [expr {$l + $nlc}]
2691 # show this pretty much as a normal diff
2692 set p [lindex $parents($id) $bestpn]
2693 set ol [expr {$l + $diffoffset($p)}]
2694 incr diffoffset($p) $delta($bestpn)
2695 unset delta($bestpn)
2696 for {set k $i} {$k < $j} {incr k} {
2697 set e [lindex $events $k]
2698 if {[lindex $e 2] != $bestpn} continue
2699 set nl [lindex $e 0]
2700 set ol [expr {$ol + $nl - $l}]
2701 for {} {$l < $nl} {incr l} {
2702 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2705 for {} {$c > 0} {incr c -1} {
2706 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2709 set nl [lindex $e 1]
2710 for {} {$l < $nl} {incr l} {
2711 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2715 for {} {$l < $endl} {incr l} {
2716 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2719 while {$l < $grouplineend} {
2720 $ctext insert end " $filelines($id,$f,$l)\n"
2723 $ctext conf -state disabled
2726 proc similarity {pnum l nlc f events} {
2727 global diffmergeid parents diffoffset filelines
2730 set p [lindex $parents($id) $pnum]
2731 set ol [expr {$l + $diffoffset($p)}]
2732 set endl [expr {$l + $nlc}]
2736 if {[lindex $e 2] != $pnum} continue
2737 set nl [lindex $e 0]
2738 set ol [expr {$ol + $nl - $l}]
2739 for {} {$l < $nl} {incr l} {
2740 incr same [string length $filelines($id,$f,$l)]
2743 set oc [lindex $e 3]
2744 for {} {$oc > 0} {incr oc -1} {
2745 incr diff [string length $filelines($p,$f,$ol)]
2749 set nl [lindex $e 1]
2750 for {} {$l < $nl} {incr l} {
2751 incr diff [string length $filelines($id,$f,$l)]
2755 for {} {$l < $endl} {incr l} {
2756 incr same [string length $filelines($id,$f,$l)]
2762 return [expr {200 * $same / (2 * $same + $diff)}]
2765 proc startdiff {ids singlecommit} {
2766 global treediffs diffids treepending diffmergeid
2769 catch {unset diffmergeid}
2770 if {![info exists treediffs($ids)]} {
2771 if {![info exists treepending]} {
2772 gettreediffs $ids $singlecommit
2775 addtocflist $ids $singlecommit
2779 proc addtocflist {ids singlecommit} {
2780 global treediffs cflist
2781 foreach f $treediffs($ids) {
2782 $cflist insert end $f
2784 getblobdiffs $ids $singlecommit
2787 proc gettreediffs {ids singlecommit} {
2788 global treediff parents treepending
2789 set treepending $ids
2791 set id [lindex $ids 0]
2792 if {$singlecommit == 1} {
2795 set p [lindex $ids 1]
2798 if [catch {set gdtf [open "|git-diff-tree --no-commit-id -r $range" r]}] return
2799 fconfigure $gdtf -blocking 0
2800 fileevent $gdtf readable [list gettreediffline $gdtf $ids $singlecommit]
2803 proc gettreediffline {gdtf ids singlecommit} {
2804 global treediff treediffs treepending diffids diffmergeid
2806 set n [gets $gdtf line]
2808 if {![eof $gdtf]} return
2810 set treediffs($ids) $treediff
2812 if {$ids != $diffids} {
2813 gettreediffs $diffids $singlecommit
2815 if {[info exists diffmergeid]} {
2816 contmergediff $ids $singlecommit
2818 addtocflist $ids $singlecommit
2823 set file [lindex $line 5]
2824 lappend treediff $file
2827 proc getblobdiffs {ids singlecommit} {
2828 global diffopts blobdifffd diffids env curdifftag curtagstart
2829 global difffilestart nextupdate diffinhdr treediffs
2831 set id [lindex $ids 0]
2832 set env(GIT_DIFF_OPTS) $diffopts
2833 if {$singlecommit == 1} {
2834 set cmd [list | git-diff-tree --no-commit-id -r -p -C $id]
2836 set p [lindex $ids 1]
2837 set cmd [list | git-diff-tree --no-commit-id -r -p -C $p $id]
2839 if {[catch {set bdf [open $cmd r]} err]} {
2840 puts "error getting diffs: $err"
2844 fconfigure $bdf -blocking 0
2845 set blobdifffd($ids) $bdf
2846 set curdifftag Comments
2848 catch {unset difffilestart}
2849 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2850 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2853 proc getblobdiffline {bdf ids} {
2854 global diffids blobdifffd ctext curdifftag curtagstart
2855 global diffnexthead diffnextnote difffilestart
2856 global nextupdate diffinhdr treediffs
2859 set n [gets $bdf line]
2863 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2864 $ctext tag add $curdifftag $curtagstart end
2869 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2872 $ctext conf -state normal
2873 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2874 # start of a new file
2875 $ctext insert end "\n"
2876 $ctext tag add $curdifftag $curtagstart end
2877 set curtagstart [$ctext index "end - 1c"]
2879 set here [$ctext index "end - 1c"]
2880 set i [lsearch -exact $treediffs($diffids) $fname]
2882 set difffilestart($i) $here
2884 $ctext mark set fmark.$i $here
2885 $ctext mark gravity fmark.$i left
2887 if {$newname != $fname} {
2888 set i [lsearch -exact $treediffs($diffids) $newname]
2890 set difffilestart($i) $here
2892 $ctext mark set fmark.$i $here
2893 $ctext mark gravity fmark.$i left
2896 set curdifftag "f:$fname"
2897 $ctext tag delete $curdifftag
2898 set l [expr {(78 - [string length $header]) / 2}]
2899 set pad [string range "----------------------------------------" 1 $l]
2900 $ctext insert end "$pad $header $pad\n" filesep
2902 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2904 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2905 $line match f1l f1c f2l f2c rest]} {
2907 $ctext insert end "\t" hunksep
2908 $ctext insert end " $f1l " d0 " $f2l " d1
2909 $ctext insert end " $rest \n" hunksep
2911 $ctext insert end "$line\n" hunksep
2915 set x [string range $line 0 0]
2916 if {$x == "-" || $x == "+"} {
2917 set tag [expr {$x == "+"}]
2919 set line [string range $line 1 end]
2921 $ctext insert end "$line\n" d$tag
2922 } elseif {$x == " "} {
2924 set line [string range $line 1 end]
2926 $ctext insert end "$line\n"
2927 } elseif {$diffinhdr || $x == "\\"} {
2928 # e.g. "\ No newline at end of file"
2929 $ctext insert end "$line\n" filesep
2931 # Something else we don't recognize
2932 if {$curdifftag != "Comments"} {
2933 $ctext insert end "\n"
2934 $ctext tag add $curdifftag $curtagstart end
2935 set curtagstart [$ctext index "end - 1c"]
2936 set curdifftag Comments
2938 $ctext insert end "$line\n" filesep
2941 $ctext conf -state disabled
2942 if {[clock clicks -milliseconds] >= $nextupdate} {
2944 fileevent $bdf readable {}
2946 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2951 global difffilestart ctext
2952 set here [$ctext index @0,0]
2953 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2954 if {[$ctext compare $difffilestart($i) > $here]} {
2955 if {![info exists pos]
2956 || [$ctext compare $difffilestart($i) < $pos]} {
2957 set pos $difffilestart($i)
2961 if {[info exists pos]} {
2966 proc listboxsel {} {
2967 global ctext cflist currentid
2968 if {![info exists currentid]} return
2969 set sel [lsort [$cflist curselection]]
2970 if {$sel eq {}} return
2971 set first [lindex $sel 0]
2972 catch {$ctext yview fmark.$first}
2976 global linespc charspc canvx0 canvy0 mainfont
2977 global xspc1 xspc2 lthickness
2979 set linespc [font metrics $mainfont -linespace]
2980 set charspc [font measure $mainfont "m"]
2981 set canvy0 [expr {3 + 0.5 * $linespc}]
2982 set canvx0 [expr {3 + 0.5 * $linespc}]
2983 set lthickness [expr {int($linespc / 9) + 1}]
2984 set xspc1(0) $linespc
2989 global stopped redisplaying phase
2990 if {$stopped > 1} return
2991 if {$phase == "getcommits"} return
2993 if {$phase == "drawgraph" || $phase == "incrdraw"} {
3000 proc incrfont {inc} {
3001 global mainfont namefont textfont ctext canv phase
3002 global stopped entries
3004 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
3005 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
3006 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
3008 $ctext conf -font $textfont
3009 $ctext tag conf filesep -font [concat $textfont bold]
3010 foreach e $entries {
3011 $e conf -font $mainfont
3013 if {$phase == "getcommits"} {
3014 $canv itemconf textitems -font $mainfont
3020 global sha1entry sha1string
3021 if {[string length $sha1string] == 40} {
3022 $sha1entry delete 0 end
3026 proc sha1change {n1 n2 op} {
3027 global sha1string currentid sha1but
3028 if {$sha1string == {}
3029 || ([info exists currentid] && $sha1string == $currentid)} {
3034 if {[$sha1but cget -state] == $state} return
3035 if {$state == "normal"} {
3036 $sha1but conf -state normal -relief raised -text "Goto: "
3038 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3042 proc gotocommit {} {
3043 global sha1string currentid idline tagids
3044 global lineid numcommits
3046 if {$sha1string == {}
3047 || ([info exists currentid] && $sha1string == $currentid)} return
3048 if {[info exists tagids($sha1string)]} {
3049 set id $tagids($sha1string)
3051 set id [string tolower $sha1string]
3052 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3054 for {set l 0} {$l < $numcommits} {incr l} {
3055 if {[string match $id* $lineid($l)]} {
3056 lappend matches $lineid($l)
3059 if {$matches ne {}} {
3060 if {[llength $matches] > 1} {
3061 error_popup "Short SHA1 id $id is ambiguous"
3064 set id [lindex $matches 0]
3068 if {[info exists idline($id)]} {
3069 selectline $idline($id) 1
3072 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3077 error_popup "$type $sha1string is not known"
3080 proc lineenter {x y id} {
3081 global hoverx hovery hoverid hovertimer
3082 global commitinfo canv
3084 if {![info exists commitinfo($id)]} return
3088 if {[info exists hovertimer]} {
3089 after cancel $hovertimer
3091 set hovertimer [after 500 linehover]
3095 proc linemotion {x y id} {
3096 global hoverx hovery hoverid hovertimer
3098 if {[info exists hoverid] && $id == $hoverid} {
3101 if {[info exists hovertimer]} {
3102 after cancel $hovertimer
3104 set hovertimer [after 500 linehover]
3108 proc lineleave {id} {
3109 global hoverid hovertimer canv
3111 if {[info exists hoverid] && $id == $hoverid} {
3113 if {[info exists hovertimer]} {
3114 after cancel $hovertimer
3122 global hoverx hovery hoverid hovertimer
3123 global canv linespc lthickness
3124 global commitinfo mainfont
3126 set text [lindex $commitinfo($hoverid) 0]
3127 set ymax [lindex [$canv cget -scrollregion] 3]
3128 if {$ymax == {}} return
3129 set yfrac [lindex [$canv yview] 0]
3130 set x [expr {$hoverx + 2 * $linespc}]
3131 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3132 set x0 [expr {$x - 2 * $lthickness}]
3133 set y0 [expr {$y - 2 * $lthickness}]
3134 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3135 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3136 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3137 -fill \#ffff80 -outline black -width 1 -tags hover]
3139 set t [$canv create text $x $y -anchor nw -text $text -tags hover -font $mainfont]
3143 proc clickisonarrow {id y} {
3144 global mainline mainlinearrow sidelines lthickness
3146 set thresh [expr {2 * $lthickness + 6}]
3147 if {[info exists mainline($id)]} {
3148 if {$mainlinearrow($id) ne "none"} {
3149 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3154 if {[info exists sidelines($id)]} {
3155 foreach ls $sidelines($id) {
3156 set coords [lindex $ls 0]
3157 set arrow [lindex $ls 2]
3158 if {$arrow eq "first" || $arrow eq "both"} {
3159 if {abs([lindex $coords 1] - $y) < $thresh} {
3163 if {$arrow eq "last" || $arrow eq "both"} {
3164 if {abs([lindex $coords end] - $y) < $thresh} {
3173 proc arrowjump {id dirn y} {
3174 global mainline sidelines canv canv2 canv3
3177 if {$dirn eq "down"} {
3178 if {[info exists mainline($id)]} {
3179 set y1 [lindex $mainline($id) 1]
3184 if {[info exists sidelines($id)]} {
3185 foreach ls $sidelines($id) {
3186 set y1 [lindex $ls 0 1]
3187 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3193 if {[info exists sidelines($id)]} {
3194 foreach ls $sidelines($id) {
3195 set y1 [lindex $ls 0 end]
3196 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3202 if {$yt eq {}} return
3203 set ymax [lindex [$canv cget -scrollregion] 3]
3204 if {$ymax eq {} || $ymax <= 0} return
3205 set view [$canv yview]
3206 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3207 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3211 $canv yview moveto $yfrac
3212 $canv2 yview moveto $yfrac
3213 $canv3 yview moveto $yfrac
3216 proc lineclick {x y id isnew} {
3217 global ctext commitinfo children cflist canv thickerline
3223 # draw this line thicker than normal
3227 set ymax [lindex [$canv cget -scrollregion] 3]
3228 if {$ymax eq {}} return
3229 set yfrac [lindex [$canv yview] 0]
3230 set y [expr {$y + $yfrac * $ymax}]
3232 set dirn [clickisonarrow $id $y]
3234 arrowjump $id $dirn $y
3239 addtohistory [list lineclick $x $y $id 0]
3241 # fill the details pane with info about this line
3242 $ctext conf -state normal
3243 $ctext delete 0.0 end
3244 $ctext tag conf link -foreground blue -underline 1
3245 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3246 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3247 $ctext insert end "Parent:\t"
3248 $ctext insert end $id [list link link0]
3249 $ctext tag bind link0 <1> [list selbyid $id]
3250 set info $commitinfo($id)
3251 $ctext insert end "\n\t[lindex $info 0]\n"
3252 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3253 set date [formatdate [lindex $info 2]]
3254 $ctext insert end "\tDate:\t$date\n"
3255 if {[info exists children($id)]} {
3256 $ctext insert end "\nChildren:"
3258 foreach child $children($id) {
3260 set info $commitinfo($child)
3261 $ctext insert end "\n\t"
3262 $ctext insert end $child [list link link$i]
3263 $ctext tag bind link$i <1> [list selbyid $child]
3264 $ctext insert end "\n\t[lindex $info 0]"
3265 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3266 set date [formatdate [lindex $info 2]]
3267 $ctext insert end "\n\tDate:\t$date\n"
3270 $ctext conf -state disabled
3272 $cflist delete 0 end
3275 proc normalline {} {
3277 if {[info exists thickerline]} {
3278 drawlines $thickerline 0 1
3285 if {[info exists idline($id)]} {
3286 selectline $idline($id) 1
3292 if {![info exists startmstime]} {
3293 set startmstime [clock clicks -milliseconds]
3295 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3298 proc rowmenu {x y id} {
3299 global rowctxmenu idline selectedline rowmenuid
3301 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3306 $rowctxmenu entryconfigure 0 -state $state
3307 $rowctxmenu entryconfigure 1 -state $state
3308 $rowctxmenu entryconfigure 2 -state $state
3310 tk_popup $rowctxmenu $x $y
3313 proc diffvssel {dirn} {
3314 global rowmenuid selectedline lineid
3316 if {![info exists selectedline]} return
3318 set oldid $lineid($selectedline)
3319 set newid $rowmenuid
3321 set oldid $rowmenuid
3322 set newid $lineid($selectedline)
3324 addtohistory [list doseldiff $oldid $newid]
3325 doseldiff $oldid $newid
3328 proc doseldiff {oldid newid} {
3332 $ctext conf -state normal
3333 $ctext delete 0.0 end
3334 $ctext mark set fmark.0 0.0
3335 $ctext mark gravity fmark.0 left
3336 $cflist delete 0 end
3337 $cflist insert end "Top"
3338 $ctext insert end "From "
3339 $ctext tag conf link -foreground blue -underline 1
3340 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3341 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3342 $ctext tag bind link0 <1> [list selbyid $oldid]
3343 $ctext insert end $oldid [list link link0]
3344 $ctext insert end "\n "
3345 $ctext insert end [lindex $commitinfo($oldid) 0]
3346 $ctext insert end "\n\nTo "
3347 $ctext tag bind link1 <1> [list selbyid $newid]
3348 $ctext insert end $newid [list link link1]
3349 $ctext insert end "\n "
3350 $ctext insert end [lindex $commitinfo($newid) 0]
3351 $ctext insert end "\n"
3352 $ctext conf -state disabled
3353 $ctext tag delete Comments
3354 $ctext tag remove found 1.0 end
3355 startdiff [list $newid $oldid] 0
3359 global rowmenuid currentid commitinfo patchtop patchnum
3361 if {![info exists currentid]} return
3362 set oldid $currentid
3363 set oldhead [lindex $commitinfo($oldid) 0]
3364 set newid $rowmenuid
3365 set newhead [lindex $commitinfo($newid) 0]
3368 catch {destroy $top}
3370 label $top.title -text "Generate patch"
3371 grid $top.title - -pady 10
3372 label $top.from -text "From:"
3373 entry $top.fromsha1 -width 40 -relief flat
3374 $top.fromsha1 insert 0 $oldid
3375 $top.fromsha1 conf -state readonly
3376 grid $top.from $top.fromsha1 -sticky w
3377 entry $top.fromhead -width 60 -relief flat
3378 $top.fromhead insert 0 $oldhead
3379 $top.fromhead conf -state readonly
3380 grid x $top.fromhead -sticky w
3381 label $top.to -text "To:"
3382 entry $top.tosha1 -width 40 -relief flat
3383 $top.tosha1 insert 0 $newid
3384 $top.tosha1 conf -state readonly
3385 grid $top.to $top.tosha1 -sticky w
3386 entry $top.tohead -width 60 -relief flat
3387 $top.tohead insert 0 $newhead
3388 $top.tohead conf -state readonly
3389 grid x $top.tohead -sticky w
3390 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3391 grid $top.rev x -pady 10
3392 label $top.flab -text "Output file:"
3393 entry $top.fname -width 60
3394 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3396 grid $top.flab $top.fname -sticky w
3398 button $top.buts.gen -text "Generate" -command mkpatchgo
3399 button $top.buts.can -text "Cancel" -command mkpatchcan
3400 grid $top.buts.gen $top.buts.can
3401 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3402 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3403 grid $top.buts - -pady 10 -sticky ew
3407 proc mkpatchrev {} {
3410 set oldid [$patchtop.fromsha1 get]
3411 set oldhead [$patchtop.fromhead get]
3412 set newid [$patchtop.tosha1 get]
3413 set newhead [$patchtop.tohead get]
3414 foreach e [list fromsha1 fromhead tosha1 tohead] \
3415 v [list $newid $newhead $oldid $oldhead] {
3416 $patchtop.$e conf -state normal
3417 $patchtop.$e delete 0 end
3418 $patchtop.$e insert 0 $v
3419 $patchtop.$e conf -state readonly
3426 set oldid [$patchtop.fromsha1 get]
3427 set newid [$patchtop.tosha1 get]
3428 set fname [$patchtop.fname get]
3429 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3430 error_popup "Error creating patch: $err"
3432 catch {destroy $patchtop}
3436 proc mkpatchcan {} {
3439 catch {destroy $patchtop}
3444 global rowmenuid mktagtop commitinfo
3448 catch {destroy $top}
3450 label $top.title -text "Create tag"
3451 grid $top.title - -pady 10
3452 label $top.id -text "ID:"
3453 entry $top.sha1 -width 40 -relief flat
3454 $top.sha1 insert 0 $rowmenuid
3455 $top.sha1 conf -state readonly
3456 grid $top.id $top.sha1 -sticky w
3457 entry $top.head -width 60 -relief flat
3458 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3459 $top.head conf -state readonly
3460 grid x $top.head -sticky w
3461 label $top.tlab -text "Tag name:"
3462 entry $top.tag -width 60
3463 grid $top.tlab $top.tag -sticky w
3465 button $top.buts.gen -text "Create" -command mktaggo
3466 button $top.buts.can -text "Cancel" -command mktagcan
3467 grid $top.buts.gen $top.buts.can
3468 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3469 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3470 grid $top.buts - -pady 10 -sticky ew
3475 global mktagtop env tagids idtags
3477 set id [$mktagtop.sha1 get]
3478 set tag [$mktagtop.tag get]
3480 error_popup "No tag name specified"
3483 if {[info exists tagids($tag)]} {
3484 error_popup "Tag \"$tag\" already exists"
3489 set fname [file join $dir "refs/tags" $tag]
3490 set f [open $fname w]
3494 error_popup "Error creating tag: $err"
3498 set tagids($tag) $id
3499 lappend idtags($id) $tag
3503 proc redrawtags {id} {
3504 global canv linehtag idline idpos selectedline
3506 if {![info exists idline($id)]} return
3507 $canv delete tag.$id
3508 set xt [eval drawtags $id $idpos($id)]
3509 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3510 if {[info exists selectedline] && $selectedline == $idline($id)} {
3511 selectline $selectedline 0
3518 catch {destroy $mktagtop}
3527 proc writecommit {} {
3528 global rowmenuid wrcomtop commitinfo wrcomcmd
3530 set top .writecommit
3532 catch {destroy $top}
3534 label $top.title -text "Write commit to file"
3535 grid $top.title - -pady 10
3536 label $top.id -text "ID:"
3537 entry $top.sha1 -width 40 -relief flat
3538 $top.sha1 insert 0 $rowmenuid
3539 $top.sha1 conf -state readonly
3540 grid $top.id $top.sha1 -sticky w
3541 entry $top.head -width 60 -relief flat
3542 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3543 $top.head conf -state readonly
3544 grid x $top.head -sticky w
3545 label $top.clab -text "Command:"
3546 entry $top.cmd -width 60 -textvariable wrcomcmd
3547 grid $top.clab $top.cmd -sticky w -pady 10
3548 label $top.flab -text "Output file:"
3549 entry $top.fname -width 60
3550 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3551 grid $top.flab $top.fname -sticky w
3553 button $top.buts.gen -text "Write" -command wrcomgo
3554 button $top.buts.can -text "Cancel" -command wrcomcan
3555 grid $top.buts.gen $top.buts.can
3556 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3557 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3558 grid $top.buts - -pady 10 -sticky ew
3565 set id [$wrcomtop.sha1 get]
3566 set cmd "echo $id | [$wrcomtop.cmd get]"
3567 set fname [$wrcomtop.fname get]
3568 if {[catch {exec sh -c $cmd >$fname &} err]} {
3569 error_popup "Error writing commit: $err"
3571 catch {destroy $wrcomtop}
3578 catch {destroy $wrcomtop}
3582 proc listrefs {id} {
3583 global idtags idheads idotherrefs
3586 if {[info exists idtags($id)]} {
3590 if {[info exists idheads($id)]} {
3594 if {[info exists idotherrefs($id)]} {
3595 set z $idotherrefs($id)
3597 return [list $x $y $z]
3600 proc rereadrefs {} {
3601 global idtags idheads idotherrefs
3602 global tagids headids otherrefids
3604 set refids [concat [array names idtags] \
3605 [array names idheads] [array names idotherrefs]]
3606 foreach id $refids {
3607 if {![info exists ref($id)]} {
3608 set ref($id) [listrefs $id]
3611 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
3615 set refids [lsort -unique [concat $refids [array names idtags] \
3616 [array names idheads] [array names idotherrefs]]]
3617 foreach id $refids {
3618 set v [listrefs $id]
3619 if {![info exists ref($id)] || $ref($id) != $v} {
3625 proc showtag {tag isnew} {
3626 global ctext cflist tagcontents tagids linknum
3629 addtohistory [list showtag $tag 0]
3631 $ctext conf -state normal
3632 $ctext delete 0.0 end
3634 if {[info exists tagcontents($tag)]} {
3635 set text $tagcontents($tag)
3637 set text "Tag: $tag\nId: $tagids($tag)"
3639 appendwithlinks $text
3640 $ctext conf -state disabled
3641 $cflist delete 0 end
3650 proc formatdate {d} {
3651 global hours nhours tfd fastdate
3654 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
3656 set hr [expr {$d / 3600}]
3657 set ms [expr {$d % 3600}]
3658 if {![info exists hours($hr)]} {
3659 set hours($hr) [clock format $d -format "%Y-%m-%d %H"]
3663 set minsec [format "%.2d:%.2d" [expr {$ms/60}] [expr {$ms%60}]]
3664 return "$hours($hr):$minsec"
3670 set diffopts "-U 5 -p"
3671 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3672 set gitencoding "utf-8"
3674 set mainfont {Helvetica 9}
3675 set textfont {Courier 9}
3676 set findmergefiles 0
3683 set colors {green red blue magenta darkgrey brown orange}
3685 catch {source ~/.gitk}
3687 set namefont $mainfont
3689 lappend namefont bold
3694 switch -regexp -- $arg {
3696 "^-b" { set boldnames 1 }
3697 "^-d" { set datemode 1 }
3698 "^-r" { set revlistorder 1 }
3700 lappend revtreeargs $arg
3715 getcommits $revtreeargs