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 parse_args
{rargs
} {
23 set parse_args
[concat
--default HEAD
$rargs]
24 set parsed_args
[split [eval exec git-rev-parse
$parse_args] "\n"]
26 # if git-rev-parse failed for some reason...
30 set parsed_args
$rargs
35 proc start_rev_list
{rlargs
} {
36 global startmsecs nextupdate ncmupdate
37 global commfd leftover gitencoding
39 set startmsecs
[clock clicks
-milliseconds]
40 set nextupdate
[expr {$startmsecs + 100}]
43 set commfd
[open
[concat | git-rev-list
--header --topo-order \
46 puts stderr
"Error executing git-rev-list: $err"
50 fconfigure
$commfd -blocking 0 -translation lf
-encoding $gitencoding
51 fileevent
$commfd readable
[list getcommitlines
$commfd]
52 . config
-cursor watch
56 proc getcommits
{rargs
} {
57 global oldcommits commits phase canv mainfont env
59 # check that we can find a .git directory somewhere...
61 if {![file isdirectory
$gitdir]} {
62 error_popup
"Cannot find the git directory \"$gitdir\"."
68 start_rev_list
[parse_args
$rargs]
70 $canv create text
3 3 -anchor nw
-text "Reading commits..." \
71 -font $mainfont -tags textitems
74 proc getcommitlines
{commfd
} {
75 global oldcommits commits parents cdate children nchildren
76 global commitlisted phase nextupdate
77 global stopped redisplaying leftover
80 set stuff
[read $commfd]
82 if {![eof
$commfd]} return
83 # set it blocking so we wait for the process to terminate
84 fconfigure
$commfd -blocking 1
85 if {![catch
{close
$commfd} err
]} {
86 after idle finishcommits
89 if {[string range
$err 0 4] == "usage"} {
91 "Gitk: error reading commits: bad arguments to git-rev-list.\
92 (Note: arguments to gitk are passed to git-rev-list\
93 to allow selection of commits to be displayed.)"
95 set err
"Error reading commits: $err"
102 set i
[string first
"\0" $stuff $start]
104 append leftover
[string range
$stuff $start end
]
107 set cmit
[string range
$stuff $start [expr {$i - 1}]]
109 set cmit
"$leftover$cmit"
112 set start
[expr {$i + 1}]
113 set j
[string first
"\n" $cmit]
116 set ids
[string range
$cmit 0 [expr {$j - 1}]]
119 if {![regexp
{^
[0-9a-f]{40}$
} $id]} {
127 if {[string length
$shortcmit] > 80} {
128 set shortcmit
"[string range $shortcmit 0 80]..."
130 error_popup
"Can't parse git-rev-list output: {$shortcmit}"
133 set id
[lindex
$ids 0]
134 set olds
[lrange
$ids 1 end
]
135 set cmit
[string range
$cmit [expr {$j + 1}] end
]
136 if {$phase == "updatecommits"} {
138 set oldcommits
$commits
145 set commitlisted
($id) 1
146 parsecommit
$id $cmit 1 [lrange
$ids 1 end
]
148 if {[clock clicks
-milliseconds] >= $nextupdate} {
151 while {$redisplaying} {
155 set phase
"getcommits"
156 foreach id
$commits {
159 if {[clock clicks
-milliseconds] >= $nextupdate} {
168 proc doupdate
{reading
} {
169 global commfd nextupdate numcommits ncmupdate
172 fileevent
$commfd readable
{}
175 set nextupdate
[expr {[clock clicks
-milliseconds] + 100}]
176 if {$numcommits < 100} {
177 set ncmupdate
[expr {$numcommits + 1}]
178 } elseif
{$numcommits < 10000} {
179 set ncmupdate
[expr {$numcommits + 10}]
181 set ncmupdate
[expr {$numcommits + 100}]
184 fileevent
$commfd readable
[list getcommitlines
$commfd]
188 proc readcommit
{id
} {
189 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
190 parsecommit
$id $contents 0 {}
193 proc updatechildren
{id olds
} {
194 global children nchildren parents nparents ncleft
196 if {![info exists nchildren
($id)]} {
201 set parents
($id) $olds
202 set nparents
($id) [llength
$olds]
204 if {![info exists nchildren
($p)]} {
205 set children
($p) [list
$id]
208 } elseif
{[lsearch
-exact $children($p) $id] < 0} {
209 lappend children
($p) $id
216 proc parsecommit
{id contents listed olds
} {
217 global commitinfo cdate
226 updatechildren
$id $olds
227 set hdrend
[string first
"\n\n" $contents]
229 # should never happen...
230 set hdrend
[string length
$contents]
232 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
233 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
234 foreach line
[split $header "\n"] {
235 set tag
[lindex
$line 0]
236 if {$tag == "author"} {
237 set audate
[lindex
$line end-1
]
238 set auname
[lrange
$line 1 end-2
]
239 } elseif
{$tag == "committer"} {
240 set comdate
[lindex
$line end-1
]
241 set comname
[lrange
$line 1 end-2
]
245 # take the first line of the comment as the headline
246 set i
[string first
"\n" $comment]
248 set headline
[string trim
[string range
$comment 0 $i]]
250 set headline
$comment
253 # git-rev-list indents the comment by 4 spaces;
254 # if we got this via git-cat-file, add the indentation
256 foreach line
[split $comment "\n"] {
257 append newcomment
" "
258 append newcomment
$line
259 append newcomment
"\n"
261 set comment
$newcomment
263 if {$comdate != {}} {
264 set cdate
($id) $comdate
266 set commitinfo
($id) [list
$headline $auname $audate \
267 $comname $comdate $comment]
271 global tagids idtags headids idheads tagcontents
272 global otherrefids idotherrefs
274 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
277 set refd
[open
[list | git-ls-remote
[gitdir
]] r
]
278 while {0 <= [set n
[gets
$refd line
]]} {
279 if {![regexp
{^
([0-9a-f]{40}) refs
/([^^
]*)$
} $line \
283 if {![regexp
{^
(tags|heads
)/(.
*)$
} $path match
type name
]} {
287 if {$type == "tags"} {
288 set tagids
($name) $id
289 lappend idtags
($id) $name
294 set commit
[exec git-rev-parse
"$id^0"]
295 if {"$commit" != "$id"} {
296 set tagids
($name) $commit
297 lappend idtags
($commit) $name
301 set tagcontents
($name) [exec git-cat-file tag
"$id"]
303 } elseif
{ $type == "heads" } {
304 set headids
($name) $id
305 lappend idheads
($id) $name
307 set otherrefids
($name) $id
308 lappend idotherrefs
($id) $name
314 proc error_popup msg
{
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"
326 proc makewindow
{rargs
} {
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 mergemax
334 .bar add cascade
-label "File" -menu .bar.
file
336 .bar.
file add
command -label "Update" -command [list updatecommits
$rargs]
337 .bar.
file add
command -label "Reread references" -command rereadrefs
338 .bar.
file add
command -label "Quit" -command doquit
340 .bar add cascade
-label "Edit" -menu .bar.edit
341 .bar.edit add
command -label "Preferences" -command doprefs
343 .bar add cascade
-label "Help" -menu .bar.
help
344 .bar.
help add
command -label "About gitk" -command about
345 . configure
-menu .bar
347 if {![info exists geometry
(canv1
)]} {
348 set geometry
(canv1
) [expr {45 * $charspc}]
349 set geometry
(canv2
) [expr {30 * $charspc}]
350 set geometry
(canv3
) [expr {15 * $charspc}]
351 set geometry
(canvh
) [expr {25 * $linespc + 4}]
352 set geometry
(ctextw
) 80
353 set geometry
(ctexth
) 30
354 set geometry
(cflistw
) 30
356 panedwindow .ctop
-orient vertical
357 if {[info exists geometry
(width
)]} {
358 .ctop conf
-width $geometry(width
) -height $geometry(height
)
359 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
360 set geometry
(ctexth
) [expr {($texth - 8) /
361 [font metrics
$textfont -linespace]}]
365 pack .ctop.top.bar
-side bottom
-fill x
366 set cscroll .ctop.top.csb
367 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
368 pack
$cscroll -side right
-fill y
369 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
370 pack .ctop.top.clist
-side top
-fill both
-expand 1
372 set canv .ctop.top.clist.canv
373 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
375 -yscrollincr $linespc -yscrollcommand "$cscroll set"
376 .ctop.top.clist add
$canv
377 set canv2 .ctop.top.clist.canv2
378 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
379 -bg white
-bd 0 -yscrollincr $linespc
380 .ctop.top.clist add
$canv2
381 set canv3 .ctop.top.clist.canv3
382 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
383 -bg white
-bd 0 -yscrollincr $linespc
384 .ctop.top.clist add
$canv3
385 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
387 set sha1entry .ctop.top.bar.sha1
388 set entries
$sha1entry
389 set sha1but .ctop.top.bar.sha1label
390 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
391 -command gotocommit
-width 8
392 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
393 pack .ctop.top.bar.sha1label
-side left
394 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
395 trace add variable sha1string
write sha1change
396 pack
$sha1entry -side left
-pady 2
398 image create bitmap bm-left
-data {
399 #define left_width 16
400 #define left_height 16
401 static unsigned char left_bits
[] = {
402 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
403 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
404 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
406 image create bitmap bm-right
-data {
407 #define right_width 16
408 #define right_height 16
409 static unsigned char right_bits
[] = {
410 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
411 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
412 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
414 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
415 -state disabled
-width 26
416 pack .ctop.top.bar.leftbut
-side left
-fill y
417 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
418 -state disabled
-width 26
419 pack .ctop.top.bar.rightbut
-side left
-fill y
421 button .ctop.top.bar.findbut
-text "Find" -command dofind
422 pack .ctop.top.bar.findbut
-side left
424 set fstring .ctop.top.bar.findstring
425 lappend entries
$fstring
426 entry
$fstring -width 30 -font $textfont -textvariable findstring
427 pack
$fstring -side left
-expand 1 -fill x
429 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
430 findtype Exact IgnCase Regexp
]
431 set findloc
"All fields"
432 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
433 Comments Author Committer Files Pickaxe
434 pack .ctop.top.bar.findloc
-side right
435 pack .ctop.top.bar.findtype
-side right
436 # for making sure type==Exact whenever loc==Pickaxe
437 trace add variable findloc
write findlocchange
439 panedwindow .ctop.cdet
-orient horizontal
441 frame .ctop.cdet.left
442 set ctext .ctop.cdet.left.ctext
443 text
$ctext -bg white
-state disabled
-font $textfont \
444 -width $geometry(ctextw
) -height $geometry(ctexth
) \
445 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
446 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
447 pack .ctop.cdet.left.sb
-side right
-fill y
448 pack
$ctext -side left
-fill both
-expand 1
449 .ctop.cdet add .ctop.cdet.left
451 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
452 $ctext tag conf hunksep
-fore blue
453 $ctext tag conf d0
-fore red
454 $ctext tag conf d1
-fore "#00a000"
455 $ctext tag conf m0
-fore red
456 $ctext tag conf m1
-fore blue
457 $ctext tag conf m2
-fore green
458 $ctext tag conf m3
-fore purple
459 $ctext tag conf
m4 -fore brown
460 $ctext tag conf mmax
-fore darkgrey
462 $ctext tag conf mresult
-font [concat
$textfont bold
]
463 $ctext tag conf msep
-font [concat
$textfont bold
]
464 $ctext tag conf found
-back yellow
466 frame .ctop.cdet.right
467 set cflist .ctop.cdet.right.cfiles
468 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
469 -yscrollcommand ".ctop.cdet.right.sb set"
470 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
471 pack .ctop.cdet.right.sb
-side right
-fill y
472 pack
$cflist -side left
-fill both
-expand 1
473 .ctop.cdet add .ctop.cdet.right
474 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
476 pack .ctop
-side top
-fill both
-expand 1
478 bindall
<1> {selcanvline
%W
%x
%y
}
479 #bindall <B1-Motion> {selcanvline %W %x %y}
480 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
481 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
482 bindall
<2> "allcanvs scan mark 0 %y"
483 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
484 bind .
<Key-Up
> "selnextline -1"
485 bind .
<Key-Down
> "selnextline 1"
486 bind .
<Key-Right
> "goforw"
487 bind .
<Key-Left
> "goback"
488 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
489 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
490 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
491 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
492 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
493 bindkey p
"selnextline -1"
494 bindkey n
"selnextline 1"
497 bindkey i
"selnextline -1"
498 bindkey k
"selnextline 1"
501 bindkey b
"$ctext yview scroll -1 pages"
502 bindkey d
"$ctext yview scroll 18 units"
503 bindkey u
"$ctext yview scroll -18 units"
504 bindkey
/ {findnext
1}
505 bindkey
<Key-Return
> {findnext
0}
508 bind .
<Control-q
> doquit
509 bind .
<Control-f
> dofind
510 bind .
<Control-g
> {findnext
0}
511 bind .
<Control-r
> findprev
512 bind .
<Control-equal
> {incrfont
1}
513 bind .
<Control-KP_Add
> {incrfont
1}
514 bind .
<Control-minus
> {incrfont
-1}
515 bind .
<Control-KP_Subtract
> {incrfont
-1}
516 bind $cflist <<ListboxSelect>> listboxsel
517 bind . <Destroy> {savestuff %W}
518 bind . <Button-1> "click %W"
519 bind $fstring <Key-Return> dofind
520 bind $sha1entry <Key-Return> gotocommit
521 bind $sha1entry <<PasteSelection>> clearsha1
523 set maincursor [. cget -cursor]
524 set textcursor [$ctext cget -cursor]
525 set curtextcursor $textcursor
527 set rowctxmenu .rowctxmenu
528 menu $rowctxmenu -tearoff 0
529 $rowctxmenu add command -label "Diff this -> selected" \
530 -command {diffvssel 0}
531 $rowctxmenu add command -label "Diff selected -> this" \
532 -command {diffvssel 1}
533 $rowctxmenu add command -label "Make patch" -command mkpatch
534 $rowctxmenu add command -label "Create tag" -command mktag
535 $rowctxmenu add command -label "Write commit to file" -command writecommit
538 # when we make a key binding for the toplevel, make sure
539 # it doesn't get triggered when that key is pressed in the
540 # find string entry widget.
541 proc bindkey {ev script} {
544 set escript [bind Entry $ev]
545 if {$escript == {}} {
546 set escript [bind Entry <Key>]
549 bind $e $ev "$escript; break"
553 # set the focus back to the toplevel for any click outside
564 global canv canv2 canv3 ctext cflist mainfont textfont
565 global stuffsaved findmergefiles maxgraphpct
568 if {$stuffsaved} return
569 if {![winfo viewable .]} return
571 set f [open "~/.gitk-new" w]
572 puts $f [list set mainfont $mainfont]
573 puts $f [list set textfont $textfont]
574 puts $f [list set findmergefiles $findmergefiles]
575 puts $f [list set maxgraphpct $maxgraphpct]
576 puts $f [list set maxwidth $maxwidth]
577 puts $f "set geometry(width) [winfo width .ctop]"
578 puts $f "set geometry(height) [winfo height .ctop]"
579 puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]"
580 puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]"
581 puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]"
582 puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]"
583 set wid [expr {([winfo width $ctext] - 8) \
584 / [font measure $textfont "0"]}]
585 puts $f "set geometry(ctextw) $wid"
586 set wid [expr {([winfo width $cflist] - 11) \
587 / [font measure [$cflist cget -font] "0"]}]
588 puts $f "set geometry(cflistw) $wid"
590 file rename -force "~/.gitk-new" "~/.gitk"
595 proc resizeclistpanes {win w} {
597 if [info exists oldwidth($win)] {
598 set s0 [$win sash coord 0]
599 set s1 [$win sash coord 1]
601 set sash0 [expr {int($w/2 - 2)}]
602 set sash1 [expr {int($w*5/6 - 2)}]
604 set factor [expr {1.0 * $w / $oldwidth($win)}]
605 set sash0 [expr {int($factor * [lindex $s0 0])}]
606 set sash1 [expr {int($factor * [lindex $s1 0])}]
610 if {$sash1 < $sash0 + 20} {
611 set sash1 [expr {$sash0 + 20}]
613 if {$sash1 > $w - 10} {
614 set sash1 [expr {$w - 10}]
615 if {$sash0 > $sash1 - 20} {
616 set sash0 [expr {$sash1 - 20}]
620 $win sash place 0 $sash0 [lindex $s0 1]
621 $win sash place 1 $sash1 [lindex $s1 1]
623 set oldwidth($win) $w
626 proc resizecdetpanes {win w} {
628 if [info exists oldwidth($win)] {
629 set s0 [$win sash coord 0]
631 set sash0 [expr {int($w*3/4 - 2)}]
633 set factor [expr {1.0 * $w / $oldwidth($win)}]
634 set sash0 [expr {int($factor * [lindex $s0 0])}]
638 if {$sash0 > $w - 15} {
639 set sash0 [expr {$w - 15}]
642 $win sash place 0 $sash0 [lindex $s0 1]
644 set oldwidth($win) $w
648 global canv canv2 canv3
654 proc bindall {event action} {
655 global canv canv2 canv3
656 bind $canv $event $action
657 bind $canv2 $event $action
658 bind $canv3 $event $action
663 if {[winfo exists $w]} {
668 wm title $w "About gitk"
672 Copyright © 2005 Paul Mackerras
674 Use and redistribute under the terms of the GNU General Public License} \
675 -justify center -aspect 400
676 pack $w.m -side top -fill x -padx 20 -pady 20
677 button $w.ok -text Close -command "destroy $w"
678 pack $w.ok -side bottom
681 proc assigncolor {id} {
682 global colormap commcolors colors nextcolor
683 global parents nparents children nchildren
684 global cornercrossings crossings
686 if [info exists colormap($id)] return
687 set ncolors [llength $colors]
688 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
689 set child [lindex $children($id) 0]
690 if {[info exists colormap($child)]
691 && $nparents($child) == 1} {
692 set colormap($id) $colormap($child)
697 if {[info exists cornercrossings($id)]} {
698 foreach x $cornercrossings($id) {
699 if {[info exists colormap($x)]
700 && [lsearch -exact $badcolors $colormap($x)] < 0} {
701 lappend badcolors $colormap($x)
704 if {[llength $badcolors] >= $ncolors} {
708 set origbad $badcolors
709 if {[llength $badcolors] < $ncolors - 1} {
710 if {[info exists crossings($id)]} {
711 foreach x $crossings($id) {
712 if {[info exists colormap($x)]
713 && [lsearch -exact $badcolors $colormap($x)] < 0} {
714 lappend badcolors $colormap($x)
717 if {[llength $badcolors] >= $ncolors} {
718 set badcolors $origbad
721 set origbad $badcolors
723 if {[llength $badcolors] < $ncolors - 1} {
724 foreach child $children($id) {
725 if {[info exists colormap($child)]
726 && [lsearch -exact $badcolors $colormap($child)] < 0} {
727 lappend badcolors $colormap($child)
729 if {[info exists parents($child)]} {
730 foreach p $parents($child) {
731 if {[info exists colormap($p)]
732 && [lsearch -exact $badcolors $colormap($p)] < 0} {
733 lappend badcolors $colormap($p)
738 if {[llength $badcolors] >= $ncolors} {
739 set badcolors $origbad
742 for {set i 0} {$i <= $ncolors} {incr i} {
743 set c [lindex $colors $nextcolor]
744 if {[incr nextcolor] >= $ncolors} {
747 if {[lsearch -exact $badcolors $c]} break
753 global canvy canvy0 lineno numcommits nextcolor linespc
754 global mainline mainlinearrow sidelines
755 global nchildren ncleft
756 global displist nhyperspace
763 catch {unset mainline}
764 catch {unset mainlinearrow}
765 catch {unset sidelines}
766 foreach id [array names nchildren] {
767 set ncleft($id) $nchildren($id)
773 proc bindline {t id} {
776 $canv bind $t <Enter> "lineenter %x %y $id"
777 $canv bind $t <Motion> "linemotion %x %y $id"
778 $canv bind $t <Leave> "lineleave $id"
779 $canv bind $t <Button-1> "lineclick %x %y $id 1"
782 proc drawlines {id xtra delold} {
783 global mainline mainlinearrow sidelines lthickness colormap canv
786 $canv delete lines.$id
788 if {[info exists mainline($id)]} {
789 set t [$canv create line $mainline($id) \
790 -width [expr {($xtra + 1) * $lthickness}] \
791 -fill $colormap($id) -tags lines.$id \
792 -arrow $mainlinearrow($id)]
796 if {[info exists sidelines($id)]} {
797 foreach ls $sidelines($id) {
798 set coords [lindex $ls 0]
799 set thick [lindex $ls 1]
800 set arrow [lindex $ls 2]
801 set t [$canv create line $coords -fill $colormap($id) \
802 -width [expr {($thick + $xtra) * $lthickness}] \
803 -arrow $arrow -tags lines.$id]
810 # level here is an index in displist
811 proc drawcommitline {level} {
812 global parents children nparents displist
813 global canv canv2 canv3 mainfont namefont canvy linespc
814 global lineid linehtag linentag linedtag commitinfo
815 global colormap numcommits currentparents dupparents
816 global idtags idline idheads idotherrefs
817 global lineno lthickness mainline mainlinearrow sidelines
818 global commitlisted rowtextx idpos lastuse displist
819 global oldnlines olddlevel olddisplist
823 set id [lindex $displist $level]
824 set lastuse($id) $lineno
825 set lineid($lineno) $id
826 set idline($id) $lineno
827 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
828 if {![info exists commitinfo($id)]} {
830 if {![info exists commitinfo($id)]} {
831 set commitinfo($id) {"No commit information available"}
836 set currentparents {}
838 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
839 foreach p $parents($id) {
840 if {[lsearch -exact $currentparents $p] < 0} {
841 lappend currentparents $p
843 # remember that this parent was listed twice
844 lappend dupparents $p
848 set x [xcoord $level $level $lineno]
850 set canvy [expr {$canvy + $linespc}]
851 allcanvs conf -scrollregion \
852 [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]]
853 if {[info exists mainline($id)]} {
854 lappend mainline($id) $x $y1
855 if {$mainlinearrow($id) ne "none"} {
856 set mainline($id) [trimdiagstart $mainline($id)]
860 set orad [expr {$linespc / 3}]
861 set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \
862 [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \
863 -fill $ofill -outline black -width 1]
865 $canv bind $t <1> {selcanvline {} %x %y}
866 set xt [xcoord [llength $displist] $level $lineno]
867 if {[llength $currentparents] > 2} {
868 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
870 set rowtextx($lineno) $xt
871 set idpos($id) [list $x $xt $y1]
872 if {[info exists idtags($id)] || [info exists idheads($id)]
873 || [info exists idotherrefs($id)]} {
874 set xt [drawtags $id $x $xt $y1]
876 set headline [lindex $commitinfo($id) 0]
877 set name [lindex $commitinfo($id) 1]
878 set date [lindex $commitinfo($id) 2]
879 set date [formatdate $date]
880 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
881 -text $headline -font $mainfont ]
882 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
883 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
884 -text $name -font $namefont]
885 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
886 -text $date -font $mainfont]
889 set olddisplist $displist
890 set oldnlines [llength $displist]
893 proc drawtags {id x xt y1} {
894 global idtags idheads idotherrefs
895 global linespc lthickness
896 global canv mainfont idline rowtextx
901 if {[info exists idtags($id)]} {
902 set marks $idtags($id)
903 set ntags [llength $marks]
905 if {[info exists idheads($id)]} {
906 set marks [concat $marks $idheads($id)]
907 set nheads [llength $idheads($id)]
909 if {[info exists idotherrefs($id)]} {
910 set marks [concat $marks $idotherrefs($id)]
916 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
917 set yt [expr {$y1 - 0.5 * $linespc}]
918 set yb [expr {$yt + $linespc - 1}]
922 set wid [font measure $mainfont $tag]
925 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
927 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
928 -width $lthickness -fill black -tags tag.$id]
930 foreach tag $marks x $xvals wid $wvals {
931 set xl [expr {$x + $delta}]
932 set xr [expr {$x + $delta + $wid + $lthickness}]
933 if {[incr ntags -1] >= 0} {
935 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
936 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
937 -width 1 -outline black -fill yellow -tags tag.$id]
938 $canv bind $t <1> [list showtag $tag 1]
939 set rowtextx($idline($id)) [expr {$xr + $linespc}]
941 # draw a head or other ref
942 if {[incr nheads -1] >= 0} {
947 set xl [expr {$xl - $delta/2}]
948 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
949 -width 1 -outline black -fill $col -tags tag.$id
951 set t [$canv create text $xl $y1 -anchor w -text $tag \
952 -font $mainfont -tags tag.$id]
954 $canv bind $t <1> [list showtag $tag 1]
960 proc notecrossings {id lo hi corner} {
961 global olddisplist crossings cornercrossings
963 for {set i $lo} {[incr i] < $hi} {} {
964 set p [lindex $olddisplist $i]
965 if {$p == {}} continue
967 if {![info exists cornercrossings($id)]
968 || [lsearch -exact $cornercrossings($id) $p] < 0} {
969 lappend cornercrossings($id) $p
971 if {![info exists cornercrossings($p)]
972 || [lsearch -exact $cornercrossings($p) $id] < 0} {
973 lappend cornercrossings($p) $id
976 if {![info exists crossings($id)]
977 || [lsearch -exact $crossings($id) $p] < 0} {
978 lappend crossings($id) $p
980 if {![info exists crossings($p)]
981 || [lsearch -exact $crossings($p) $id] < 0} {
982 lappend crossings($p) $id
988 proc xcoord {i level ln} {
989 global canvx0 xspc1 xspc2
991 set x [expr {$canvx0 + $i * $xspc1($ln)}]
992 if {$i > 0 && $i == $level} {
993 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
994 } elseif {$i > $level} {
995 set x [expr {$x + $xspc2 - $xspc1($ln)}]
1000 # it seems Tk can't draw arrows on the end of diagonal line segments...
1001 proc trimdiagend {line} {
1002 while {[llength $line] > 4} {
1003 set x1 [lindex $line end-3]
1004 set y1 [lindex $line end-2]
1005 set x2 [lindex $line end-1]
1006 set y2 [lindex $line end]
1007 if {($x1 == $x2) != ($y1 == $y2)} break
1008 set line [lreplace $line end-1 end]
1013 proc trimdiagstart {line} {
1014 while {[llength $line] > 4} {
1015 set x1 [lindex $line 0]
1016 set y1 [lindex $line 1]
1017 set x2 [lindex $line 2]
1018 set y2 [lindex $line 3]
1019 if {($x1 == $x2) != ($y1 == $y2)} break
1020 set line [lreplace $line 0 1]
1025 proc drawslants {id needonscreen nohs} {
1026 global canv mainline mainlinearrow sidelines
1027 global canvx0 canvy xspc1 xspc2 lthickness
1028 global currentparents dupparents
1029 global lthickness linespc canvy colormap lineno geometry
1030 global maxgraphpct maxwidth
1031 global displist onscreen lastuse
1032 global parents commitlisted
1033 global oldnlines olddlevel olddisplist
1034 global nhyperspace numcommits nnewparents
1037 lappend displist $id
1042 set y1 [expr {$canvy - $linespc}]
1045 # work out what we need to get back on screen
1047 if {$onscreen($id) < 0} {
1048 # next to do isn't displayed, better get it on screen...
1049 lappend reins [list $id 0]
1051 # make sure all the previous commits's parents are on the screen
1052 foreach p $currentparents {
1053 if {$onscreen($p) < 0} {
1054 lappend reins [list $p 0]
1057 # bring back anything requested by caller
1058 if {$needonscreen ne {}} {
1059 lappend reins $needonscreen
1063 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1064 set dlevel $olddlevel
1065 set x [xcoord $dlevel $dlevel $lineno]
1066 set mainline($id) [list $x $y1]
1067 set mainlinearrow($id) none
1068 set lastuse($id) $lineno
1069 set displist [lreplace $displist $dlevel $dlevel $id]
1071 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1076 set displist [lreplace $displist $olddlevel $olddlevel]
1078 foreach p $currentparents {
1079 set lastuse($p) $lineno
1080 if {$onscreen($p) == 0} {
1081 set displist [linsert $displist $j $p]
1086 if {$onscreen($id) == 0} {
1087 lappend displist $id
1091 # remove the null entry if present
1092 set nullentry [lsearch -exact $displist {}]
1093 if {$nullentry >= 0} {
1094 set displist [lreplace $displist $nullentry $nullentry]
1097 # bring back the ones we need now (if we did it earlier
1098 # it would change displist and invalidate olddlevel)
1100 # test again in case of duplicates in reins
1101 set p [lindex $pi 0]
1102 if {$onscreen($p) < 0} {
1104 set lastuse($p) $lineno
1105 set displist [linsert $displist [lindex $pi 1] $p]
1110 set lastuse($id) $lineno
1112 # see if we need to make any lines jump off into hyperspace
1113 set displ [llength $displist]
1114 if {$displ > $maxwidth} {
1116 foreach x $displist {
1117 lappend ages [list $lastuse($x) $x]
1119 set ages [lsort -integer -index 0 $ages]
1121 while {$displ > $maxwidth} {
1122 set use [lindex $ages $k 0]
1123 set victim [lindex $ages $k 1]
1124 if {$use >= $lineno - 5} break
1126 if {[lsearch -exact $nohs $victim] >= 0} continue
1127 set i [lsearch -exact $displist $victim]
1128 set displist [lreplace $displist $i $i]
1129 set onscreen($victim) -1
1132 if {$i < $nullentry} {
1135 set x [lindex $mainline($victim) end-1]
1136 lappend mainline($victim) $x $y1
1137 set line [trimdiagend $mainline($victim)]
1139 if {$mainlinearrow($victim) ne "none"} {
1140 set line [trimdiagstart $line]
1143 lappend sidelines($victim) [list $line 1 $arrow]
1144 unset mainline($victim)
1148 set dlevel [lsearch -exact $displist $id]
1150 # If we are reducing, put in a null entry
1151 if {$displ < $oldnlines} {
1152 # does the next line look like a merge?
1153 # i.e. does it have > 1 new parent?
1154 if {$nnewparents($id) > 1} {
1155 set i [expr {$dlevel + 1}]
1156 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1158 if {$nullentry >= 0 && $nullentry < $i} {
1161 } elseif {$nullentry >= 0} {
1164 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1169 if {$dlevel >= $i} {
1174 set displist [linsert $displist $i {}]
1176 if {$dlevel >= $i} {
1182 # decide on the line spacing for the next line
1183 set lj [expr {$lineno + 1}]
1184 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1185 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1186 set xspc1($lj) $xspc2
1188 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1189 if {$xspc1($lj) < $lthickness} {
1190 set xspc1($lj) $lthickness
1194 foreach idi $reins {
1195 set id [lindex $idi 0]
1196 set j [lsearch -exact $displist $id]
1197 set xj [xcoord $j $dlevel $lj]
1198 set mainline($id) [list $xj $y2]
1199 set mainlinearrow($id) first
1203 foreach id $olddisplist {
1205 if {$id == {}} continue
1206 if {$onscreen($id) <= 0} continue
1207 set xi [xcoord $i $olddlevel $lineno]
1208 if {$i == $olddlevel} {
1209 foreach p $currentparents {
1210 set j [lsearch -exact $displist $p]
1211 set coords [list $xi $y1]
1212 set xj [xcoord $j $dlevel $lj]
1213 if {$xj < $xi - $linespc} {
1214 lappend coords [expr {$xj + $linespc}] $y1
1215 notecrossings $p $j $i [expr {$j + 1}]
1216 } elseif {$xj > $xi + $linespc} {
1217 lappend coords [expr {$xj - $linespc}] $y1
1218 notecrossings $p $i $j [expr {$j - 1}]
1220 if {[lsearch -exact $dupparents $p] >= 0} {
1221 # draw a double-width line to indicate the doubled parent
1222 lappend coords $xj $y2
1223 lappend sidelines($p) [list $coords 2 none]
1224 if {![info exists mainline($p)]} {
1225 set mainline($p) [list $xj $y2]
1226 set mainlinearrow($p) none
1229 # normal case, no parent duplicated
1231 set dx [expr {abs($xi - $xj)}]
1232 if {0 && $dx < $linespc} {
1233 set yb [expr {$y1 + $dx}]
1235 if {![info exists mainline($p)]} {
1237 lappend coords $xj $yb
1239 set mainline($p) $coords
1240 set mainlinearrow($p) none
1242 lappend coords $xj $yb
1244 lappend coords $xj $y2
1246 lappend sidelines($p) [list $coords 1 none]
1252 if {[lindex $displist $i] != $id} {
1253 set j [lsearch -exact $displist $id]
1255 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1256 || ($olddlevel < $i && $i < $dlevel)
1257 || ($dlevel < $i && $i < $olddlevel)} {
1258 set xj [xcoord $j $dlevel $lj]
1259 lappend mainline($id) $xi $y1 $xj $y2
1266 # search for x in a list of lists
1267 proc llsearch {llist x} {
1270 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1278 proc drawmore {reading} {
1279 global displayorder numcommits ncmupdate nextupdate
1280 global stopped nhyperspace parents commitlisted
1281 global maxwidth onscreen displist currentparents olddlevel
1283 set n [llength $displayorder]
1284 while {$numcommits < $n} {
1285 set id [lindex $displayorder $numcommits]
1286 set ctxend [expr {$numcommits + 10}]
1287 if {!$reading && $ctxend > $n} {
1291 if {$numcommits > 0} {
1292 set dlist [lreplace $displist $olddlevel $olddlevel]
1294 foreach p $currentparents {
1295 if {$onscreen($p) == 0} {
1296 set dlist [linsert $dlist $i $p]
1303 set isfat [expr {[llength $dlist] > $maxwidth}]
1304 if {$nhyperspace > 0 || $isfat} {
1305 if {$ctxend > $n} break
1306 # work out what to bring back and
1307 # what we want to don't want to send into hyperspace
1309 for {set k $numcommits} {$k < $ctxend} {incr k} {
1310 set x [lindex $displayorder $k]
1311 set i [llsearch $dlist $x]
1313 set i [llength $dlist]
1316 if {[lsearch -exact $nohs $x] < 0} {
1319 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1320 set reins [list $x $i]
1323 if {[info exists commitlisted($x)]} {
1325 foreach p $parents($x) {
1326 if {[llsearch $dlist $p] < 0} {
1328 if {[lsearch -exact $nohs $p] < 0} {
1331 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1332 set reins [list $p [expr {$i + $right}]]
1338 set l [lindex $dlist $i]
1339 if {[llength $l] == 1} {
1342 set j [lsearch -exact $l $x]
1343 set l [concat [lreplace $l $j $j] $newp]
1345 set dlist [lreplace $dlist $i $i $l]
1346 if {$room && $isfat && [llength $newp] <= 1} {
1352 set dlevel [drawslants $id $reins $nohs]
1353 drawcommitline $dlevel
1354 if {[clock clicks -milliseconds] >= $nextupdate
1355 && $numcommits >= $ncmupdate} {
1362 # level here is an index in todo
1363 proc updatetodo {level noshortcut} {
1364 global ncleft todo nnewparents
1365 global commitlisted parents onscreen
1367 set id [lindex $todo $level]
1369 if {[info exists commitlisted($id)]} {
1370 foreach p $parents($id) {
1371 if {[lsearch -exact $olds $p] < 0} {
1376 if {!$noshortcut && [llength $olds] == 1} {
1377 set p [lindex $olds 0]
1378 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1380 set todo [lreplace $todo $level $level $p]
1382 set nnewparents($id) 1
1387 set todo [lreplace $todo $level $level]
1392 set k [lsearch -exact $todo $p]
1394 set todo [linsert $todo $i $p]
1400 set nnewparents($id) $n
1405 proc decidenext {{noread 0}} {
1407 global datemode cdate
1410 # choose which one to do next time around
1411 set todol [llength $todo]
1414 for {set k $todol} {[incr k -1] >= 0} {} {
1415 set p [lindex $todo $k]
1416 if {$ncleft($p) == 0} {
1418 if {![info exists commitinfo($p)]} {
1424 if {$latest == {} || $cdate($p) > $latest} {
1426 set latest $cdate($p)
1436 puts "ERROR: none of the pending commits can be done yet:"
1438 puts " $p ($ncleft($p))"
1447 proc drawcommit {id reading} {
1448 global phase todo nchildren datemode nextupdate revlistorder
1449 global numcommits ncmupdate displayorder todo onscreen
1450 global numcommits ncmupdate displayorder todo onscreen parents
1452 if {$phase != "incrdraw"} {
1458 if {$nchildren($id) == 0} {
1462 if {$revlistorder} {
1463 set level [lsearch -exact $todo $id]
1465 error_popup "oops, $id isn't in todo"
1468 lappend displayorder $id
1471 set level [decidenext 1]
1472 if {$level == {} || $id != [lindex $todo $level]} {
1476 lappend displayorder [lindex $todo $level]
1477 if {[updatetodo $level $datemode]} {
1478 set level [decidenext 1]
1479 if {$level == {}} break
1481 set id [lindex $todo $level]
1482 if {![info exists commitlisted($id)]} {
1490 proc finishcommits {} {
1491 global phase oldcommits commits
1492 global canv mainfont ctext maincursor textcursor
1495 if {$phase == "incrdraw" || $phase == "removecommits"} {
1496 foreach id $oldcommits {
1498 updatechildren $id $parents($id)
1503 } elseif {$phase == "updatecommits"} {
1507 $canv create text 3 3 -anchor nw -text "No commits selected" \
1508 -font $mainfont -tags textitems
1511 . config -cursor $maincursor
1512 settextcursor $textcursor
1515 # Don't change the text pane cursor if it is currently the hand cursor,
1516 # showing that we are over a sha1 ID link.
1517 proc settextcursor {c} {
1518 global ctext curtextcursor
1520 if {[$ctext cget -cursor] == $curtextcursor} {
1521 $ctext config -cursor $c
1523 set curtextcursor $c
1527 global nextupdate startmsecs ncmupdate
1528 global displayorder onscreen
1530 if {$displayorder == {}} return
1531 set startmsecs [clock clicks -milliseconds]
1532 set nextupdate [expr {$startmsecs + 100}]
1535 foreach id $displayorder {
1542 global phase stopped redisplaying selectedline
1543 global datemode todo displayorder
1544 global numcommits ncmupdate
1545 global nextupdate startmsecs revlistorder
1547 set level [decidenext]
1551 lappend displayorder [lindex $todo $level]
1552 set hard [updatetodo $level $datemode]
1554 set level [decidenext]
1555 if {$level < 0} break
1561 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
1562 #puts "overall $drawmsecs ms for $numcommits commits"
1563 if {$redisplaying} {
1564 if {$stopped == 0 && [info exists selectedline]} {
1565 selectline $selectedline 0
1567 if {$stopped == 1} {
1569 after idle drawgraph
1576 proc findmatches {f} {
1577 global findtype foundstring foundstrlen
1578 if {$findtype == "Regexp"} {
1579 set matches [regexp -indices -all -inline $foundstring $f]
1581 if {$findtype == "IgnCase"} {
1582 set str [string tolower $f]
1588 while {[set j [string first $foundstring $str $i]] >= 0} {
1589 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
1590 set i [expr {$j + $foundstrlen}]
1597 global findtype findloc findstring markedmatches commitinfo
1598 global numcommits lineid linehtag linentag linedtag
1599 global mainfont namefont canv canv2 canv3 selectedline
1600 global matchinglines foundstring foundstrlen
1605 set matchinglines {}
1606 if {$findloc == "Pickaxe"} {
1610 if {$findtype == "IgnCase"} {
1611 set foundstring [string tolower $findstring]
1613 set foundstring $findstring
1615 set foundstrlen [string length $findstring]
1616 if {$foundstrlen == 0} return
1617 if {$findloc == "Files"} {
1621 if {![info exists selectedline]} {
1624 set oldsel $selectedline
1627 set fldtypes {Headline Author Date Committer CDate Comment}
1628 for {set l 0} {$l < $numcommits} {incr l} {
1630 set info $commitinfo($id)
1632 foreach f $info ty $fldtypes {
1633 if {$findloc != "All fields" && $findloc != $ty} {
1636 set matches [findmatches $f]
1637 if {$matches == {}} continue
1639 if {$ty == "Headline"} {
1640 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1641 } elseif {$ty == "Author"} {
1642 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1643 } elseif {$ty == "Date"} {
1644 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1648 lappend matchinglines $l
1649 if {!$didsel && $l > $oldsel} {
1655 if {$matchinglines == {}} {
1657 } elseif {!$didsel} {
1658 findselectline [lindex $matchinglines 0]
1662 proc findselectline {l} {
1663 global findloc commentend ctext
1665 if {$findloc == "All fields" || $findloc == "Comments"} {
1666 # highlight the matches in the comments
1667 set f [$ctext get 1.0 $commentend]
1668 set matches [findmatches $f]
1669 foreach match $matches {
1670 set start [lindex $match 0]
1671 set end [expr {[lindex $match 1] + 1}]
1672 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1677 proc findnext {restart} {
1678 global matchinglines selectedline
1679 if {![info exists matchinglines]} {
1685 if {![info exists selectedline]} return
1686 foreach l $matchinglines {
1687 if {$l > $selectedline} {
1696 global matchinglines selectedline
1697 if {![info exists matchinglines]} {
1701 if {![info exists selectedline]} return
1703 foreach l $matchinglines {
1704 if {$l >= $selectedline} break
1708 findselectline $prev
1714 proc findlocchange {name ix op} {
1715 global findloc findtype findtypemenu
1716 if {$findloc == "Pickaxe"} {
1722 $findtypemenu entryconf 1 -state $state
1723 $findtypemenu entryconf 2 -state $state
1726 proc stopfindproc {{done 0}} {
1727 global findprocpid findprocfile findids
1728 global ctext findoldcursor phase maincursor textcursor
1729 global findinprogress
1731 catch {unset findids}
1732 if {[info exists findprocpid]} {
1734 catch {exec kill $findprocpid}
1736 catch {close $findprocfile}
1739 if {[info exists findinprogress]} {
1740 unset findinprogress
1741 if {$phase != "incrdraw"} {
1742 . config -cursor $maincursor
1743 settextcursor $textcursor
1748 proc findpatches {} {
1749 global findstring selectedline numcommits
1750 global findprocpid findprocfile
1751 global finddidsel ctext lineid findinprogress
1752 global findinsertpos
1754 if {$numcommits == 0} return
1756 # make a list of all the ids to search, starting at the one
1757 # after the selected line (if any)
1758 if {[info exists selectedline]} {
1764 for {set i 0} {$i < $numcommits} {incr i} {
1765 if {[incr l] >= $numcommits} {
1768 append inputids $lineid($l) "\n"
1772 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1775 error_popup "Error starting search process: $err"
1779 set findinsertpos end
1781 set findprocpid [pid $f]
1782 fconfigure $f -blocking 0
1783 fileevent $f readable readfindproc
1785 . config -cursor watch
1787 set findinprogress 1
1790 proc readfindproc {} {
1791 global findprocfile finddidsel
1792 global idline matchinglines findinsertpos
1794 set n [gets $findprocfile line]
1796 if {[eof $findprocfile]} {
1804 if {![regexp {^[0-9a-f]{40}} $line id]} {
1805 error_popup "Can't parse git-diff-tree output: $line"
1809 if {![info exists idline($id)]} {
1810 puts stderr "spurious id: $id"
1817 proc insertmatch {l id} {
1818 global matchinglines findinsertpos finddidsel
1820 if {$findinsertpos == "end"} {
1821 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1822 set matchinglines [linsert $matchinglines 0 $l]
1825 lappend matchinglines $l
1828 set matchinglines [linsert $matchinglines $findinsertpos $l]
1839 global selectedline numcommits lineid ctext
1840 global ffileline finddidsel parents nparents
1841 global findinprogress findstartline findinsertpos
1842 global treediffs fdiffids fdiffsneeded fdiffpos
1843 global findmergefiles
1845 if {$numcommits == 0} return
1847 if {[info exists selectedline]} {
1848 set l [expr {$selectedline + 1}]
1853 set findstartline $l
1858 if {$findmergefiles || $nparents($id) == 1} {
1859 foreach p $parents($id) {
1860 if {![info exists treediffs([list $id $p])]} {
1861 append diffsneeded "$id $p\n"
1862 lappend fdiffsneeded [list $id $p]
1866 if {[incr l] >= $numcommits} {
1869 if {$l == $findstartline} break
1872 # start off a git-diff-tree process if needed
1873 if {$diffsneeded ne {}} {
1875 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1877 error_popup "Error starting search process: $err"
1880 catch {unset fdiffids}
1882 fconfigure $df -blocking 0
1883 fileevent $df readable [list readfilediffs $df]
1887 set findinsertpos end
1889 set p [lindex $parents($id) 0]
1890 . config -cursor watch
1892 set findinprogress 1
1893 findcont [list $id $p]
1897 proc readfilediffs {df} {
1898 global findids fdiffids fdiffs
1900 set n [gets $df line]
1904 if {[catch {close $df} err]} {
1907 error_popup "Error in git-diff-tree: $err"
1908 } elseif {[info exists findids]} {
1912 error_popup "Couldn't find diffs for {$ids}"
1917 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1918 # start of a new string of diffs
1920 set fdiffids [list $id $p]
1922 } elseif {[string match ":*" $line]} {
1923 lappend fdiffs [lindex $line 5]
1927 proc donefilediff {} {
1928 global fdiffids fdiffs treediffs findids
1929 global fdiffsneeded fdiffpos
1931 if {[info exists fdiffids]} {
1932 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1933 && $fdiffpos < [llength $fdiffsneeded]} {
1934 # git-diff-tree doesn't output anything for a commit
1935 # which doesn't change anything
1936 set nullids [lindex $fdiffsneeded $fdiffpos]
1937 set treediffs($nullids) {}
1938 if {[info exists findids] && $nullids eq $findids} {
1946 if {![info exists treediffs($fdiffids)]} {
1947 set treediffs($fdiffids) $fdiffs
1949 if {[info exists findids] && $fdiffids eq $findids} {
1956 proc findcont {ids} {
1957 global findids treediffs parents nparents
1958 global ffileline findstartline finddidsel
1959 global lineid numcommits matchinglines findinprogress
1960 global findmergefiles
1962 set id [lindex $ids 0]
1963 set p [lindex $ids 1]
1964 set pi [lsearch -exact $parents($id) $p]
1967 if {$findmergefiles || $nparents($id) == 1} {
1968 if {![info exists treediffs($ids)]} {
1974 foreach f $treediffs($ids) {
1975 set x [findmatches $f]
1983 set pi $nparents($id)
1986 set pi $nparents($id)
1988 if {[incr pi] >= $nparents($id)} {
1990 if {[incr l] >= $numcommits} {
1993 if {$l == $findstartline} break
1996 set p [lindex $parents($id) $pi]
1997 set ids [list $id $p]
2005 # mark a commit as matching by putting a yellow background
2006 # behind the headline
2007 proc markheadline {l id} {
2008 global canv mainfont linehtag commitinfo
2010 set bbox [$canv bbox $linehtag($l)]
2011 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
2015 # mark the bits of a headline, author or date that match a find string
2016 proc markmatches {canv l str tag matches font} {
2017 set bbox [$canv bbox $tag]
2018 set x0 [lindex $bbox 0]
2019 set y0 [lindex $bbox 1]
2020 set y1 [lindex $bbox 3]
2021 foreach match $matches {
2022 set start [lindex $match 0]
2023 set end [lindex $match 1]
2024 if {$start > $end} continue
2025 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
2026 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
2027 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
2028 [expr {$x0+$xlen+2}] $y1 \
2029 -outline {} -tags matches -fill yellow]
2034 proc unmarkmatches {} {
2035 global matchinglines findids
2036 allcanvs delete matches
2037 catch {unset matchinglines}
2038 catch {unset findids}
2041 proc selcanvline {w x y} {
2042 global canv canvy0 ctext linespc
2043 global lineid linehtag linentag linedtag rowtextx
2044 set ymax [lindex [$canv cget -scrollregion] 3]
2045 if {$ymax == {}} return
2046 set yfrac [lindex [$canv yview] 0]
2047 set y [expr {$y + $yfrac * $ymax}]
2048 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2053 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2059 proc commit_descriptor {p} {
2062 if {[info exists commitinfo($p)]} {
2063 set l [lindex $commitinfo($p) 0]
2068 # append some text to the ctext widget, and make any SHA1 ID
2069 # that we know about be a clickable link.
2070 proc appendwithlinks {text} {
2071 global ctext idline linknum
2073 set start [$ctext index "end - 1c"]
2074 $ctext insert end $text
2075 $ctext insert end "\n"
2076 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2080 set linkid [string range $text $s $e]
2081 if {![info exists idline($linkid)]} continue
2083 $ctext tag add link "$start + $s c" "$start + $e c"
2084 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2085 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2088 $ctext tag conf link -foreground blue -underline 1
2089 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2090 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2093 proc selectline {l isnew} {
2094 global canv canv2 canv3 ctext commitinfo selectedline
2095 global lineid linehtag linentag linedtag
2096 global canvy0 linespc parents nparents children
2097 global cflist currentid sha1entry
2098 global commentend idtags idline linknum
2102 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2104 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2105 -tags secsel -fill [$canv cget -selectbackground]]
2107 $canv2 delete secsel
2108 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2109 -tags secsel -fill [$canv2 cget -selectbackground]]
2111 $canv3 delete secsel
2112 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2113 -tags secsel -fill [$canv3 cget -selectbackground]]
2115 set y [expr {$canvy0 + $l * $linespc}]
2116 set ymax [lindex [$canv cget -scrollregion] 3]
2117 set ytop [expr {$y - $linespc - 1}]
2118 set ybot [expr {$y + $linespc + 1}]
2119 set wnow [$canv yview]
2120 set wtop [expr {[lindex $wnow 0] * $ymax}]
2121 set wbot [expr {[lindex $wnow 1] * $ymax}]
2122 set wh [expr {$wbot - $wtop}]
2124 if {$ytop < $wtop} {
2125 if {$ybot < $wtop} {
2126 set newtop [expr {$y - $wh / 2.0}]
2129 if {$newtop > $wtop - $linespc} {
2130 set newtop [expr {$wtop - $linespc}]
2133 } elseif {$ybot > $wbot} {
2134 if {$ytop > $wbot} {
2135 set newtop [expr {$y - $wh / 2.0}]
2137 set newtop [expr {$ybot - $wh}]
2138 if {$newtop < $wtop + $linespc} {
2139 set newtop [expr {$wtop + $linespc}]
2143 if {$newtop != $wtop} {
2147 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
2151 addtohistory [list selectline $l 0]
2158 $sha1entry delete 0 end
2159 $sha1entry insert 0 $id
2160 $sha1entry selection from 0
2161 $sha1entry selection to end
2163 $ctext conf -state normal
2164 $ctext delete 0.0 end
2166 $ctext mark set fmark.0 0.0
2167 $ctext mark gravity fmark.0 left
2168 set info $commitinfo($id)
2169 set date [formatdate [lindex $info 2]]
2170 $ctext insert end "Author: [lindex $info 1] $date\n"
2171 set date [formatdate [lindex $info 4]]
2172 $ctext insert end "Committer: [lindex $info 3] $date\n"
2173 if {[info exists idtags($id)]} {
2174 $ctext insert end "Tags:"
2175 foreach tag $idtags($id) {
2176 $ctext insert end " $tag"
2178 $ctext insert end "\n"
2182 if {[info exists parents($id)]} {
2183 foreach p $parents($id) {
2184 append comment "Parent: [commit_descriptor $p]\n"
2187 if {[info exists children($id)]} {
2188 foreach c $children($id) {
2189 append comment "Child: [commit_descriptor $c]\n"
2193 append comment [lindex $info 5]
2195 # make anything that looks like a SHA1 ID be a clickable link
2196 appendwithlinks $comment
2198 $ctext tag delete Comments
2199 $ctext tag remove found 1.0 end
2200 $ctext conf -state disabled
2201 set commentend [$ctext index "end - 1c"]
2203 $cflist delete 0 end
2204 $cflist insert end "Comments"
2205 if {$nparents($id) == 1} {
2207 } elseif {$nparents($id) > 1} {
2212 proc selnextline {dir} {
2214 if {![info exists selectedline]} return
2215 set l [expr {$selectedline + $dir}]
2220 proc unselectline {} {
2223 catch {unset selectedline}
2224 allcanvs delete secsel
2227 proc addtohistory {cmd} {
2228 global history historyindex
2230 if {$historyindex > 0
2231 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2235 if {$historyindex < [llength $history]} {
2236 set history [lreplace $history $historyindex end $cmd]
2238 lappend history $cmd
2241 if {$historyindex > 1} {
2242 .ctop.top.bar.leftbut conf -state normal
2244 .ctop.top.bar.leftbut conf -state disabled
2246 .ctop.top.bar.rightbut conf -state disabled
2250 global history historyindex
2252 if {$historyindex > 1} {
2253 incr historyindex -1
2254 set cmd [lindex $history [expr {$historyindex - 1}]]
2256 .ctop.top.bar.rightbut conf -state normal
2258 if {$historyindex <= 1} {
2259 .ctop.top.bar.leftbut conf -state disabled
2264 global history historyindex
2266 if {$historyindex < [llength $history]} {
2267 set cmd [lindex $history $historyindex]
2270 .ctop.top.bar.leftbut conf -state normal
2272 if {$historyindex >= [llength $history]} {
2273 .ctop.top.bar.rightbut conf -state disabled
2277 proc mergediff {id} {
2278 global parents diffmergeid diffmergegca mergefilelist diffpindex
2282 set diffmergegca [findgca $parents($id)]
2283 if {[info exists mergefilelist($id)]} {
2284 if {$mergefilelist($id) ne {}} {
2292 proc findgca {ids} {
2299 set gca [exec git-merge-base $gca $id]
2308 proc contmergediff {ids} {
2309 global diffmergeid diffpindex parents nparents diffmergegca
2310 global treediffs mergefilelist diffids treepending
2312 # diff the child against each of the parents, and diff
2313 # each of the parents against the GCA.
2315 if {[lindex $ids 1] == $diffmergeid && $diffmergegca ne {}} {
2316 set ids [list $diffmergegca [lindex $ids 0]]
2318 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2319 set p [lindex $parents($diffmergeid) $diffpindex]
2320 set ids [list $p $diffmergeid]
2322 if {![info exists treediffs($ids)]} {
2324 if {![info exists treepending]} {
2331 # If a file in some parent is different from the child and also
2332 # different from the GCA, then it's interesting.
2333 # If we don't have a GCA, then a file is interesting if it is
2334 # different from the child in all the parents.
2335 if {$diffmergegca ne {}} {
2337 foreach p $parents($diffmergeid) {
2338 set gcadiffs $treediffs([list $diffmergegca $p])
2339 foreach f $treediffs([list $p $diffmergeid]) {
2340 if {[lsearch -exact $files $f] < 0
2341 && [lsearch -exact $gcadiffs $f] >= 0} {
2346 set files [lsort $files]
2348 set p [lindex $parents($diffmergeid) 0]
2349 set files $treediffs([list $diffmergeid $p])
2350 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2351 set p [lindex $parents($diffmergeid) $i]
2352 set df $treediffs([list $p $diffmergeid])
2355 if {[lsearch -exact $df $f] >= 0} {
2363 set mergefilelist($diffmergeid) $files
2369 proc showmergediff {} {
2370 global cflist diffmergeid mergefilelist parents
2371 global diffopts diffinhunk currentfile currenthunk filelines
2372 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2374 set files $mergefilelist($diffmergeid)
2376 $cflist insert end $f
2378 set env(GIT_DIFF_OPTS) $diffopts
2380 catch {unset currentfile}
2381 catch {unset currenthunk}
2382 catch {unset filelines}
2383 catch {unset groupfilenum}
2384 catch {unset grouphunks}
2385 set groupfilelast -1
2386 foreach p $parents($diffmergeid) {
2387 set cmd [list | git-diff-tree -p $p $diffmergeid]
2388 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2389 if {[catch {set f [open $cmd r]} err]} {
2390 error_popup "Error getting diffs: $err"
2397 set ids [list $diffmergeid $p]
2398 set mergefds($ids) $f
2399 set diffinhunk($ids) 0
2400 set diffblocked($ids) 0
2401 fconfigure $f -blocking 0
2402 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2406 proc getmergediffline {f ids id} {
2407 global diffmergeid diffinhunk diffoldlines diffnewlines
2408 global currentfile currenthunk
2409 global diffoldstart diffnewstart diffoldlno diffnewlno
2410 global diffblocked mergefilelist
2411 global noldlines nnewlines difflcounts filelines
2413 set n [gets $f line]
2415 if {![eof $f]} return
2418 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2425 if {$diffinhunk($ids) != 0} {
2426 set fi $currentfile($ids)
2427 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2428 # continuing an existing hunk
2429 set line [string range $line 1 end]
2430 set p [lindex $ids 1]
2431 if {$match eq "-" || $match eq " "} {
2432 set filelines($p,$fi,$diffoldlno($ids)) $line
2433 incr diffoldlno($ids)
2435 if {$match eq "+" || $match eq " "} {
2436 set filelines($id,$fi,$diffnewlno($ids)) $line
2437 incr diffnewlno($ids)
2439 if {$match eq " "} {
2440 if {$diffinhunk($ids) == 2} {
2441 lappend difflcounts($ids) \
2442 [list $noldlines($ids) $nnewlines($ids)]
2443 set noldlines($ids) 0
2444 set diffinhunk($ids) 1
2446 incr noldlines($ids)
2447 } elseif {$match eq "-" || $match eq "+"} {
2448 if {$diffinhunk($ids) == 1} {
2449 lappend difflcounts($ids) [list $noldlines($ids)]
2450 set noldlines($ids) 0
2451 set nnewlines($ids) 0
2452 set diffinhunk($ids) 2
2454 if {$match eq "-"} {
2455 incr noldlines($ids)
2457 incr nnewlines($ids)
2460 # and if it's \ No newline at end of line, then what?
2464 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2465 lappend difflcounts($ids) [list $noldlines($ids)]
2466 } elseif {$diffinhunk($ids) == 2
2467 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2468 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2470 set currenthunk($ids) [list $currentfile($ids) \
2471 $diffoldstart($ids) $diffnewstart($ids) \
2472 $diffoldlno($ids) $diffnewlno($ids) \
2474 set diffinhunk($ids) 0
2475 # -1 = need to block, 0 = unblocked, 1 = is blocked
2476 set diffblocked($ids) -1
2478 if {$diffblocked($ids) == -1} {
2479 fileevent $f readable {}
2480 set diffblocked($ids) 1
2486 if {!$diffblocked($ids)} {
2488 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2489 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2492 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2493 # start of a new file
2494 set currentfile($ids) \
2495 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2496 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2497 $line match f1l f1c f2l f2c rest]} {
2498 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2499 # start of a new hunk
2500 if {$f1l == 0 && $f1c == 0} {
2503 if {$f2l == 0 && $f2c == 0} {
2506 set diffinhunk($ids) 1
2507 set diffoldstart($ids) $f1l
2508 set diffnewstart($ids) $f2l
2509 set diffoldlno($ids) $f1l
2510 set diffnewlno($ids) $f2l
2511 set difflcounts($ids) {}
2512 set noldlines($ids) 0
2513 set nnewlines($ids) 0
2518 proc processhunks {} {
2519 global diffmergeid parents nparents currenthunk
2520 global mergefilelist diffblocked mergefds
2521 global grouphunks grouplinestart grouplineend groupfilenum
2523 set nfiles [llength $mergefilelist($diffmergeid)]
2527 # look for the earliest hunk
2528 foreach p $parents($diffmergeid) {
2529 set ids [list $diffmergeid $p]
2530 if {![info exists currenthunk($ids)]} return
2531 set i [lindex $currenthunk($ids) 0]
2532 set l [lindex $currenthunk($ids) 2]
2533 if {$i < $fi || ($i == $fi && $l < $lno)} {
2540 if {$fi < $nfiles} {
2541 set ids [list $diffmergeid $pi]
2542 set hunk $currenthunk($ids)
2543 unset currenthunk($ids)
2544 if {$diffblocked($ids) > 0} {
2545 fileevent $mergefds($ids) readable \
2546 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2548 set diffblocked($ids) 0
2550 if {[info exists groupfilenum] && $groupfilenum == $fi
2551 && $lno <= $grouplineend} {
2552 # add this hunk to the pending group
2553 lappend grouphunks($pi) $hunk
2554 set endln [lindex $hunk 4]
2555 if {$endln > $grouplineend} {
2556 set grouplineend $endln
2562 # succeeding stuff doesn't belong in this group, so
2563 # process the group now
2564 if {[info exists groupfilenum]} {
2570 if {$fi >= $nfiles} break
2573 set groupfilenum $fi
2574 set grouphunks($pi) [list $hunk]
2575 set grouplinestart $lno
2576 set grouplineend [lindex $hunk 4]
2580 proc processgroup {} {
2581 global groupfilelast groupfilenum difffilestart
2582 global mergefilelist diffmergeid ctext filelines
2583 global parents diffmergeid diffoffset
2584 global grouphunks grouplinestart grouplineend nparents
2587 $ctext conf -state normal
2590 if {$groupfilelast != $f} {
2591 $ctext insert end "\n"
2592 set here [$ctext index "end - 1c"]
2593 set difffilestart($f) $here
2594 set mark fmark.[expr {$f + 1}]
2595 $ctext mark set $mark $here
2596 $ctext mark gravity $mark left
2597 set header [lindex $mergefilelist($id) $f]
2598 set l [expr {(78 - [string length $header]) / 2}]
2599 set pad [string range "----------------------------------------" 1 $l]
2600 $ctext insert end "$pad $header $pad\n" filesep
2601 set groupfilelast $f
2602 foreach p $parents($id) {
2603 set diffoffset($p) 0
2607 $ctext insert end "@@" msep
2608 set nlines [expr {$grouplineend - $grouplinestart}]
2611 foreach p $parents($id) {
2612 set startline [expr {$grouplinestart + $diffoffset($p)}]
2614 set nl $grouplinestart
2615 if {[info exists grouphunks($p)]} {
2616 foreach h $grouphunks($p) {
2619 for {} {$nl < $l} {incr nl} {
2620 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2624 foreach chunk [lindex $h 5] {
2625 if {[llength $chunk] == 2} {
2626 set olc [lindex $chunk 0]
2627 set nlc [lindex $chunk 1]
2628 set nnl [expr {$nl + $nlc}]
2629 lappend events [list $nl $nnl $pnum $olc $nlc]
2633 incr ol [lindex $chunk 0]
2634 incr nl [lindex $chunk 0]
2639 if {$nl < $grouplineend} {
2640 for {} {$nl < $grouplineend} {incr nl} {
2641 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2645 set nlines [expr {$ol - $startline}]
2646 $ctext insert end " -$startline,$nlines" msep
2650 set nlines [expr {$grouplineend - $grouplinestart}]
2651 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2653 set events [lsort -integer -index 0 $events]
2654 set nevents [llength $events]
2655 set nmerge $nparents($diffmergeid)
2656 set l $grouplinestart
2657 for {set i 0} {$i < $nevents} {set i $j} {
2658 set nl [lindex $events $i 0]
2660 $ctext insert end " $filelines($id,$f,$l)\n"
2663 set e [lindex $events $i]
2664 set enl [lindex $e 1]
2668 set pnum [lindex $e 2]
2669 set olc [lindex $e 3]
2670 set nlc [lindex $e 4]
2671 if {![info exists delta($pnum)]} {
2672 set delta($pnum) [expr {$olc - $nlc}]
2673 lappend active $pnum
2675 incr delta($pnum) [expr {$olc - $nlc}]
2677 if {[incr j] >= $nevents} break
2678 set e [lindex $events $j]
2679 if {[lindex $e 0] >= $enl} break
2680 if {[lindex $e 1] > $enl} {
2681 set enl [lindex $e 1]
2684 set nlc [expr {$enl - $l}]
2687 if {[llength $active] == $nmerge - 1} {
2688 # no diff for one of the parents, i.e. it's identical
2689 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2690 if {![info exists delta($pnum)]} {
2691 if {$pnum < $mergemax} {
2699 } elseif {[llength $active] == $nmerge} {
2700 # all parents are different, see if one is very similar
2702 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2703 set sim [similarity $pnum $l $nlc $f \
2704 [lrange $events $i [expr {$j-1}]]]
2705 if {$sim > $bestsim} {
2711 lappend ncol m$bestpn
2715 foreach p $parents($id) {
2717 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2718 set olc [expr {$nlc + $delta($pnum)}]
2719 set ol [expr {$l + $diffoffset($p)}]
2720 incr diffoffset($p) $delta($pnum)
2722 for {} {$olc > 0} {incr olc -1} {
2723 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2727 set endl [expr {$l + $nlc}]
2729 # show this pretty much as a normal diff
2730 set p [lindex $parents($id) $bestpn]
2731 set ol [expr {$l + $diffoffset($p)}]
2732 incr diffoffset($p) $delta($bestpn)
2733 unset delta($bestpn)
2734 for {set k $i} {$k < $j} {incr k} {
2735 set e [lindex $events $k]
2736 if {[lindex $e 2] != $bestpn} continue
2737 set nl [lindex $e 0]
2738 set ol [expr {$ol + $nl - $l}]
2739 for {} {$l < $nl} {incr l} {
2740 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2743 for {} {$c > 0} {incr c -1} {
2744 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2747 set nl [lindex $e 1]
2748 for {} {$l < $nl} {incr l} {
2749 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2753 for {} {$l < $endl} {incr l} {
2754 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2757 while {$l < $grouplineend} {
2758 $ctext insert end " $filelines($id,$f,$l)\n"
2761 $ctext conf -state disabled
2764 proc similarity {pnum l nlc f events} {
2765 global diffmergeid parents diffoffset filelines
2768 set p [lindex $parents($id) $pnum]
2769 set ol [expr {$l + $diffoffset($p)}]
2770 set endl [expr {$l + $nlc}]
2774 if {[lindex $e 2] != $pnum} continue
2775 set nl [lindex $e 0]
2776 set ol [expr {$ol + $nl - $l}]
2777 for {} {$l < $nl} {incr l} {
2778 incr same [string length $filelines($id,$f,$l)]
2781 set oc [lindex $e 3]
2782 for {} {$oc > 0} {incr oc -1} {
2783 incr diff [string length $filelines($p,$f,$ol)]
2787 set nl [lindex $e 1]
2788 for {} {$l < $nl} {incr l} {
2789 incr diff [string length $filelines($id,$f,$l)]
2793 for {} {$l < $endl} {incr l} {
2794 incr same [string length $filelines($id,$f,$l)]
2800 return [expr {200 * $same / (2 * $same + $diff)}]
2803 proc startdiff {ids} {
2804 global treediffs diffids treepending diffmergeid
2807 catch {unset diffmergeid}
2808 if {![info exists treediffs($ids)]} {
2809 if {![info exists treepending]} {
2817 proc addtocflist {ids} {
2818 global treediffs cflist
2819 foreach f $treediffs($ids) {
2820 $cflist insert end $f
2825 proc gettreediffs {ids} {
2826 global treediff parents treepending
2827 set treepending $ids
2829 if [catch {set gdtf [open [concat | git-diff-tree --no-commit-id -r $ids] r]}] return
2830 fconfigure $gdtf -blocking 0
2831 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2834 proc gettreediffline {gdtf ids} {
2835 global treediff treediffs treepending diffids diffmergeid
2837 set n [gets $gdtf line]
2839 if {![eof $gdtf]} return
2841 set treediffs($ids) $treediff
2843 if {$ids != $diffids} {
2844 gettreediffs $diffids
2846 if {[info exists diffmergeid]} {
2854 set file [lindex $line 5]
2855 lappend treediff $file
2858 proc getblobdiffs {ids} {
2859 global diffopts blobdifffd diffids env curdifftag curtagstart
2860 global difffilestart nextupdate diffinhdr treediffs
2862 set env(GIT_DIFF_OPTS) $diffopts
2863 set cmd [concat | git-diff-tree --no-commit-id -r -p -C $ids]
2864 if {[catch {set bdf [open $cmd r]} err]} {
2865 puts "error getting diffs: $err"
2869 fconfigure $bdf -blocking 0
2870 set blobdifffd($ids) $bdf
2871 set curdifftag Comments
2873 catch {unset difffilestart}
2874 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2875 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2878 proc getblobdiffline {bdf ids} {
2879 global diffids blobdifffd ctext curdifftag curtagstart
2880 global diffnexthead diffnextnote difffilestart
2881 global nextupdate diffinhdr treediffs
2883 set n [gets $bdf line]
2887 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2888 $ctext tag add $curdifftag $curtagstart end
2893 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2896 $ctext conf -state normal
2897 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2898 # start of a new file
2899 $ctext insert end "\n"
2900 $ctext tag add $curdifftag $curtagstart end
2901 set curtagstart [$ctext index "end - 1c"]
2903 set here [$ctext index "end - 1c"]
2904 set i [lsearch -exact $treediffs($diffids) $fname]
2906 set difffilestart($i) $here
2908 $ctext mark set fmark.$i $here
2909 $ctext mark gravity fmark.$i left
2911 if {$newname != $fname} {
2912 set i [lsearch -exact $treediffs($diffids) $newname]
2914 set difffilestart($i) $here
2916 $ctext mark set fmark.$i $here
2917 $ctext mark gravity fmark.$i left
2920 set curdifftag "f:$fname"
2921 $ctext tag delete $curdifftag
2922 set l [expr {(78 - [string length $header]) / 2}]
2923 set pad [string range "----------------------------------------" 1 $l]
2924 $ctext insert end "$pad $header $pad\n" filesep
2926 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2928 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2929 $line match f1l f1c f2l f2c rest]} {
2930 $ctext insert end "$line\n" hunksep
2933 set x [string range $line 0 0]
2934 if {$x == "-" || $x == "+"} {
2935 set tag [expr {$x == "+"}]
2936 $ctext insert end "$line\n" d$tag
2937 } elseif {$x == " "} {
2938 $ctext insert end "$line\n"
2939 } elseif {$diffinhdr || $x == "\\"} {
2940 # e.g. "\ No newline at end of file"
2941 $ctext insert end "$line\n" filesep
2943 # Something else we don't recognize
2944 if {$curdifftag != "Comments"} {
2945 $ctext insert end "\n"
2946 $ctext tag add $curdifftag $curtagstart end
2947 set curtagstart [$ctext index "end - 1c"]
2948 set curdifftag Comments
2950 $ctext insert end "$line\n" filesep
2953 $ctext conf -state disabled
2954 if {[clock clicks -milliseconds] >= $nextupdate} {
2956 fileevent $bdf readable {}
2958 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2963 global difffilestart ctext
2964 set here [$ctext index @0,0]
2965 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2966 if {[$ctext compare $difffilestart($i) > $here]} {
2967 if {![info exists pos]
2968 || [$ctext compare $difffilestart($i) < $pos]} {
2969 set pos $difffilestart($i)
2973 if {[info exists pos]} {
2978 proc listboxsel {} {
2979 global ctext cflist currentid
2980 if {![info exists currentid]} return
2981 set sel [lsort [$cflist curselection]]
2982 if {$sel eq {}} return
2983 set first [lindex $sel 0]
2984 catch {$ctext yview fmark.$first}
2988 global linespc charspc canvx0 canvy0 mainfont
2989 global xspc1 xspc2 lthickness
2991 set linespc [font metrics $mainfont -linespace]
2992 set charspc [font measure $mainfont "m"]
2993 set canvy0 [expr {3 + 0.5 * $linespc}]
2994 set canvx0 [expr {3 + 0.5 * $linespc}]
2995 set lthickness [expr {int($linespc / 9) + 1}]
2996 set xspc1(0) $linespc
3001 global stopped redisplaying phase
3002 if {$stopped > 1} return
3003 if {$phase == "getcommits"} return
3005 if {$phase == "drawgraph" || $phase == "incrdraw"} {
3012 proc incrfont {inc} {
3013 global mainfont namefont textfont ctext canv phase
3014 global stopped entries
3016 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
3017 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
3018 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
3020 $ctext conf -font $textfont
3021 $ctext tag conf filesep -font [concat $textfont bold]
3022 foreach e $entries {
3023 $e conf -font $mainfont
3025 if {$phase == "getcommits"} {
3026 $canv itemconf textitems -font $mainfont
3032 global sha1entry sha1string
3033 if {[string length $sha1string] == 40} {
3034 $sha1entry delete 0 end
3038 proc sha1change {n1 n2 op} {
3039 global sha1string currentid sha1but
3040 if {$sha1string == {}
3041 || ([info exists currentid] && $sha1string == $currentid)} {
3046 if {[$sha1but cget -state] == $state} return
3047 if {$state == "normal"} {
3048 $sha1but conf -state normal -relief raised -text "Goto: "
3050 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3054 proc gotocommit {} {
3055 global sha1string currentid idline tagids
3056 global lineid numcommits
3058 if {$sha1string == {}
3059 || ([info exists currentid] && $sha1string == $currentid)} return
3060 if {[info exists tagids($sha1string)]} {
3061 set id $tagids($sha1string)
3063 set id [string tolower $sha1string]
3064 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3066 for {set l 0} {$l < $numcommits} {incr l} {
3067 if {[string match $id* $lineid($l)]} {
3068 lappend matches $lineid($l)
3071 if {$matches ne {}} {
3072 if {[llength $matches] > 1} {
3073 error_popup "Short SHA1 id $id is ambiguous"
3076 set id [lindex $matches 0]
3080 if {[info exists idline($id)]} {
3081 selectline $idline($id) 1
3084 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3089 error_popup "$type $sha1string is not known"
3092 proc lineenter {x y id} {
3093 global hoverx hovery hoverid hovertimer
3094 global commitinfo canv
3096 if {![info exists commitinfo($id)]} return
3100 if {[info exists hovertimer]} {
3101 after cancel $hovertimer
3103 set hovertimer [after 500 linehover]
3107 proc linemotion {x y id} {
3108 global hoverx hovery hoverid hovertimer
3110 if {[info exists hoverid] && $id == $hoverid} {
3113 if {[info exists hovertimer]} {
3114 after cancel $hovertimer
3116 set hovertimer [after 500 linehover]
3120 proc lineleave {id} {
3121 global hoverid hovertimer canv
3123 if {[info exists hoverid] && $id == $hoverid} {
3125 if {[info exists hovertimer]} {
3126 after cancel $hovertimer
3134 global hoverx hovery hoverid hovertimer
3135 global canv linespc lthickness
3136 global commitinfo mainfont
3138 set text [lindex $commitinfo($hoverid) 0]
3139 set ymax [lindex [$canv cget -scrollregion] 3]
3140 if {$ymax == {}} return
3141 set yfrac [lindex [$canv yview] 0]
3142 set x [expr {$hoverx + 2 * $linespc}]
3143 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3144 set x0 [expr {$x - 2 * $lthickness}]
3145 set y0 [expr {$y - 2 * $lthickness}]
3146 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3147 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3148 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3149 -fill \#ffff80 -outline black -width 1 -tags hover]
3151 set t [$canv create text $x $y -anchor nw -text $text -tags hover -font $mainfont]
3155 proc clickisonarrow {id y} {
3156 global mainline mainlinearrow sidelines lthickness
3158 set thresh [expr {2 * $lthickness + 6}]
3159 if {[info exists mainline($id)]} {
3160 if {$mainlinearrow($id) ne "none"} {
3161 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3166 if {[info exists sidelines($id)]} {
3167 foreach ls $sidelines($id) {
3168 set coords [lindex $ls 0]
3169 set arrow [lindex $ls 2]
3170 if {$arrow eq "first" || $arrow eq "both"} {
3171 if {abs([lindex $coords 1] - $y) < $thresh} {
3175 if {$arrow eq "last" || $arrow eq "both"} {
3176 if {abs([lindex $coords end] - $y) < $thresh} {
3185 proc arrowjump {id dirn y} {
3186 global mainline sidelines canv canv2 canv3
3189 if {$dirn eq "down"} {
3190 if {[info exists mainline($id)]} {
3191 set y1 [lindex $mainline($id) 1]
3196 if {[info exists sidelines($id)]} {
3197 foreach ls $sidelines($id) {
3198 set y1 [lindex $ls 0 1]
3199 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3205 if {[info exists sidelines($id)]} {
3206 foreach ls $sidelines($id) {
3207 set y1 [lindex $ls 0 end]
3208 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3214 if {$yt eq {}} return
3215 set ymax [lindex [$canv cget -scrollregion] 3]
3216 if {$ymax eq {} || $ymax <= 0} return
3217 set view [$canv yview]
3218 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3219 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3223 $canv yview moveto $yfrac
3224 $canv2 yview moveto $yfrac
3225 $canv3 yview moveto $yfrac
3228 proc lineclick {x y id isnew} {
3229 global ctext commitinfo children cflist canv thickerline
3235 # draw this line thicker than normal
3239 set ymax [lindex [$canv cget -scrollregion] 3]
3240 if {$ymax eq {}} return
3241 set yfrac [lindex [$canv yview] 0]
3242 set y [expr {$y + $yfrac * $ymax}]
3244 set dirn [clickisonarrow $id $y]
3246 arrowjump $id $dirn $y
3251 addtohistory [list lineclick $x $y $id 0]
3253 # fill the details pane with info about this line
3254 $ctext conf -state normal
3255 $ctext delete 0.0 end
3256 $ctext tag conf link -foreground blue -underline 1
3257 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3258 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3259 $ctext insert end "Parent:\t"
3260 $ctext insert end $id [list link link0]
3261 $ctext tag bind link0 <1> [list selbyid $id]
3262 set info $commitinfo($id)
3263 $ctext insert end "\n\t[lindex $info 0]\n"
3264 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3265 set date [formatdate [lindex $info 2]]
3266 $ctext insert end "\tDate:\t$date\n"
3267 if {[info exists children($id)]} {
3268 $ctext insert end "\nChildren:"
3270 foreach child $children($id) {
3272 set info $commitinfo($child)
3273 $ctext insert end "\n\t"
3274 $ctext insert end $child [list link link$i]
3275 $ctext tag bind link$i <1> [list selbyid $child]
3276 $ctext insert end "\n\t[lindex $info 0]"
3277 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3278 set date [formatdate [lindex $info 2]]
3279 $ctext insert end "\n\tDate:\t$date\n"
3282 $ctext conf -state disabled
3284 $cflist delete 0 end
3287 proc normalline {} {
3289 if {[info exists thickerline]} {
3290 drawlines $thickerline 0 1
3297 if {[info exists idline($id)]} {
3298 selectline $idline($id) 1
3304 if {![info exists startmstime]} {
3305 set startmstime [clock clicks -milliseconds]
3307 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3310 proc rowmenu {x y id} {
3311 global rowctxmenu idline selectedline rowmenuid
3313 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3318 $rowctxmenu entryconfigure 0 -state $state
3319 $rowctxmenu entryconfigure 1 -state $state
3320 $rowctxmenu entryconfigure 2 -state $state
3322 tk_popup $rowctxmenu $x $y
3325 proc diffvssel {dirn} {
3326 global rowmenuid selectedline lineid
3328 if {![info exists selectedline]} return
3330 set oldid $lineid($selectedline)
3331 set newid $rowmenuid
3333 set oldid $rowmenuid
3334 set newid $lineid($selectedline)
3336 addtohistory [list doseldiff $oldid $newid]
3337 doseldiff $oldid $newid
3340 proc doseldiff {oldid newid} {
3344 $ctext conf -state normal
3345 $ctext delete 0.0 end
3346 $ctext mark set fmark.0 0.0
3347 $ctext mark gravity fmark.0 left
3348 $cflist delete 0 end
3349 $cflist insert end "Top"
3350 $ctext insert end "From "
3351 $ctext tag conf link -foreground blue -underline 1
3352 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3353 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3354 $ctext tag bind link0 <1> [list selbyid $oldid]
3355 $ctext insert end $oldid [list link link0]
3356 $ctext insert end "\n "
3357 $ctext insert end [lindex $commitinfo($oldid) 0]
3358 $ctext insert end "\n\nTo "
3359 $ctext tag bind link1 <1> [list selbyid $newid]
3360 $ctext insert end $newid [list link link1]
3361 $ctext insert end "\n "
3362 $ctext insert end [lindex $commitinfo($newid) 0]
3363 $ctext insert end "\n"
3364 $ctext conf -state disabled
3365 $ctext tag delete Comments
3366 $ctext tag remove found 1.0 end
3367 startdiff [list $oldid $newid]
3371 global rowmenuid currentid commitinfo patchtop patchnum
3373 if {![info exists currentid]} return
3374 set oldid $currentid
3375 set oldhead [lindex $commitinfo($oldid) 0]
3376 set newid $rowmenuid
3377 set newhead [lindex $commitinfo($newid) 0]
3380 catch {destroy $top}
3382 label $top.title -text "Generate patch"
3383 grid $top.title - -pady 10
3384 label $top.from -text "From:"
3385 entry $top.fromsha1 -width 40 -relief flat
3386 $top.fromsha1 insert 0 $oldid
3387 $top.fromsha1 conf -state readonly
3388 grid $top.from $top.fromsha1 -sticky w
3389 entry $top.fromhead -width 60 -relief flat
3390 $top.fromhead insert 0 $oldhead
3391 $top.fromhead conf -state readonly
3392 grid x $top.fromhead -sticky w
3393 label $top.to -text "To:"
3394 entry $top.tosha1 -width 40 -relief flat
3395 $top.tosha1 insert 0 $newid
3396 $top.tosha1 conf -state readonly
3397 grid $top.to $top.tosha1 -sticky w
3398 entry $top.tohead -width 60 -relief flat
3399 $top.tohead insert 0 $newhead
3400 $top.tohead conf -state readonly
3401 grid x $top.tohead -sticky w
3402 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3403 grid $top.rev x -pady 10
3404 label $top.flab -text "Output file:"
3405 entry $top.fname -width 60
3406 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3408 grid $top.flab $top.fname -sticky w
3410 button $top.buts.gen -text "Generate" -command mkpatchgo
3411 button $top.buts.can -text "Cancel" -command mkpatchcan
3412 grid $top.buts.gen $top.buts.can
3413 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3414 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3415 grid $top.buts - -pady 10 -sticky ew
3419 proc mkpatchrev {} {
3422 set oldid [$patchtop.fromsha1 get]
3423 set oldhead [$patchtop.fromhead get]
3424 set newid [$patchtop.tosha1 get]
3425 set newhead [$patchtop.tohead get]
3426 foreach e [list fromsha1 fromhead tosha1 tohead] \
3427 v [list $newid $newhead $oldid $oldhead] {
3428 $patchtop.$e conf -state normal
3429 $patchtop.$e delete 0 end
3430 $patchtop.$e insert 0 $v
3431 $patchtop.$e conf -state readonly
3438 set oldid [$patchtop.fromsha1 get]
3439 set newid [$patchtop.tosha1 get]
3440 set fname [$patchtop.fname get]
3441 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3442 error_popup "Error creating patch: $err"
3444 catch {destroy $patchtop}
3448 proc mkpatchcan {} {
3451 catch {destroy $patchtop}
3456 global rowmenuid mktagtop commitinfo
3460 catch {destroy $top}
3462 label $top.title -text "Create tag"
3463 grid $top.title - -pady 10
3464 label $top.id -text "ID:"
3465 entry $top.sha1 -width 40 -relief flat
3466 $top.sha1 insert 0 $rowmenuid
3467 $top.sha1 conf -state readonly
3468 grid $top.id $top.sha1 -sticky w
3469 entry $top.head -width 60 -relief flat
3470 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3471 $top.head conf -state readonly
3472 grid x $top.head -sticky w
3473 label $top.tlab -text "Tag name:"
3474 entry $top.tag -width 60
3475 grid $top.tlab $top.tag -sticky w
3477 button $top.buts.gen -text "Create" -command mktaggo
3478 button $top.buts.can -text "Cancel" -command mktagcan
3479 grid $top.buts.gen $top.buts.can
3480 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3481 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3482 grid $top.buts - -pady 10 -sticky ew
3487 global mktagtop env tagids idtags
3489 set id [$mktagtop.sha1 get]
3490 set tag [$mktagtop.tag get]
3492 error_popup "No tag name specified"
3495 if {[info exists tagids($tag)]} {
3496 error_popup "Tag \"$tag\" already exists"
3501 set fname [file join $dir "refs/tags" $tag]
3502 set f [open $fname w]
3506 error_popup "Error creating tag: $err"
3510 set tagids($tag) $id
3511 lappend idtags($id) $tag
3515 proc redrawtags {id} {
3516 global canv linehtag idline idpos selectedline
3518 if {![info exists idline($id)]} return
3519 $canv delete tag.$id
3520 set xt [eval drawtags $id $idpos($id)]
3521 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3522 if {[info exists selectedline] && $selectedline == $idline($id)} {
3523 selectline $selectedline 0
3530 catch {destroy $mktagtop}
3539 proc writecommit {} {
3540 global rowmenuid wrcomtop commitinfo wrcomcmd
3542 set top .writecommit
3544 catch {destroy $top}
3546 label $top.title -text "Write commit to file"
3547 grid $top.title - -pady 10
3548 label $top.id -text "ID:"
3549 entry $top.sha1 -width 40 -relief flat
3550 $top.sha1 insert 0 $rowmenuid
3551 $top.sha1 conf -state readonly
3552 grid $top.id $top.sha1 -sticky w
3553 entry $top.head -width 60 -relief flat
3554 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3555 $top.head conf -state readonly
3556 grid x $top.head -sticky w
3557 label $top.clab -text "Command:"
3558 entry $top.cmd -width 60 -textvariable wrcomcmd
3559 grid $top.clab $top.cmd -sticky w -pady 10
3560 label $top.flab -text "Output file:"
3561 entry $top.fname -width 60
3562 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3563 grid $top.flab $top.fname -sticky w
3565 button $top.buts.gen -text "Write" -command wrcomgo
3566 button $top.buts.can -text "Cancel" -command wrcomcan
3567 grid $top.buts.gen $top.buts.can
3568 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3569 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3570 grid $top.buts - -pady 10 -sticky ew
3577 set id [$wrcomtop.sha1 get]
3578 set cmd "echo $id | [$wrcomtop.cmd get]"
3579 set fname [$wrcomtop.fname get]
3580 if {[catch {exec sh -c $cmd >$fname &} err]} {
3581 error_popup "Error writing commit: $err"
3583 catch {destroy $wrcomtop}
3590 catch {destroy $wrcomtop}
3594 proc listrefs {id} {
3595 global idtags idheads idotherrefs
3598 if {[info exists idtags($id)]} {
3602 if {[info exists idheads($id)]} {
3606 if {[info exists idotherrefs($id)]} {
3607 set z $idotherrefs($id)
3609 return [list $x $y $z]
3612 proc rereadrefs {} {
3613 global idtags idheads idotherrefs
3614 global tagids headids otherrefids
3616 set refids [concat [array names idtags] \
3617 [array names idheads] [array names idotherrefs]]
3618 foreach id $refids {
3619 if {![info exists ref($id)]} {
3620 set ref($id) [listrefs $id]
3624 set refids [lsort -unique [concat $refids [array names idtags] \
3625 [array names idheads] [array names idotherrefs]]]
3626 foreach id $refids {
3627 set v [listrefs $id]
3628 if {![info exists ref($id)] || $ref($id) != $v} {
3634 proc updatecommits {rargs} {
3635 global commitlisted commfd phase
3636 global startmsecs nextupdate ncmupdate
3637 global idtags idheads idotherrefs
3641 global oldcommits commits
3642 global parents nchildren children ncleft
3644 set old_args $parsed_args
3647 foreach id $old_args {
3648 if {![regexp {^[0-9a-f]{40}$} $id]} continue
3649 if {[info exists oldref($id)]} continue
3651 lappend ignoreold "^$id"
3653 foreach id $parsed_args {
3654 if {![regexp {^[0-9a-f]{40}$} $id]} continue
3655 if {[info exists ref($id)]} continue
3657 lappend ignorenew "^$id"
3660 foreach a $old_args {
3661 if {![info exists ref($a)]} {
3662 lappend ignorenew $a
3666 set phase updatecommits
3667 set removed_commits [split [eval exec git-rev-list $ignorenew] "\n" ]
3668 if {[llength $removed_commits] > 0} {
3671 foreach c $commits {
3672 if {[lsearch $c $removed_commits] < 0} {
3673 lappend oldcommits $c
3675 unset commitlisted($c)
3681 set phase removecommits
3685 foreach a $parsed_args {
3686 if {![info exists oldref($a)]} {
3692 start_rev_list [concat $ignoreold $args]
3695 proc showtag {tag isnew} {
3696 global ctext cflist tagcontents tagids linknum
3699 addtohistory [list showtag $tag 0]
3701 $ctext conf -state normal
3702 $ctext delete 0.0 end
3704 if {[info exists tagcontents($tag)]} {
3705 set text $tagcontents($tag)
3707 set text "Tag: $tag\nId: $tagids($tag)"
3709 appendwithlinks $text
3710 $ctext conf -state disabled
3711 $cflist delete 0 end
3721 global maxwidth maxgraphpct diffopts findmergefiles
3722 global oldprefs prefstop
3726 if {[winfo exists $top]} {
3730 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3731 set oldprefs($v) [set $v]
3734 wm title $top "Gitk preferences"
3735 label $top.ldisp -text "Commit list display options"
3736 grid $top.ldisp - -sticky w -pady 10
3737 label $top.spacer -text " "
3738 label $top.maxwidthl -text "Maximum graph width (lines)" \
3740 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
3741 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
3742 label $top.maxpctl -text "Maximum graph width (% of pane)" \
3744 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
3745 grid x $top.maxpctl $top.maxpct -sticky w
3746 checkbutton $top.findm -variable findmergefiles
3747 label $top.findml -text "Include merges for \"Find\" in \"Files\"" \
3749 grid $top.findm $top.findml - -sticky w
3750 label $top.ddisp -text "Diff display options"
3751 grid $top.ddisp - -sticky w -pady 10
3752 label $top.diffoptl -text "Options for diff program" \
3754 entry $top.diffopt -width 20 -textvariable diffopts
3755 grid x $top.diffoptl $top.diffopt -sticky w
3757 button $top.buts.ok -text "OK" -command prefsok
3758 button $top.buts.can -text "Cancel" -command prefscan
3759 grid $top.buts.ok $top.buts.can
3760 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3761 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3762 grid $top.buts - - -pady 10 -sticky ew
3766 global maxwidth maxgraphpct diffopts findmergefiles
3767 global oldprefs prefstop
3769 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3770 set $v $oldprefs($v)
3772 catch {destroy $prefstop}
3777 global maxwidth maxgraphpct
3778 global oldprefs prefstop
3780 catch {destroy $prefstop}
3782 if {$maxwidth != $oldprefs(maxwidth)
3783 || $maxgraphpct != $oldprefs(maxgraphpct)} {
3788 proc formatdate {d} {
3789 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
3794 set diffopts "-U 5 -p"
3795 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3799 set gitencoding [exec git-repo-config --get i18n.commitencoding]
3801 if {$gitencoding == ""} {
3802 set gitencoding "utf-8"
3805 set mainfont {Helvetica 9}
3806 set textfont {Courier 9}
3807 set findmergefiles 0
3813 set colors {green red blue magenta darkgrey brown orange}
3815 catch {source ~/.gitk}
3817 set namefont $mainfont
3819 font create optionfont -family sans-serif -size -12
3823 switch -regexp -- $arg {
3825 "^-d" { set datemode 1 }
3826 "^-r" { set revlistorder 1 }
3828 lappend revtreeargs $arg
3841 makewindow $revtreeargs
3843 getcommits $revtreeargs