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
]
137 set commitlisted
($id) 1
138 parsecommit
$id $cmit 1 [lrange
$ids 1 end
]
140 if {[clock clicks
-milliseconds] >= $nextupdate} {
143 while {$redisplaying} {
147 set phase
"getcommits"
148 foreach id
$commits {
151 if {[clock clicks
-milliseconds] >= $nextupdate} {
160 proc doupdate
{reading
} {
161 global commfd nextupdate numcommits ncmupdate
164 fileevent
$commfd readable
{}
167 set nextupdate
[expr {[clock clicks
-milliseconds] + 100}]
168 if {$numcommits < 100} {
169 set ncmupdate
[expr {$numcommits + 1}]
170 } elseif
{$numcommits < 10000} {
171 set ncmupdate
[expr {$numcommits + 10}]
173 set ncmupdate
[expr {$numcommits + 100}]
176 fileevent
$commfd readable
[list getcommitlines
$commfd]
180 proc readcommit
{id
} {
181 if [catch
{set contents
[exec git-cat-file commit
$id]}] return
182 parsecommit
$id $contents 0 {}
185 proc updatechildren
{id olds
} {
186 global children nchildren parents nparents ncleft
188 if {![info exists nchildren
($id)]} {
193 set parents
($id) $olds
194 set nparents
($id) [llength
$olds]
196 if {![info exists nchildren
($p)]} {
197 set children
($p) [list
$id]
200 } elseif
{[lsearch
-exact $children($p) $id] < 0} {
201 lappend children
($p) $id
208 proc parsecommit
{id contents listed olds
} {
209 global commitinfo cdate
218 updatechildren
$id $olds
219 set hdrend
[string first
"\n\n" $contents]
221 # should never happen...
222 set hdrend
[string length
$contents]
224 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
225 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
226 foreach line
[split $header "\n"] {
227 set tag
[lindex
$line 0]
228 if {$tag == "author"} {
229 set audate
[lindex
$line end-1
]
230 set auname
[lrange
$line 1 end-2
]
231 } elseif
{$tag == "committer"} {
232 set comdate
[lindex
$line end-1
]
233 set comname
[lrange
$line 1 end-2
]
237 # take the first line of the comment as the headline
238 set i
[string first
"\n" $comment]
240 set headline
[string trim
[string range
$comment 0 $i]]
242 set headline
$comment
245 # git-rev-list indents the comment by 4 spaces;
246 # if we got this via git-cat-file, add the indentation
248 foreach line
[split $comment "\n"] {
249 append newcomment
" "
250 append newcomment
$line
251 append newcomment
"\n"
253 set comment
$newcomment
255 if {$comdate != {}} {
256 set cdate
($id) $comdate
258 set commitinfo
($id) [list
$headline $auname $audate \
259 $comname $comdate $comment]
263 global tagids idtags headids idheads tagcontents
264 global otherrefids idotherrefs
266 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
269 set refd
[open
[list | git-ls-remote
[gitdir
]] r
]
270 while {0 <= [set n
[gets
$refd line
]]} {
271 if {![regexp
{^
([0-9a-f]{40}) refs
/([^^
]*)$
} $line \
275 if {![regexp
{^
(tags|heads
)/(.
*)$
} $path match
type name
]} {
279 if {$type == "tags"} {
280 set tagids
($name) $id
281 lappend idtags
($id) $name
286 set commit
[exec git-rev-parse
"$id^0"]
287 if {"$commit" != "$id"} {
288 set tagids
($name) $commit
289 lappend idtags
($commit) $name
293 set tagcontents
($name) [exec git-cat-file tag
"$id"]
295 } elseif
{ $type == "heads" } {
296 set headids
($name) $id
297 lappend idheads
($id) $name
299 set otherrefids
($name) $id
300 lappend idotherrefs
($id) $name
306 proc error_popup msg
{
310 message
$w.m
-text $msg -justify center
-aspect 400
311 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
312 button
$w.ok
-text OK
-command "destroy $w"
313 pack
$w.ok
-side bottom
-fill x
314 bind $w <Visibility
> "grab $w; focus $w"
318 proc makewindow
{rargs
} {
319 global canv canv2 canv3 linespc charspc ctext cflist textfont
320 global findtype findtypemenu findloc findstring fstring geometry
321 global entries sha1entry sha1string sha1but
322 global maincursor textcursor curtextcursor
323 global rowctxmenu mergemax
326 .bar add cascade
-label "File" -menu .bar.
file
328 .bar.
file add
command -label "Update" -command [list updatecommits
$rargs]
329 .bar.
file add
command -label "Reread references" -command rereadrefs
330 .bar.
file add
command -label "Quit" -command doquit
332 .bar add cascade
-label "Edit" -menu .bar.edit
333 .bar.edit add
command -label "Preferences" -command doprefs
335 .bar add cascade
-label "Help" -menu .bar.
help
336 .bar.
help add
command -label "About gitk" -command about
337 . configure
-menu .bar
339 if {![info exists geometry
(canv1
)]} {
340 set geometry
(canv1
) [expr {45 * $charspc}]
341 set geometry
(canv2
) [expr {30 * $charspc}]
342 set geometry
(canv3
) [expr {15 * $charspc}]
343 set geometry
(canvh
) [expr {25 * $linespc + 4}]
344 set geometry
(ctextw
) 80
345 set geometry
(ctexth
) 30
346 set geometry
(cflistw
) 30
348 panedwindow .ctop
-orient vertical
349 if {[info exists geometry
(width
)]} {
350 .ctop conf
-width $geometry(width
) -height $geometry(height
)
351 set texth
[expr {$geometry(height
) - $geometry(canvh
) - 56}]
352 set geometry
(ctexth
) [expr {($texth - 8) /
353 [font metrics
$textfont -linespace]}]
357 pack .ctop.top.bar
-side bottom
-fill x
358 set cscroll .ctop.top.csb
359 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
360 pack
$cscroll -side right
-fill y
361 panedwindow .ctop.top.clist
-orient horizontal
-sashpad 0 -handlesize 4
362 pack .ctop.top.clist
-side top
-fill both
-expand 1
364 set canv .ctop.top.clist.canv
365 canvas
$canv -height $geometry(canvh
) -width $geometry(canv1
) \
367 -yscrollincr $linespc -yscrollcommand "$cscroll set"
368 .ctop.top.clist add
$canv
369 set canv2 .ctop.top.clist.canv2
370 canvas
$canv2 -height $geometry(canvh
) -width $geometry(canv2
) \
371 -bg white
-bd 0 -yscrollincr $linespc
372 .ctop.top.clist add
$canv2
373 set canv3 .ctop.top.clist.canv3
374 canvas
$canv3 -height $geometry(canvh
) -width $geometry(canv3
) \
375 -bg white
-bd 0 -yscrollincr $linespc
376 .ctop.top.clist add
$canv3
377 bind .ctop.top.clist
<Configure
> {resizeclistpanes
%W
%w
}
379 set sha1entry .ctop.top.bar.sha1
380 set entries
$sha1entry
381 set sha1but .ctop.top.bar.sha1label
382 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
383 -command gotocommit
-width 8
384 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
385 pack .ctop.top.bar.sha1label
-side left
386 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
387 trace add variable sha1string
write sha1change
388 pack
$sha1entry -side left
-pady 2
390 image create bitmap bm-left
-data {
391 #define left_width 16
392 #define left_height 16
393 static unsigned char left_bits
[] = {
394 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
395 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
396 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
398 image create bitmap bm-right
-data {
399 #define right_width 16
400 #define right_height 16
401 static unsigned char right_bits
[] = {
402 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
403 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
404 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
406 button .ctop.top.bar.leftbut
-image bm-left
-command goback \
407 -state disabled
-width 26
408 pack .ctop.top.bar.leftbut
-side left
-fill y
409 button .ctop.top.bar.rightbut
-image bm-right
-command goforw \
410 -state disabled
-width 26
411 pack .ctop.top.bar.rightbut
-side left
-fill y
413 button .ctop.top.bar.findbut
-text "Find" -command dofind
414 pack .ctop.top.bar.findbut
-side left
416 set fstring .ctop.top.bar.findstring
417 lappend entries
$fstring
418 entry
$fstring -width 30 -font $textfont -textvariable findstring
419 pack
$fstring -side left
-expand 1 -fill x
421 set findtypemenu
[tk_optionMenu .ctop.top.bar.findtype \
422 findtype Exact IgnCase Regexp
]
423 set findloc
"All fields"
424 tk_optionMenu .ctop.top.bar.findloc findloc
"All fields" Headline \
425 Comments Author Committer Files Pickaxe
426 pack .ctop.top.bar.findloc
-side right
427 pack .ctop.top.bar.findtype
-side right
428 # for making sure type==Exact whenever loc==Pickaxe
429 trace add variable findloc
write findlocchange
431 panedwindow .ctop.cdet
-orient horizontal
433 frame .ctop.cdet.left
434 set ctext .ctop.cdet.left.ctext
435 text
$ctext -bg white
-state disabled
-font $textfont \
436 -width $geometry(ctextw
) -height $geometry(ctexth
) \
437 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
438 scrollbar .ctop.cdet.left.sb
-command "$ctext yview"
439 pack .ctop.cdet.left.sb
-side right
-fill y
440 pack
$ctext -side left
-fill both
-expand 1
441 .ctop.cdet add .ctop.cdet.left
443 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
444 $ctext tag conf hunksep
-fore blue
445 $ctext tag conf d0
-fore red
446 $ctext tag conf d1
-fore "#00a000"
447 $ctext tag conf m0
-fore red
448 $ctext tag conf m1
-fore blue
449 $ctext tag conf m2
-fore green
450 $ctext tag conf m3
-fore purple
451 $ctext tag conf
m4 -fore brown
452 $ctext tag conf mmax
-fore darkgrey
454 $ctext tag conf mresult
-font [concat
$textfont bold
]
455 $ctext tag conf msep
-font [concat
$textfont bold
]
456 $ctext tag conf found
-back yellow
458 frame .ctop.cdet.right
459 set cflist .ctop.cdet.right.cfiles
460 listbox
$cflist -bg white
-selectmode extended
-width $geometry(cflistw
) \
461 -yscrollcommand ".ctop.cdet.right.sb set"
462 scrollbar .ctop.cdet.right.sb
-command "$cflist yview"
463 pack .ctop.cdet.right.sb
-side right
-fill y
464 pack
$cflist -side left
-fill both
-expand 1
465 .ctop.cdet add .ctop.cdet.right
466 bind .ctop.cdet
<Configure
> {resizecdetpanes
%W
%w
}
468 pack .ctop
-side top
-fill both
-expand 1
470 bindall
<1> {selcanvline
%W
%x
%y
}
471 #bindall <B1-Motion> {selcanvline %W %x %y}
472 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
473 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
474 bindall
<2> "allcanvs scan mark 0 %y"
475 bindall
<B2-Motion
> "allcanvs scan dragto 0 %y"
476 bind .
<Key-Up
> "selnextline -1"
477 bind .
<Key-Down
> "selnextline 1"
478 bind .
<Key-Right
> "goforw"
479 bind .
<Key-Left
> "goback"
480 bind .
<Key-Prior
> "allcanvs yview scroll -1 pages"
481 bind .
<Key-Next
> "allcanvs yview scroll 1 pages"
482 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
483 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
484 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
485 bindkey p
"selnextline -1"
486 bindkey n
"selnextline 1"
489 bindkey i
"selnextline -1"
490 bindkey k
"selnextline 1"
493 bindkey b
"$ctext yview scroll -1 pages"
494 bindkey d
"$ctext yview scroll 18 units"
495 bindkey u
"$ctext yview scroll -18 units"
496 bindkey
/ {findnext
1}
497 bindkey
<Key-Return
> {findnext
0}
500 bind .
<Control-q
> doquit
501 bind .
<Control-f
> dofind
502 bind .
<Control-g
> {findnext
0}
503 bind .
<Control-r
> findprev
504 bind .
<Control-equal
> {incrfont
1}
505 bind .
<Control-KP_Add
> {incrfont
1}
506 bind .
<Control-minus
> {incrfont
-1}
507 bind .
<Control-KP_Subtract
> {incrfont
-1}
508 bind $cflist <<ListboxSelect>> listboxsel
509 bind . <Destroy> {savestuff %W}
510 bind . <Button-1> "click %W"
511 bind $fstring <Key-Return> dofind
512 bind $sha1entry <Key-Return> gotocommit
513 bind $sha1entry <<PasteSelection>> clearsha1
515 set maincursor [. cget -cursor]
516 set textcursor [$ctext cget -cursor]
517 set curtextcursor $textcursor
519 set rowctxmenu .rowctxmenu
520 menu $rowctxmenu -tearoff 0
521 $rowctxmenu add command -label "Diff this -> selected" \
522 -command {diffvssel 0}
523 $rowctxmenu add command -label "Diff selected -> this" \
524 -command {diffvssel 1}
525 $rowctxmenu add command -label "Make patch" -command mkpatch
526 $rowctxmenu add command -label "Create tag" -command mktag
527 $rowctxmenu add command -label "Write commit to file" -command writecommit
530 # when we make a key binding for the toplevel, make sure
531 # it doesn't get triggered when that key is pressed in the
532 # find string entry widget.
533 proc bindkey {ev script} {
536 set escript [bind Entry $ev]
537 if {$escript == {}} {
538 set escript [bind Entry <Key>]
541 bind $e $ev "$escript; break"
545 # set the focus back to the toplevel for any click outside
556 global canv canv2 canv3 ctext cflist mainfont textfont
557 global stuffsaved findmergefiles maxgraphpct
560 if {$stuffsaved} return
561 if {![winfo viewable .]} return
563 set f [open "~/.gitk-new" w]
564 puts $f [list set mainfont $mainfont]
565 puts $f [list set textfont $textfont]
566 puts $f [list set findmergefiles $findmergefiles]
567 puts $f [list set maxgraphpct $maxgraphpct]
568 puts $f [list set maxwidth $maxwidth]
569 puts $f "set geometry(width) [winfo width .ctop]"
570 puts $f "set geometry(height) [winfo height .ctop]"
571 puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]"
572 puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]"
573 puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]"
574 puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]"
575 set wid [expr {([winfo width $ctext] - 8) \
576 / [font measure $textfont "0"]}]
577 puts $f "set geometry(ctextw) $wid"
578 set wid [expr {([winfo width $cflist] - 11) \
579 / [font measure [$cflist cget -font] "0"]}]
580 puts $f "set geometry(cflistw) $wid"
582 file rename -force "~/.gitk-new" "~/.gitk"
587 proc resizeclistpanes {win w} {
589 if [info exists oldwidth($win)] {
590 set s0 [$win sash coord 0]
591 set s1 [$win sash coord 1]
593 set sash0 [expr {int($w/2 - 2)}]
594 set sash1 [expr {int($w*5/6 - 2)}]
596 set factor [expr {1.0 * $w / $oldwidth($win)}]
597 set sash0 [expr {int($factor * [lindex $s0 0])}]
598 set sash1 [expr {int($factor * [lindex $s1 0])}]
602 if {$sash1 < $sash0 + 20} {
603 set sash1 [expr {$sash0 + 20}]
605 if {$sash1 > $w - 10} {
606 set sash1 [expr {$w - 10}]
607 if {$sash0 > $sash1 - 20} {
608 set sash0 [expr {$sash1 - 20}]
612 $win sash place 0 $sash0 [lindex $s0 1]
613 $win sash place 1 $sash1 [lindex $s1 1]
615 set oldwidth($win) $w
618 proc resizecdetpanes {win w} {
620 if [info exists oldwidth($win)] {
621 set s0 [$win sash coord 0]
623 set sash0 [expr {int($w*3/4 - 2)}]
625 set factor [expr {1.0 * $w / $oldwidth($win)}]
626 set sash0 [expr {int($factor * [lindex $s0 0])}]
630 if {$sash0 > $w - 15} {
631 set sash0 [expr {$w - 15}]
634 $win sash place 0 $sash0 [lindex $s0 1]
636 set oldwidth($win) $w
640 global canv canv2 canv3
646 proc bindall {event action} {
647 global canv canv2 canv3
648 bind $canv $event $action
649 bind $canv2 $event $action
650 bind $canv3 $event $action
655 if {[winfo exists $w]} {
660 wm title $w "About gitk"
664 Copyright © 2005 Paul Mackerras
666 Use and redistribute under the terms of the GNU General Public License} \
667 -justify center -aspect 400
668 pack $w.m -side top -fill x -padx 20 -pady 20
669 button $w.ok -text Close -command "destroy $w"
670 pack $w.ok -side bottom
673 proc assigncolor {id} {
674 global colormap commcolors colors nextcolor
675 global parents nparents children nchildren
676 global cornercrossings crossings
678 if [info exists colormap($id)] return
679 set ncolors [llength $colors]
680 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
681 set child [lindex $children($id) 0]
682 if {[info exists colormap($child)]
683 && $nparents($child) == 1} {
684 set colormap($id) $colormap($child)
689 if {[info exists cornercrossings($id)]} {
690 foreach x $cornercrossings($id) {
691 if {[info exists colormap($x)]
692 && [lsearch -exact $badcolors $colormap($x)] < 0} {
693 lappend badcolors $colormap($x)
696 if {[llength $badcolors] >= $ncolors} {
700 set origbad $badcolors
701 if {[llength $badcolors] < $ncolors - 1} {
702 if {[info exists crossings($id)]} {
703 foreach x $crossings($id) {
704 if {[info exists colormap($x)]
705 && [lsearch -exact $badcolors $colormap($x)] < 0} {
706 lappend badcolors $colormap($x)
709 if {[llength $badcolors] >= $ncolors} {
710 set badcolors $origbad
713 set origbad $badcolors
715 if {[llength $badcolors] < $ncolors - 1} {
716 foreach child $children($id) {
717 if {[info exists colormap($child)]
718 && [lsearch -exact $badcolors $colormap($child)] < 0} {
719 lappend badcolors $colormap($child)
721 if {[info exists parents($child)]} {
722 foreach p $parents($child) {
723 if {[info exists colormap($p)]
724 && [lsearch -exact $badcolors $colormap($p)] < 0} {
725 lappend badcolors $colormap($p)
730 if {[llength $badcolors] >= $ncolors} {
731 set badcolors $origbad
734 for {set i 0} {$i <= $ncolors} {incr i} {
735 set c [lindex $colors $nextcolor]
736 if {[incr nextcolor] >= $ncolors} {
739 if {[lsearch -exact $badcolors $c]} break
745 global canvy canvy0 lineno numcommits nextcolor linespc
746 global nchildren ncleft
747 global displist nhyperspace
754 foreach v {mainline mainlinearrow sidelines colormap cornercrossings
755 crossings idline lineid} {
759 foreach id [array names nchildren] {
760 set ncleft($id) $nchildren($id)
766 proc bindline {t id} {
769 $canv bind $t <Enter> "lineenter %x %y $id"
770 $canv bind $t <Motion> "linemotion %x %y $id"
771 $canv bind $t <Leave> "lineleave $id"
772 $canv bind $t <Button-1> "lineclick %x %y $id 1"
775 proc drawlines {id xtra delold} {
776 global mainline mainlinearrow sidelines lthickness colormap canv
779 $canv delete lines.$id
781 if {[info exists mainline($id)]} {
782 set t [$canv create line $mainline($id) \
783 -width [expr {($xtra + 1) * $lthickness}] \
784 -fill $colormap($id) -tags lines.$id \
785 -arrow $mainlinearrow($id)]
789 if {[info exists sidelines($id)]} {
790 foreach ls $sidelines($id) {
791 set coords [lindex $ls 0]
792 set thick [lindex $ls 1]
793 set arrow [lindex $ls 2]
794 set t [$canv create line $coords -fill $colormap($id) \
795 -width [expr {($thick + $xtra) * $lthickness}] \
796 -arrow $arrow -tags lines.$id]
803 # level here is an index in displist
804 proc drawcommitline {level} {
805 global parents children nparents displist
806 global canv canv2 canv3 mainfont namefont canvy linespc
807 global lineid linehtag linentag linedtag commitinfo
808 global colormap numcommits currentparents dupparents
809 global idtags idline idheads idotherrefs
810 global lineno lthickness mainline mainlinearrow sidelines
811 global commitlisted rowtextx idpos lastuse displist
812 global oldnlines olddlevel olddisplist
816 set id [lindex $displist $level]
817 set lastuse($id) $lineno
818 set lineid($lineno) $id
819 set idline($id) $lineno
820 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
821 if {![info exists commitinfo($id)]} {
823 if {![info exists commitinfo($id)]} {
824 set commitinfo($id) {"No commit information available"}
829 set currentparents {}
831 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
832 foreach p $parents($id) {
833 if {[lsearch -exact $currentparents $p] < 0} {
834 lappend currentparents $p
836 # remember that this parent was listed twice
837 lappend dupparents $p
841 set x [xcoord $level $level $lineno]
843 set canvy [expr {$canvy + $linespc}]
844 allcanvs conf -scrollregion \
845 [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]]
846 if {[info exists mainline($id)]} {
847 lappend mainline($id) $x $y1
848 if {$mainlinearrow($id) ne "none"} {
849 set mainline($id) [trimdiagstart $mainline($id)]
853 set orad [expr {$linespc / 3}]
854 set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \
855 [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \
856 -fill $ofill -outline black -width 1]
858 $canv bind $t <1> {selcanvline {} %x %y}
859 set xt [xcoord [llength $displist] $level $lineno]
860 if {[llength $currentparents] > 2} {
861 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
863 set rowtextx($lineno) $xt
864 set idpos($id) [list $x $xt $y1]
865 if {[info exists idtags($id)] || [info exists idheads($id)]
866 || [info exists idotherrefs($id)]} {
867 set xt [drawtags $id $x $xt $y1]
869 set headline [lindex $commitinfo($id) 0]
870 set name [lindex $commitinfo($id) 1]
871 set date [lindex $commitinfo($id) 2]
872 set date [formatdate $date]
873 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
874 -text $headline -font $mainfont ]
875 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
876 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
877 -text $name -font $namefont]
878 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
879 -text $date -font $mainfont]
882 set olddisplist $displist
883 set oldnlines [llength $displist]
886 proc drawtags {id x xt y1} {
887 global idtags idheads idotherrefs
888 global linespc lthickness
889 global canv mainfont idline rowtextx
894 if {[info exists idtags($id)]} {
895 set marks $idtags($id)
896 set ntags [llength $marks]
898 if {[info exists idheads($id)]} {
899 set marks [concat $marks $idheads($id)]
900 set nheads [llength $idheads($id)]
902 if {[info exists idotherrefs($id)]} {
903 set marks [concat $marks $idotherrefs($id)]
909 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
910 set yt [expr {$y1 - 0.5 * $linespc}]
911 set yb [expr {$yt + $linespc - 1}]
915 set wid [font measure $mainfont $tag]
918 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
920 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
921 -width $lthickness -fill black -tags tag.$id]
923 foreach tag $marks x $xvals wid $wvals {
924 set xl [expr {$x + $delta}]
925 set xr [expr {$x + $delta + $wid + $lthickness}]
926 if {[incr ntags -1] >= 0} {
928 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
929 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
930 -width 1 -outline black -fill yellow -tags tag.$id]
931 $canv bind $t <1> [list showtag $tag 1]
932 set rowtextx($idline($id)) [expr {$xr + $linespc}]
934 # draw a head or other ref
935 if {[incr nheads -1] >= 0} {
940 set xl [expr {$xl - $delta/2}]
941 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
942 -width 1 -outline black -fill $col -tags tag.$id
944 set t [$canv create text $xl $y1 -anchor w -text $tag \
945 -font $mainfont -tags tag.$id]
947 $canv bind $t <1> [list showtag $tag 1]
953 proc notecrossings {id lo hi corner} {
954 global olddisplist crossings cornercrossings
956 for {set i $lo} {[incr i] < $hi} {} {
957 set p [lindex $olddisplist $i]
958 if {$p == {}} continue
960 if {![info exists cornercrossings($id)]
961 || [lsearch -exact $cornercrossings($id) $p] < 0} {
962 lappend cornercrossings($id) $p
964 if {![info exists cornercrossings($p)]
965 || [lsearch -exact $cornercrossings($p) $id] < 0} {
966 lappend cornercrossings($p) $id
969 if {![info exists crossings($id)]
970 || [lsearch -exact $crossings($id) $p] < 0} {
971 lappend crossings($id) $p
973 if {![info exists crossings($p)]
974 || [lsearch -exact $crossings($p) $id] < 0} {
975 lappend crossings($p) $id
981 proc xcoord {i level ln} {
982 global canvx0 xspc1 xspc2
984 set x [expr {$canvx0 + $i * $xspc1($ln)}]
985 if {$i > 0 && $i == $level} {
986 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
987 } elseif {$i > $level} {
988 set x [expr {$x + $xspc2 - $xspc1($ln)}]
993 # it seems Tk can't draw arrows on the end of diagonal line segments...
994 proc trimdiagend {line} {
995 while {[llength $line] > 4} {
996 set x1 [lindex $line end-3]
997 set y1 [lindex $line end-2]
998 set x2 [lindex $line end-1]
999 set y2 [lindex $line end]
1000 if {($x1 == $x2) != ($y1 == $y2)} break
1001 set line [lreplace $line end-1 end]
1006 proc trimdiagstart {line} {
1007 while {[llength $line] > 4} {
1008 set x1 [lindex $line 0]
1009 set y1 [lindex $line 1]
1010 set x2 [lindex $line 2]
1011 set y2 [lindex $line 3]
1012 if {($x1 == $x2) != ($y1 == $y2)} break
1013 set line [lreplace $line 0 1]
1018 proc drawslants {id needonscreen nohs} {
1019 global canv mainline mainlinearrow sidelines
1020 global canvx0 canvy xspc1 xspc2 lthickness
1021 global currentparents dupparents
1022 global lthickness linespc canvy colormap lineno geometry
1023 global maxgraphpct maxwidth
1024 global displist onscreen lastuse
1025 global parents commitlisted
1026 global oldnlines olddlevel olddisplist
1027 global nhyperspace numcommits nnewparents
1030 lappend displist $id
1035 set y1 [expr {$canvy - $linespc}]
1038 # work out what we need to get back on screen
1040 if {$onscreen($id) < 0} {
1041 # next to do isn't displayed, better get it on screen...
1042 lappend reins [list $id 0]
1044 # make sure all the previous commits's parents are on the screen
1045 foreach p $currentparents {
1046 if {$onscreen($p) < 0} {
1047 lappend reins [list $p 0]
1050 # bring back anything requested by caller
1051 if {$needonscreen ne {}} {
1052 lappend reins $needonscreen
1056 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1057 set dlevel $olddlevel
1058 set x [xcoord $dlevel $dlevel $lineno]
1059 set mainline($id) [list $x $y1]
1060 set mainlinearrow($id) none
1061 set lastuse($id) $lineno
1062 set displist [lreplace $displist $dlevel $dlevel $id]
1064 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1069 set displist [lreplace $displist $olddlevel $olddlevel]
1071 foreach p $currentparents {
1072 set lastuse($p) $lineno
1073 if {$onscreen($p) == 0} {
1074 set displist [linsert $displist $j $p]
1079 if {$onscreen($id) == 0} {
1080 lappend displist $id
1084 # remove the null entry if present
1085 set nullentry [lsearch -exact $displist {}]
1086 if {$nullentry >= 0} {
1087 set displist [lreplace $displist $nullentry $nullentry]
1090 # bring back the ones we need now (if we did it earlier
1091 # it would change displist and invalidate olddlevel)
1093 # test again in case of duplicates in reins
1094 set p [lindex $pi 0]
1095 if {$onscreen($p) < 0} {
1097 set lastuse($p) $lineno
1098 set displist [linsert $displist [lindex $pi 1] $p]
1103 set lastuse($id) $lineno
1105 # see if we need to make any lines jump off into hyperspace
1106 set displ [llength $displist]
1107 if {$displ > $maxwidth} {
1109 foreach x $displist {
1110 lappend ages [list $lastuse($x) $x]
1112 set ages [lsort -integer -index 0 $ages]
1114 while {$displ > $maxwidth} {
1115 set use [lindex $ages $k 0]
1116 set victim [lindex $ages $k 1]
1117 if {$use >= $lineno - 5} break
1119 if {[lsearch -exact $nohs $victim] >= 0} continue
1120 set i [lsearch -exact $displist $victim]
1121 set displist [lreplace $displist $i $i]
1122 set onscreen($victim) -1
1125 if {$i < $nullentry} {
1128 set x [lindex $mainline($victim) end-1]
1129 lappend mainline($victim) $x $y1
1130 set line [trimdiagend $mainline($victim)]
1132 if {$mainlinearrow($victim) ne "none"} {
1133 set line [trimdiagstart $line]
1136 lappend sidelines($victim) [list $line 1 $arrow]
1137 unset mainline($victim)
1141 set dlevel [lsearch -exact $displist $id]
1143 # If we are reducing, put in a null entry
1144 if {$displ < $oldnlines} {
1145 # does the next line look like a merge?
1146 # i.e. does it have > 1 new parent?
1147 if {$nnewparents($id) > 1} {
1148 set i [expr {$dlevel + 1}]
1149 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1151 if {$nullentry >= 0 && $nullentry < $i} {
1154 } elseif {$nullentry >= 0} {
1157 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1162 if {$dlevel >= $i} {
1167 set displist [linsert $displist $i {}]
1169 if {$dlevel >= $i} {
1175 # decide on the line spacing for the next line
1176 set lj [expr {$lineno + 1}]
1177 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1178 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1179 set xspc1($lj) $xspc2
1181 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1182 if {$xspc1($lj) < $lthickness} {
1183 set xspc1($lj) $lthickness
1187 foreach idi $reins {
1188 set id [lindex $idi 0]
1189 set j [lsearch -exact $displist $id]
1190 set xj [xcoord $j $dlevel $lj]
1191 set mainline($id) [list $xj $y2]
1192 set mainlinearrow($id) first
1196 foreach id $olddisplist {
1198 if {$id == {}} continue
1199 if {$onscreen($id) <= 0} continue
1200 set xi [xcoord $i $olddlevel $lineno]
1201 if {$i == $olddlevel} {
1202 foreach p $currentparents {
1203 set j [lsearch -exact $displist $p]
1204 set coords [list $xi $y1]
1205 set xj [xcoord $j $dlevel $lj]
1206 if {$xj < $xi - $linespc} {
1207 lappend coords [expr {$xj + $linespc}] $y1
1208 notecrossings $p $j $i [expr {$j + 1}]
1209 } elseif {$xj > $xi + $linespc} {
1210 lappend coords [expr {$xj - $linespc}] $y1
1211 notecrossings $p $i $j [expr {$j - 1}]
1213 if {[lsearch -exact $dupparents $p] >= 0} {
1214 # draw a double-width line to indicate the doubled parent
1215 lappend coords $xj $y2
1216 lappend sidelines($p) [list $coords 2 none]
1217 if {![info exists mainline($p)]} {
1218 set mainline($p) [list $xj $y2]
1219 set mainlinearrow($p) none
1222 # normal case, no parent duplicated
1224 set dx [expr {abs($xi - $xj)}]
1225 if {0 && $dx < $linespc} {
1226 set yb [expr {$y1 + $dx}]
1228 if {![info exists mainline($p)]} {
1230 lappend coords $xj $yb
1232 set mainline($p) $coords
1233 set mainlinearrow($p) none
1235 lappend coords $xj $yb
1237 lappend coords $xj $y2
1239 lappend sidelines($p) [list $coords 1 none]
1245 if {[lindex $displist $i] != $id} {
1246 set j [lsearch -exact $displist $id]
1248 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1249 || ($olddlevel < $i && $i < $dlevel)
1250 || ($dlevel < $i && $i < $olddlevel)} {
1251 set xj [xcoord $j $dlevel $lj]
1252 lappend mainline($id) $xi $y1 $xj $y2
1259 # search for x in a list of lists
1260 proc llsearch {llist x} {
1263 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1271 proc drawmore {reading} {
1272 global displayorder numcommits ncmupdate nextupdate
1273 global stopped nhyperspace parents commitlisted
1274 global maxwidth onscreen displist currentparents olddlevel
1276 set n [llength $displayorder]
1277 while {$numcommits < $n} {
1278 set id [lindex $displayorder $numcommits]
1279 set ctxend [expr {$numcommits + 10}]
1280 if {!$reading && $ctxend > $n} {
1284 if {$numcommits > 0} {
1285 set dlist [lreplace $displist $olddlevel $olddlevel]
1287 foreach p $currentparents {
1288 if {$onscreen($p) == 0} {
1289 set dlist [linsert $dlist $i $p]
1296 set isfat [expr {[llength $dlist] > $maxwidth}]
1297 if {$nhyperspace > 0 || $isfat} {
1298 if {$ctxend > $n} break
1299 # work out what to bring back and
1300 # what we want to don't want to send into hyperspace
1302 for {set k $numcommits} {$k < $ctxend} {incr k} {
1303 set x [lindex $displayorder $k]
1304 set i [llsearch $dlist $x]
1306 set i [llength $dlist]
1309 if {[lsearch -exact $nohs $x] < 0} {
1312 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1313 set reins [list $x $i]
1316 if {[info exists commitlisted($x)]} {
1318 foreach p $parents($x) {
1319 if {[llsearch $dlist $p] < 0} {
1321 if {[lsearch -exact $nohs $p] < 0} {
1324 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1325 set reins [list $p [expr {$i + $right}]]
1331 set l [lindex $dlist $i]
1332 if {[llength $l] == 1} {
1335 set j [lsearch -exact $l $x]
1336 set l [concat [lreplace $l $j $j] $newp]
1338 set dlist [lreplace $dlist $i $i $l]
1339 if {$room && $isfat && [llength $newp] <= 1} {
1345 set dlevel [drawslants $id $reins $nohs]
1346 drawcommitline $dlevel
1347 if {[clock clicks -milliseconds] >= $nextupdate
1348 && $numcommits >= $ncmupdate} {
1355 # level here is an index in todo
1356 proc updatetodo {level noshortcut} {
1357 global ncleft todo nnewparents
1358 global commitlisted parents onscreen
1360 set id [lindex $todo $level]
1362 if {[info exists commitlisted($id)]} {
1363 foreach p $parents($id) {
1364 if {[lsearch -exact $olds $p] < 0} {
1369 if {!$noshortcut && [llength $olds] == 1} {
1370 set p [lindex $olds 0]
1371 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1373 set todo [lreplace $todo $level $level $p]
1375 set nnewparents($id) 1
1380 set todo [lreplace $todo $level $level]
1385 set k [lsearch -exact $todo $p]
1387 set todo [linsert $todo $i $p]
1393 set nnewparents($id) $n
1398 proc decidenext {{noread 0}} {
1400 global datemode cdate
1403 # choose which one to do next time around
1404 set todol [llength $todo]
1407 for {set k $todol} {[incr k -1] >= 0} {} {
1408 set p [lindex $todo $k]
1409 if {$ncleft($p) == 0} {
1411 if {![info exists commitinfo($p)]} {
1417 if {$latest == {} || $cdate($p) > $latest} {
1419 set latest $cdate($p)
1431 proc drawcommit {id reading} {
1432 global phase todo nchildren datemode nextupdate revlistorder ncleft
1433 global numcommits ncmupdate displayorder todo onscreen parents
1434 global commitlisted commitordered
1436 if {$phase != "incrdraw"} {
1441 catch {unset commitordered}
1443 set commitordered($id) 1
1444 if {$nchildren($id) == 0} {
1448 if {$revlistorder} {
1449 set level [lsearch -exact $todo $id]
1451 error_popup "oops, $id isn't in todo"
1454 lappend displayorder $id
1457 set level [decidenext 1]
1458 if {$level == {} || $level < 0} return
1460 set id [lindex $todo $level]
1461 if {![info exists commitordered($id)]} {
1464 lappend displayorder [lindex $todo $level]
1465 if {[updatetodo $level $datemode]} {
1466 set level [decidenext 1]
1467 if {$level == {} || $level < 0} break
1474 proc finishcommits {} {
1475 global phase oldcommits commits
1476 global canv mainfont ctext maincursor textcursor
1477 global parents displayorder todo
1479 if {$phase == "incrdraw" || $phase == "removecommits"} {
1480 foreach id $oldcommits {
1486 } elseif {$phase == "updatecommits"} {
1487 # there were no new commits, in fact
1488 set commits $oldcommits
1493 $canv create text 3 3 -anchor nw -text "No commits selected" \
1494 -font $mainfont -tags textitems
1497 . config -cursor $maincursor
1498 settextcursor $textcursor
1501 # Don't change the text pane cursor if it is currently the hand cursor,
1502 # showing that we are over a sha1 ID link.
1503 proc settextcursor {c} {
1504 global ctext curtextcursor
1506 if {[$ctext cget -cursor] == $curtextcursor} {
1507 $ctext config -cursor $c
1509 set curtextcursor $c
1513 global nextupdate startmsecs ncmupdate
1514 global displayorder onscreen
1516 if {$displayorder == {}} return
1517 set startmsecs [clock clicks -milliseconds]
1518 set nextupdate [expr {$startmsecs + 100}]
1521 foreach id $displayorder {
1528 global phase stopped redisplaying selectedline
1529 global datemode todo displayorder ncleft
1530 global numcommits ncmupdate
1531 global nextupdate startmsecs revlistorder
1533 set level [decidenext]
1537 lappend displayorder [lindex $todo $level]
1538 set hard [updatetodo $level $datemode]
1540 set level [decidenext]
1541 if {$level < 0} break
1546 puts "ERROR: none of the pending commits can be done yet:"
1548 puts " $p ($ncleft($p))"
1554 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
1555 #puts "overall $drawmsecs ms for $numcommits commits"
1556 if {$redisplaying} {
1557 if {$stopped == 0 && [info exists selectedline]} {
1558 selectline $selectedline 0
1560 if {$stopped == 1} {
1562 after idle drawgraph
1569 proc findmatches {f} {
1570 global findtype foundstring foundstrlen
1571 if {$findtype == "Regexp"} {
1572 set matches [regexp -indices -all -inline $foundstring $f]
1574 if {$findtype == "IgnCase"} {
1575 set str [string tolower $f]
1581 while {[set j [string first $foundstring $str $i]] >= 0} {
1582 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
1583 set i [expr {$j + $foundstrlen}]
1590 global findtype findloc findstring markedmatches commitinfo
1591 global numcommits lineid linehtag linentag linedtag
1592 global mainfont namefont canv canv2 canv3 selectedline
1593 global matchinglines foundstring foundstrlen
1598 set matchinglines {}
1599 if {$findloc == "Pickaxe"} {
1603 if {$findtype == "IgnCase"} {
1604 set foundstring [string tolower $findstring]
1606 set foundstring $findstring
1608 set foundstrlen [string length $findstring]
1609 if {$foundstrlen == 0} return
1610 if {$findloc == "Files"} {
1614 if {![info exists selectedline]} {
1617 set oldsel $selectedline
1620 set fldtypes {Headline Author Date Committer CDate Comment}
1621 for {set l 0} {$l < $numcommits} {incr l} {
1623 set info $commitinfo($id)
1625 foreach f $info ty $fldtypes {
1626 if {$findloc != "All fields" && $findloc != $ty} {
1629 set matches [findmatches $f]
1630 if {$matches == {}} continue
1632 if {$ty == "Headline"} {
1633 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1634 } elseif {$ty == "Author"} {
1635 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1636 } elseif {$ty == "Date"} {
1637 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1641 lappend matchinglines $l
1642 if {!$didsel && $l > $oldsel} {
1648 if {$matchinglines == {}} {
1650 } elseif {!$didsel} {
1651 findselectline [lindex $matchinglines 0]
1655 proc findselectline {l} {
1656 global findloc commentend ctext
1658 if {$findloc == "All fields" || $findloc == "Comments"} {
1659 # highlight the matches in the comments
1660 set f [$ctext get 1.0 $commentend]
1661 set matches [findmatches $f]
1662 foreach match $matches {
1663 set start [lindex $match 0]
1664 set end [expr {[lindex $match 1] + 1}]
1665 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1670 proc findnext {restart} {
1671 global matchinglines selectedline
1672 if {![info exists matchinglines]} {
1678 if {![info exists selectedline]} return
1679 foreach l $matchinglines {
1680 if {$l > $selectedline} {
1689 global matchinglines selectedline
1690 if {![info exists matchinglines]} {
1694 if {![info exists selectedline]} return
1696 foreach l $matchinglines {
1697 if {$l >= $selectedline} break
1701 findselectline $prev
1707 proc findlocchange {name ix op} {
1708 global findloc findtype findtypemenu
1709 if {$findloc == "Pickaxe"} {
1715 $findtypemenu entryconf 1 -state $state
1716 $findtypemenu entryconf 2 -state $state
1719 proc stopfindproc {{done 0}} {
1720 global findprocpid findprocfile findids
1721 global ctext findoldcursor phase maincursor textcursor
1722 global findinprogress
1724 catch {unset findids}
1725 if {[info exists findprocpid]} {
1727 catch {exec kill $findprocpid}
1729 catch {close $findprocfile}
1732 if {[info exists findinprogress]} {
1733 unset findinprogress
1734 if {$phase != "incrdraw"} {
1735 . config -cursor $maincursor
1736 settextcursor $textcursor
1741 proc findpatches {} {
1742 global findstring selectedline numcommits
1743 global findprocpid findprocfile
1744 global finddidsel ctext lineid findinprogress
1745 global findinsertpos
1747 if {$numcommits == 0} return
1749 # make a list of all the ids to search, starting at the one
1750 # after the selected line (if any)
1751 if {[info exists selectedline]} {
1757 for {set i 0} {$i < $numcommits} {incr i} {
1758 if {[incr l] >= $numcommits} {
1761 append inputids $lineid($l) "\n"
1765 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1768 error_popup "Error starting search process: $err"
1772 set findinsertpos end
1774 set findprocpid [pid $f]
1775 fconfigure $f -blocking 0
1776 fileevent $f readable readfindproc
1778 . config -cursor watch
1780 set findinprogress 1
1783 proc readfindproc {} {
1784 global findprocfile finddidsel
1785 global idline matchinglines findinsertpos
1787 set n [gets $findprocfile line]
1789 if {[eof $findprocfile]} {
1797 if {![regexp {^[0-9a-f]{40}} $line id]} {
1798 error_popup "Can't parse git-diff-tree output: $line"
1802 if {![info exists idline($id)]} {
1803 puts stderr "spurious id: $id"
1810 proc insertmatch {l id} {
1811 global matchinglines findinsertpos finddidsel
1813 if {$findinsertpos == "end"} {
1814 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1815 set matchinglines [linsert $matchinglines 0 $l]
1818 lappend matchinglines $l
1821 set matchinglines [linsert $matchinglines $findinsertpos $l]
1832 global selectedline numcommits lineid ctext
1833 global ffileline finddidsel parents nparents
1834 global findinprogress findstartline findinsertpos
1835 global treediffs fdiffids fdiffsneeded fdiffpos
1836 global findmergefiles
1838 if {$numcommits == 0} return
1840 if {[info exists selectedline]} {
1841 set l [expr {$selectedline + 1}]
1846 set findstartline $l
1851 if {$findmergefiles || $nparents($id) == 1} {
1852 foreach p $parents($id) {
1853 if {![info exists treediffs([list $id $p])]} {
1854 append diffsneeded "$id $p\n"
1855 lappend fdiffsneeded [list $id $p]
1859 if {[incr l] >= $numcommits} {
1862 if {$l == $findstartline} break
1865 # start off a git-diff-tree process if needed
1866 if {$diffsneeded ne {}} {
1868 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1870 error_popup "Error starting search process: $err"
1873 catch {unset fdiffids}
1875 fconfigure $df -blocking 0
1876 fileevent $df readable [list readfilediffs $df]
1880 set findinsertpos end
1882 set p [lindex $parents($id) 0]
1883 . config -cursor watch
1885 set findinprogress 1
1886 findcont [list $id $p]
1890 proc readfilediffs {df} {
1891 global findids fdiffids fdiffs
1893 set n [gets $df line]
1897 if {[catch {close $df} err]} {
1900 error_popup "Error in git-diff-tree: $err"
1901 } elseif {[info exists findids]} {
1905 error_popup "Couldn't find diffs for {$ids}"
1910 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1911 # start of a new string of diffs
1913 set fdiffids [list $id $p]
1915 } elseif {[string match ":*" $line]} {
1916 lappend fdiffs [lindex $line 5]
1920 proc donefilediff {} {
1921 global fdiffids fdiffs treediffs findids
1922 global fdiffsneeded fdiffpos
1924 if {[info exists fdiffids]} {
1925 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1926 && $fdiffpos < [llength $fdiffsneeded]} {
1927 # git-diff-tree doesn't output anything for a commit
1928 # which doesn't change anything
1929 set nullids [lindex $fdiffsneeded $fdiffpos]
1930 set treediffs($nullids) {}
1931 if {[info exists findids] && $nullids eq $findids} {
1939 if {![info exists treediffs($fdiffids)]} {
1940 set treediffs($fdiffids) $fdiffs
1942 if {[info exists findids] && $fdiffids eq $findids} {
1949 proc findcont {ids} {
1950 global findids treediffs parents nparents
1951 global ffileline findstartline finddidsel
1952 global lineid numcommits matchinglines findinprogress
1953 global findmergefiles
1955 set id [lindex $ids 0]
1956 set p [lindex $ids 1]
1957 set pi [lsearch -exact $parents($id) $p]
1960 if {$findmergefiles || $nparents($id) == 1} {
1961 if {![info exists treediffs($ids)]} {
1967 foreach f $treediffs($ids) {
1968 set x [findmatches $f]
1976 set pi $nparents($id)
1979 set pi $nparents($id)
1981 if {[incr pi] >= $nparents($id)} {
1983 if {[incr l] >= $numcommits} {
1986 if {$l == $findstartline} break
1989 set p [lindex $parents($id) $pi]
1990 set ids [list $id $p]
1998 # mark a commit as matching by putting a yellow background
1999 # behind the headline
2000 proc markheadline {l id} {
2001 global canv mainfont linehtag commitinfo
2003 set bbox [$canv bbox $linehtag($l)]
2004 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
2008 # mark the bits of a headline, author or date that match a find string
2009 proc markmatches {canv l str tag matches font} {
2010 set bbox [$canv bbox $tag]
2011 set x0 [lindex $bbox 0]
2012 set y0 [lindex $bbox 1]
2013 set y1 [lindex $bbox 3]
2014 foreach match $matches {
2015 set start [lindex $match 0]
2016 set end [lindex $match 1]
2017 if {$start > $end} continue
2018 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
2019 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
2020 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
2021 [expr {$x0+$xlen+2}] $y1 \
2022 -outline {} -tags matches -fill yellow]
2027 proc unmarkmatches {} {
2028 global matchinglines findids
2029 allcanvs delete matches
2030 catch {unset matchinglines}
2031 catch {unset findids}
2034 proc selcanvline {w x y} {
2035 global canv canvy0 ctext linespc
2036 global lineid linehtag linentag linedtag rowtextx
2037 set ymax [lindex [$canv cget -scrollregion] 3]
2038 if {$ymax == {}} return
2039 set yfrac [lindex [$canv yview] 0]
2040 set y [expr {$y + $yfrac * $ymax}]
2041 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2046 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2052 proc commit_descriptor {p} {
2055 if {[info exists commitinfo($p)]} {
2056 set l [lindex $commitinfo($p) 0]
2061 # append some text to the ctext widget, and make any SHA1 ID
2062 # that we know about be a clickable link.
2063 proc appendwithlinks {text} {
2064 global ctext idline linknum
2066 set start [$ctext index "end - 1c"]
2067 $ctext insert end $text
2068 $ctext insert end "\n"
2069 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2073 set linkid [string range $text $s $e]
2074 if {![info exists idline($linkid)]} continue
2076 $ctext tag add link "$start + $s c" "$start + $e c"
2077 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2078 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2081 $ctext tag conf link -foreground blue -underline 1
2082 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2083 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2086 proc selectline {l isnew} {
2087 global canv canv2 canv3 ctext commitinfo selectedline
2088 global lineid linehtag linentag linedtag
2089 global canvy0 linespc parents nparents children
2090 global cflist currentid sha1entry
2091 global commentend idtags idline linknum
2095 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2097 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2098 -tags secsel -fill [$canv cget -selectbackground]]
2100 $canv2 delete secsel
2101 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2102 -tags secsel -fill [$canv2 cget -selectbackground]]
2104 $canv3 delete secsel
2105 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2106 -tags secsel -fill [$canv3 cget -selectbackground]]
2108 set y [expr {$canvy0 + $l * $linespc}]
2109 set ymax [lindex [$canv cget -scrollregion] 3]
2110 set ytop [expr {$y - $linespc - 1}]
2111 set ybot [expr {$y + $linespc + 1}]
2112 set wnow [$canv yview]
2113 set wtop [expr {[lindex $wnow 0] * $ymax}]
2114 set wbot [expr {[lindex $wnow 1] * $ymax}]
2115 set wh [expr {$wbot - $wtop}]
2117 if {$ytop < $wtop} {
2118 if {$ybot < $wtop} {
2119 set newtop [expr {$y - $wh / 2.0}]
2122 if {$newtop > $wtop - $linespc} {
2123 set newtop [expr {$wtop - $linespc}]
2126 } elseif {$ybot > $wbot} {
2127 if {$ytop > $wbot} {
2128 set newtop [expr {$y - $wh / 2.0}]
2130 set newtop [expr {$ybot - $wh}]
2131 if {$newtop < $wtop + $linespc} {
2132 set newtop [expr {$wtop + $linespc}]
2136 if {$newtop != $wtop} {
2140 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
2144 addtohistory [list selectline $l 0]
2151 $sha1entry delete 0 end
2152 $sha1entry insert 0 $id
2153 $sha1entry selection from 0
2154 $sha1entry selection to end
2156 $ctext conf -state normal
2157 $ctext delete 0.0 end
2159 $ctext mark set fmark.0 0.0
2160 $ctext mark gravity fmark.0 left
2161 set info $commitinfo($id)
2162 set date [formatdate [lindex $info 2]]
2163 $ctext insert end "Author: [lindex $info 1] $date\n"
2164 set date [formatdate [lindex $info 4]]
2165 $ctext insert end "Committer: [lindex $info 3] $date\n"
2166 if {[info exists idtags($id)]} {
2167 $ctext insert end "Tags:"
2168 foreach tag $idtags($id) {
2169 $ctext insert end " $tag"
2171 $ctext insert end "\n"
2175 if {[info exists parents($id)]} {
2176 foreach p $parents($id) {
2177 append comment "Parent: [commit_descriptor $p]\n"
2180 if {[info exists children($id)]} {
2181 foreach c $children($id) {
2182 append comment "Child: [commit_descriptor $c]\n"
2186 append comment [lindex $info 5]
2188 # make anything that looks like a SHA1 ID be a clickable link
2189 appendwithlinks $comment
2191 $ctext tag delete Comments
2192 $ctext tag remove found 1.0 end
2193 $ctext conf -state disabled
2194 set commentend [$ctext index "end - 1c"]
2196 $cflist delete 0 end
2197 $cflist insert end "Comments"
2198 if {$nparents($id) == 1} {
2200 } elseif {$nparents($id) > 1} {
2205 proc selnextline {dir} {
2207 if {![info exists selectedline]} return
2208 set l [expr {$selectedline + $dir}]
2213 proc unselectline {} {
2216 catch {unset selectedline}
2217 allcanvs delete secsel
2220 proc addtohistory {cmd} {
2221 global history historyindex
2223 if {$historyindex > 0
2224 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2228 if {$historyindex < [llength $history]} {
2229 set history [lreplace $history $historyindex end $cmd]
2231 lappend history $cmd
2234 if {$historyindex > 1} {
2235 .ctop.top.bar.leftbut conf -state normal
2237 .ctop.top.bar.leftbut conf -state disabled
2239 .ctop.top.bar.rightbut conf -state disabled
2243 global history historyindex
2245 if {$historyindex > 1} {
2246 incr historyindex -1
2247 set cmd [lindex $history [expr {$historyindex - 1}]]
2249 .ctop.top.bar.rightbut conf -state normal
2251 if {$historyindex <= 1} {
2252 .ctop.top.bar.leftbut conf -state disabled
2257 global history historyindex
2259 if {$historyindex < [llength $history]} {
2260 set cmd [lindex $history $historyindex]
2263 .ctop.top.bar.leftbut conf -state normal
2265 if {$historyindex >= [llength $history]} {
2266 .ctop.top.bar.rightbut conf -state disabled
2270 proc mergediff {id} {
2271 global parents diffmergeid diffmergegca mergefilelist diffpindex
2275 set diffmergegca [findgca $parents($id)]
2276 if {[info exists mergefilelist($id)]} {
2277 if {$mergefilelist($id) ne {}} {
2285 proc findgca {ids} {
2292 set gca [exec git-merge-base $gca $id]
2301 proc contmergediff {ids} {
2302 global diffmergeid diffpindex parents nparents diffmergegca
2303 global treediffs mergefilelist diffids treepending
2305 # diff the child against each of the parents, and diff
2306 # each of the parents against the GCA.
2308 if {[lindex $ids 1] == $diffmergeid && $diffmergegca ne {}} {
2309 set ids [list $diffmergegca [lindex $ids 0]]
2311 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2312 set p [lindex $parents($diffmergeid) $diffpindex]
2313 set ids [list $p $diffmergeid]
2315 if {![info exists treediffs($ids)]} {
2317 if {![info exists treepending]} {
2324 # If a file in some parent is different from the child and also
2325 # different from the GCA, then it's interesting.
2326 # If we don't have a GCA, then a file is interesting if it is
2327 # different from the child in all the parents.
2328 if {$diffmergegca ne {}} {
2330 foreach p $parents($diffmergeid) {
2331 set gcadiffs $treediffs([list $diffmergegca $p])
2332 foreach f $treediffs([list $p $diffmergeid]) {
2333 if {[lsearch -exact $files $f] < 0
2334 && [lsearch -exact $gcadiffs $f] >= 0} {
2339 set files [lsort $files]
2341 set p [lindex $parents($diffmergeid) 0]
2342 set files $treediffs([list $diffmergeid $p])
2343 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2344 set p [lindex $parents($diffmergeid) $i]
2345 set df $treediffs([list $p $diffmergeid])
2348 if {[lsearch -exact $df $f] >= 0} {
2356 set mergefilelist($diffmergeid) $files
2362 proc showmergediff {} {
2363 global cflist diffmergeid mergefilelist parents
2364 global diffopts diffinhunk currentfile currenthunk filelines
2365 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2367 set files $mergefilelist($diffmergeid)
2369 $cflist insert end $f
2371 set env(GIT_DIFF_OPTS) $diffopts
2373 catch {unset currentfile}
2374 catch {unset currenthunk}
2375 catch {unset filelines}
2376 catch {unset groupfilenum}
2377 catch {unset grouphunks}
2378 set groupfilelast -1
2379 foreach p $parents($diffmergeid) {
2380 set cmd [list | git-diff-tree -p $p $diffmergeid]
2381 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2382 if {[catch {set f [open $cmd r]} err]} {
2383 error_popup "Error getting diffs: $err"
2390 set ids [list $diffmergeid $p]
2391 set mergefds($ids) $f
2392 set diffinhunk($ids) 0
2393 set diffblocked($ids) 0
2394 fconfigure $f -blocking 0
2395 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2399 proc getmergediffline {f ids id} {
2400 global diffmergeid diffinhunk diffoldlines diffnewlines
2401 global currentfile currenthunk
2402 global diffoldstart diffnewstart diffoldlno diffnewlno
2403 global diffblocked mergefilelist
2404 global noldlines nnewlines difflcounts filelines
2406 set n [gets $f line]
2408 if {![eof $f]} return
2411 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2418 if {$diffinhunk($ids) != 0} {
2419 set fi $currentfile($ids)
2420 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2421 # continuing an existing hunk
2422 set line [string range $line 1 end]
2423 set p [lindex $ids 1]
2424 if {$match eq "-" || $match eq " "} {
2425 set filelines($p,$fi,$diffoldlno($ids)) $line
2426 incr diffoldlno($ids)
2428 if {$match eq "+" || $match eq " "} {
2429 set filelines($id,$fi,$diffnewlno($ids)) $line
2430 incr diffnewlno($ids)
2432 if {$match eq " "} {
2433 if {$diffinhunk($ids) == 2} {
2434 lappend difflcounts($ids) \
2435 [list $noldlines($ids) $nnewlines($ids)]
2436 set noldlines($ids) 0
2437 set diffinhunk($ids) 1
2439 incr noldlines($ids)
2440 } elseif {$match eq "-" || $match eq "+"} {
2441 if {$diffinhunk($ids) == 1} {
2442 lappend difflcounts($ids) [list $noldlines($ids)]
2443 set noldlines($ids) 0
2444 set nnewlines($ids) 0
2445 set diffinhunk($ids) 2
2447 if {$match eq "-"} {
2448 incr noldlines($ids)
2450 incr nnewlines($ids)
2453 # and if it's \ No newline at end of line, then what?
2457 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2458 lappend difflcounts($ids) [list $noldlines($ids)]
2459 } elseif {$diffinhunk($ids) == 2
2460 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2461 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2463 set currenthunk($ids) [list $currentfile($ids) \
2464 $diffoldstart($ids) $diffnewstart($ids) \
2465 $diffoldlno($ids) $diffnewlno($ids) \
2467 set diffinhunk($ids) 0
2468 # -1 = need to block, 0 = unblocked, 1 = is blocked
2469 set diffblocked($ids) -1
2471 if {$diffblocked($ids) == -1} {
2472 fileevent $f readable {}
2473 set diffblocked($ids) 1
2479 if {!$diffblocked($ids)} {
2481 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2482 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2485 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2486 # start of a new file
2487 set currentfile($ids) \
2488 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2489 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2490 $line match f1l f1c f2l f2c rest]} {
2491 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2492 # start of a new hunk
2493 if {$f1l == 0 && $f1c == 0} {
2496 if {$f2l == 0 && $f2c == 0} {
2499 set diffinhunk($ids) 1
2500 set diffoldstart($ids) $f1l
2501 set diffnewstart($ids) $f2l
2502 set diffoldlno($ids) $f1l
2503 set diffnewlno($ids) $f2l
2504 set difflcounts($ids) {}
2505 set noldlines($ids) 0
2506 set nnewlines($ids) 0
2511 proc processhunks {} {
2512 global diffmergeid parents nparents currenthunk
2513 global mergefilelist diffblocked mergefds
2514 global grouphunks grouplinestart grouplineend groupfilenum
2516 set nfiles [llength $mergefilelist($diffmergeid)]
2520 # look for the earliest hunk
2521 foreach p $parents($diffmergeid) {
2522 set ids [list $diffmergeid $p]
2523 if {![info exists currenthunk($ids)]} return
2524 set i [lindex $currenthunk($ids) 0]
2525 set l [lindex $currenthunk($ids) 2]
2526 if {$i < $fi || ($i == $fi && $l < $lno)} {
2533 if {$fi < $nfiles} {
2534 set ids [list $diffmergeid $pi]
2535 set hunk $currenthunk($ids)
2536 unset currenthunk($ids)
2537 if {$diffblocked($ids) > 0} {
2538 fileevent $mergefds($ids) readable \
2539 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2541 set diffblocked($ids) 0
2543 if {[info exists groupfilenum] && $groupfilenum == $fi
2544 && $lno <= $grouplineend} {
2545 # add this hunk to the pending group
2546 lappend grouphunks($pi) $hunk
2547 set endln [lindex $hunk 4]
2548 if {$endln > $grouplineend} {
2549 set grouplineend $endln
2555 # succeeding stuff doesn't belong in this group, so
2556 # process the group now
2557 if {[info exists groupfilenum]} {
2563 if {$fi >= $nfiles} break
2566 set groupfilenum $fi
2567 set grouphunks($pi) [list $hunk]
2568 set grouplinestart $lno
2569 set grouplineend [lindex $hunk 4]
2573 proc processgroup {} {
2574 global groupfilelast groupfilenum difffilestart
2575 global mergefilelist diffmergeid ctext filelines
2576 global parents diffmergeid diffoffset
2577 global grouphunks grouplinestart grouplineend nparents
2580 $ctext conf -state normal
2583 if {$groupfilelast != $f} {
2584 $ctext insert end "\n"
2585 set here [$ctext index "end - 1c"]
2586 set difffilestart($f) $here
2587 set mark fmark.[expr {$f + 1}]
2588 $ctext mark set $mark $here
2589 $ctext mark gravity $mark left
2590 set header [lindex $mergefilelist($id) $f]
2591 set l [expr {(78 - [string length $header]) / 2}]
2592 set pad [string range "----------------------------------------" 1 $l]
2593 $ctext insert end "$pad $header $pad\n" filesep
2594 set groupfilelast $f
2595 foreach p $parents($id) {
2596 set diffoffset($p) 0
2600 $ctext insert end "@@" msep
2601 set nlines [expr {$grouplineend - $grouplinestart}]
2604 foreach p $parents($id) {
2605 set startline [expr {$grouplinestart + $diffoffset($p)}]
2607 set nl $grouplinestart
2608 if {[info exists grouphunks($p)]} {
2609 foreach h $grouphunks($p) {
2612 for {} {$nl < $l} {incr nl} {
2613 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2617 foreach chunk [lindex $h 5] {
2618 if {[llength $chunk] == 2} {
2619 set olc [lindex $chunk 0]
2620 set nlc [lindex $chunk 1]
2621 set nnl [expr {$nl + $nlc}]
2622 lappend events [list $nl $nnl $pnum $olc $nlc]
2626 incr ol [lindex $chunk 0]
2627 incr nl [lindex $chunk 0]
2632 if {$nl < $grouplineend} {
2633 for {} {$nl < $grouplineend} {incr nl} {
2634 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2638 set nlines [expr {$ol - $startline}]
2639 $ctext insert end " -$startline,$nlines" msep
2643 set nlines [expr {$grouplineend - $grouplinestart}]
2644 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2646 set events [lsort -integer -index 0 $events]
2647 set nevents [llength $events]
2648 set nmerge $nparents($diffmergeid)
2649 set l $grouplinestart
2650 for {set i 0} {$i < $nevents} {set i $j} {
2651 set nl [lindex $events $i 0]
2653 $ctext insert end " $filelines($id,$f,$l)\n"
2656 set e [lindex $events $i]
2657 set enl [lindex $e 1]
2661 set pnum [lindex $e 2]
2662 set olc [lindex $e 3]
2663 set nlc [lindex $e 4]
2664 if {![info exists delta($pnum)]} {
2665 set delta($pnum) [expr {$olc - $nlc}]
2666 lappend active $pnum
2668 incr delta($pnum) [expr {$olc - $nlc}]
2670 if {[incr j] >= $nevents} break
2671 set e [lindex $events $j]
2672 if {[lindex $e 0] >= $enl} break
2673 if {[lindex $e 1] > $enl} {
2674 set enl [lindex $e 1]
2677 set nlc [expr {$enl - $l}]
2680 if {[llength $active] == $nmerge - 1} {
2681 # no diff for one of the parents, i.e. it's identical
2682 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2683 if {![info exists delta($pnum)]} {
2684 if {$pnum < $mergemax} {
2692 } elseif {[llength $active] == $nmerge} {
2693 # all parents are different, see if one is very similar
2695 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2696 set sim [similarity $pnum $l $nlc $f \
2697 [lrange $events $i [expr {$j-1}]]]
2698 if {$sim > $bestsim} {
2704 lappend ncol m$bestpn
2708 foreach p $parents($id) {
2710 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2711 set olc [expr {$nlc + $delta($pnum)}]
2712 set ol [expr {$l + $diffoffset($p)}]
2713 incr diffoffset($p) $delta($pnum)
2715 for {} {$olc > 0} {incr olc -1} {
2716 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2720 set endl [expr {$l + $nlc}]
2722 # show this pretty much as a normal diff
2723 set p [lindex $parents($id) $bestpn]
2724 set ol [expr {$l + $diffoffset($p)}]
2725 incr diffoffset($p) $delta($bestpn)
2726 unset delta($bestpn)
2727 for {set k $i} {$k < $j} {incr k} {
2728 set e [lindex $events $k]
2729 if {[lindex $e 2] != $bestpn} continue
2730 set nl [lindex $e 0]
2731 set ol [expr {$ol + $nl - $l}]
2732 for {} {$l < $nl} {incr l} {
2733 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2736 for {} {$c > 0} {incr c -1} {
2737 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2740 set nl [lindex $e 1]
2741 for {} {$l < $nl} {incr l} {
2742 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2746 for {} {$l < $endl} {incr l} {
2747 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2750 while {$l < $grouplineend} {
2751 $ctext insert end " $filelines($id,$f,$l)\n"
2754 $ctext conf -state disabled
2757 proc similarity {pnum l nlc f events} {
2758 global diffmergeid parents diffoffset filelines
2761 set p [lindex $parents($id) $pnum]
2762 set ol [expr {$l + $diffoffset($p)}]
2763 set endl [expr {$l + $nlc}]
2767 if {[lindex $e 2] != $pnum} continue
2768 set nl [lindex $e 0]
2769 set ol [expr {$ol + $nl - $l}]
2770 for {} {$l < $nl} {incr l} {
2771 incr same [string length $filelines($id,$f,$l)]
2774 set oc [lindex $e 3]
2775 for {} {$oc > 0} {incr oc -1} {
2776 incr diff [string length $filelines($p,$f,$ol)]
2780 set nl [lindex $e 1]
2781 for {} {$l < $nl} {incr l} {
2782 incr diff [string length $filelines($id,$f,$l)]
2786 for {} {$l < $endl} {incr l} {
2787 incr same [string length $filelines($id,$f,$l)]
2793 return [expr {200 * $same / (2 * $same + $diff)}]
2796 proc startdiff {ids} {
2797 global treediffs diffids treepending diffmergeid
2800 catch {unset diffmergeid}
2801 if {![info exists treediffs($ids)]} {
2802 if {![info exists treepending]} {
2810 proc addtocflist {ids} {
2811 global treediffs cflist
2812 foreach f $treediffs($ids) {
2813 $cflist insert end $f
2818 proc gettreediffs {ids} {
2819 global treediff parents treepending
2820 set treepending $ids
2822 if [catch {set gdtf [open [concat | git-diff-tree --no-commit-id -r $ids] r]}] return
2823 fconfigure $gdtf -blocking 0
2824 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2827 proc gettreediffline {gdtf ids} {
2828 global treediff treediffs treepending diffids diffmergeid
2830 set n [gets $gdtf line]
2832 if {![eof $gdtf]} return
2834 set treediffs($ids) $treediff
2836 if {$ids != $diffids} {
2837 gettreediffs $diffids
2839 if {[info exists diffmergeid]} {
2847 set file [lindex $line 5]
2848 lappend treediff $file
2851 proc getblobdiffs {ids} {
2852 global diffopts blobdifffd diffids env curdifftag curtagstart
2853 global difffilestart nextupdate diffinhdr treediffs
2855 set env(GIT_DIFF_OPTS) $diffopts
2856 set cmd [concat | git-diff-tree --no-commit-id -r -p -C $ids]
2857 if {[catch {set bdf [open $cmd r]} err]} {
2858 puts "error getting diffs: $err"
2862 fconfigure $bdf -blocking 0
2863 set blobdifffd($ids) $bdf
2864 set curdifftag Comments
2866 catch {unset difffilestart}
2867 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2868 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2871 proc getblobdiffline {bdf ids} {
2872 global diffids blobdifffd ctext curdifftag curtagstart
2873 global diffnexthead diffnextnote difffilestart
2874 global nextupdate diffinhdr treediffs
2876 set n [gets $bdf line]
2880 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2881 $ctext tag add $curdifftag $curtagstart end
2886 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2889 $ctext conf -state normal
2890 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2891 # start of a new file
2892 $ctext insert end "\n"
2893 $ctext tag add $curdifftag $curtagstart end
2894 set curtagstart [$ctext index "end - 1c"]
2896 set here [$ctext index "end - 1c"]
2897 set i [lsearch -exact $treediffs($diffids) $fname]
2899 set difffilestart($i) $here
2901 $ctext mark set fmark.$i $here
2902 $ctext mark gravity fmark.$i left
2904 if {$newname != $fname} {
2905 set i [lsearch -exact $treediffs($diffids) $newname]
2907 set difffilestart($i) $here
2909 $ctext mark set fmark.$i $here
2910 $ctext mark gravity fmark.$i left
2913 set curdifftag "f:$fname"
2914 $ctext tag delete $curdifftag
2915 set l [expr {(78 - [string length $header]) / 2}]
2916 set pad [string range "----------------------------------------" 1 $l]
2917 $ctext insert end "$pad $header $pad\n" filesep
2919 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2921 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2922 $line match f1l f1c f2l f2c rest]} {
2923 $ctext insert end "$line\n" hunksep
2926 set x [string range $line 0 0]
2927 if {$x == "-" || $x == "+"} {
2928 set tag [expr {$x == "+"}]
2929 $ctext insert end "$line\n" d$tag
2930 } elseif {$x == " "} {
2931 $ctext insert end "$line\n"
2932 } elseif {$diffinhdr || $x == "\\"} {
2933 # e.g. "\ No newline at end of file"
2934 $ctext insert end "$line\n" filesep
2936 # Something else we don't recognize
2937 if {$curdifftag != "Comments"} {
2938 $ctext insert end "\n"
2939 $ctext tag add $curdifftag $curtagstart end
2940 set curtagstart [$ctext index "end - 1c"]
2941 set curdifftag Comments
2943 $ctext insert end "$line\n" filesep
2946 $ctext conf -state disabled
2947 if {[clock clicks -milliseconds] >= $nextupdate} {
2949 fileevent $bdf readable {}
2951 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2956 global difffilestart ctext
2957 set here [$ctext index @0,0]
2958 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2959 if {[$ctext compare $difffilestart($i) > $here]} {
2960 if {![info exists pos]
2961 || [$ctext compare $difffilestart($i) < $pos]} {
2962 set pos $difffilestart($i)
2966 if {[info exists pos]} {
2971 proc listboxsel {} {
2972 global ctext cflist currentid
2973 if {![info exists currentid]} return
2974 set sel [lsort [$cflist curselection]]
2975 if {$sel eq {}} return
2976 set first [lindex $sel 0]
2977 catch {$ctext yview fmark.$first}
2981 global linespc charspc canvx0 canvy0 mainfont
2982 global xspc1 xspc2 lthickness
2984 set linespc [font metrics $mainfont -linespace]
2985 set charspc [font measure $mainfont "m"]
2986 set canvy0 [expr {3 + 0.5 * $linespc}]
2987 set canvx0 [expr {3 + 0.5 * $linespc}]
2988 set lthickness [expr {int($linespc / 9) + 1}]
2989 set xspc1(0) $linespc
2994 global stopped redisplaying phase
2995 if {$stopped > 1} return
2996 if {$phase == "getcommits"} return
2998 if {$phase == "drawgraph" || $phase == "incrdraw"} {
3005 proc incrfont {inc} {
3006 global mainfont namefont textfont ctext canv phase
3007 global stopped entries
3009 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
3010 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
3011 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
3013 $ctext conf -font $textfont
3014 $ctext tag conf filesep -font [concat $textfont bold]
3015 foreach e $entries {
3016 $e conf -font $mainfont
3018 if {$phase == "getcommits"} {
3019 $canv itemconf textitems -font $mainfont
3025 global sha1entry sha1string
3026 if {[string length $sha1string] == 40} {
3027 $sha1entry delete 0 end
3031 proc sha1change {n1 n2 op} {
3032 global sha1string currentid sha1but
3033 if {$sha1string == {}
3034 || ([info exists currentid] && $sha1string == $currentid)} {
3039 if {[$sha1but cget -state] == $state} return
3040 if {$state == "normal"} {
3041 $sha1but conf -state normal -relief raised -text "Goto: "
3043 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3047 proc gotocommit {} {
3048 global sha1string currentid idline tagids
3049 global lineid numcommits
3051 if {$sha1string == {}
3052 || ([info exists currentid] && $sha1string == $currentid)} return
3053 if {[info exists tagids($sha1string)]} {
3054 set id $tagids($sha1string)
3056 set id [string tolower $sha1string]
3057 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3059 for {set l 0} {$l < $numcommits} {incr l} {
3060 if {[string match $id* $lineid($l)]} {
3061 lappend matches $lineid($l)
3064 if {$matches ne {}} {
3065 if {[llength $matches] > 1} {
3066 error_popup "Short SHA1 id $id is ambiguous"
3069 set id [lindex $matches 0]
3073 if {[info exists idline($id)]} {
3074 selectline $idline($id) 1
3077 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3082 error_popup "$type $sha1string is not known"
3085 proc lineenter {x y id} {
3086 global hoverx hovery hoverid hovertimer
3087 global commitinfo canv
3089 if {![info exists commitinfo($id)]} return
3093 if {[info exists hovertimer]} {
3094 after cancel $hovertimer
3096 set hovertimer [after 500 linehover]
3100 proc linemotion {x y id} {
3101 global hoverx hovery hoverid hovertimer
3103 if {[info exists hoverid] && $id == $hoverid} {
3106 if {[info exists hovertimer]} {
3107 after cancel $hovertimer
3109 set hovertimer [after 500 linehover]
3113 proc lineleave {id} {
3114 global hoverid hovertimer canv
3116 if {[info exists hoverid] && $id == $hoverid} {
3118 if {[info exists hovertimer]} {
3119 after cancel $hovertimer
3127 global hoverx hovery hoverid hovertimer
3128 global canv linespc lthickness
3129 global commitinfo mainfont
3131 set text [lindex $commitinfo($hoverid) 0]
3132 set ymax [lindex [$canv cget -scrollregion] 3]
3133 if {$ymax == {}} return
3134 set yfrac [lindex [$canv yview] 0]
3135 set x [expr {$hoverx + 2 * $linespc}]
3136 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3137 set x0 [expr {$x - 2 * $lthickness}]
3138 set y0 [expr {$y - 2 * $lthickness}]
3139 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3140 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3141 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3142 -fill \#ffff80 -outline black -width 1 -tags hover]
3144 set t [$canv create text $x $y -anchor nw -text $text -tags hover -font $mainfont]
3148 proc clickisonarrow {id y} {
3149 global mainline mainlinearrow sidelines lthickness
3151 set thresh [expr {2 * $lthickness + 6}]
3152 if {[info exists mainline($id)]} {
3153 if {$mainlinearrow($id) ne "none"} {
3154 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3159 if {[info exists sidelines($id)]} {
3160 foreach ls $sidelines($id) {
3161 set coords [lindex $ls 0]
3162 set arrow [lindex $ls 2]
3163 if {$arrow eq "first" || $arrow eq "both"} {
3164 if {abs([lindex $coords 1] - $y) < $thresh} {
3168 if {$arrow eq "last" || $arrow eq "both"} {
3169 if {abs([lindex $coords end] - $y) < $thresh} {
3178 proc arrowjump {id dirn y} {
3179 global mainline sidelines canv canv2 canv3
3182 if {$dirn eq "down"} {
3183 if {[info exists mainline($id)]} {
3184 set y1 [lindex $mainline($id) 1]
3189 if {[info exists sidelines($id)]} {
3190 foreach ls $sidelines($id) {
3191 set y1 [lindex $ls 0 1]
3192 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3198 if {[info exists sidelines($id)]} {
3199 foreach ls $sidelines($id) {
3200 set y1 [lindex $ls 0 end]
3201 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3207 if {$yt eq {}} return
3208 set ymax [lindex [$canv cget -scrollregion] 3]
3209 if {$ymax eq {} || $ymax <= 0} return
3210 set view [$canv yview]
3211 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3212 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3216 $canv yview moveto $yfrac
3217 $canv2 yview moveto $yfrac
3218 $canv3 yview moveto $yfrac
3221 proc lineclick {x y id isnew} {
3222 global ctext commitinfo children cflist canv thickerline
3228 # draw this line thicker than normal
3232 set ymax [lindex [$canv cget -scrollregion] 3]
3233 if {$ymax eq {}} return
3234 set yfrac [lindex [$canv yview] 0]
3235 set y [expr {$y + $yfrac * $ymax}]
3237 set dirn [clickisonarrow $id $y]
3239 arrowjump $id $dirn $y
3244 addtohistory [list lineclick $x $y $id 0]
3246 # fill the details pane with info about this line
3247 $ctext conf -state normal
3248 $ctext delete 0.0 end
3249 $ctext tag conf link -foreground blue -underline 1
3250 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3251 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3252 $ctext insert end "Parent:\t"
3253 $ctext insert end $id [list link link0]
3254 $ctext tag bind link0 <1> [list selbyid $id]
3255 set info $commitinfo($id)
3256 $ctext insert end "\n\t[lindex $info 0]\n"
3257 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3258 set date [formatdate [lindex $info 2]]
3259 $ctext insert end "\tDate:\t$date\n"
3260 if {[info exists children($id)]} {
3261 $ctext insert end "\nChildren:"
3263 foreach child $children($id) {
3265 set info $commitinfo($child)
3266 $ctext insert end "\n\t"
3267 $ctext insert end $child [list link link$i]
3268 $ctext tag bind link$i <1> [list selbyid $child]
3269 $ctext insert end "\n\t[lindex $info 0]"
3270 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3271 set date [formatdate [lindex $info 2]]
3272 $ctext insert end "\n\tDate:\t$date\n"
3275 $ctext conf -state disabled
3277 $cflist delete 0 end
3280 proc normalline {} {
3282 if {[info exists thickerline]} {
3283 drawlines $thickerline 0 1
3290 if {[info exists idline($id)]} {
3291 selectline $idline($id) 1
3297 if {![info exists startmstime]} {
3298 set startmstime [clock clicks -milliseconds]
3300 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3303 proc rowmenu {x y id} {
3304 global rowctxmenu idline selectedline rowmenuid
3306 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3311 $rowctxmenu entryconfigure 0 -state $state
3312 $rowctxmenu entryconfigure 1 -state $state
3313 $rowctxmenu entryconfigure 2 -state $state
3315 tk_popup $rowctxmenu $x $y
3318 proc diffvssel {dirn} {
3319 global rowmenuid selectedline lineid
3321 if {![info exists selectedline]} return
3323 set oldid $lineid($selectedline)
3324 set newid $rowmenuid
3326 set oldid $rowmenuid
3327 set newid $lineid($selectedline)
3329 addtohistory [list doseldiff $oldid $newid]
3330 doseldiff $oldid $newid
3333 proc doseldiff {oldid newid} {
3337 $ctext conf -state normal
3338 $ctext delete 0.0 end
3339 $ctext mark set fmark.0 0.0
3340 $ctext mark gravity fmark.0 left
3341 $cflist delete 0 end
3342 $cflist insert end "Top"
3343 $ctext insert end "From "
3344 $ctext tag conf link -foreground blue -underline 1
3345 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3346 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3347 $ctext tag bind link0 <1> [list selbyid $oldid]
3348 $ctext insert end $oldid [list link link0]
3349 $ctext insert end "\n "
3350 $ctext insert end [lindex $commitinfo($oldid) 0]
3351 $ctext insert end "\n\nTo "
3352 $ctext tag bind link1 <1> [list selbyid $newid]
3353 $ctext insert end $newid [list link link1]
3354 $ctext insert end "\n "
3355 $ctext insert end [lindex $commitinfo($newid) 0]
3356 $ctext insert end "\n"
3357 $ctext conf -state disabled
3358 $ctext tag delete Comments
3359 $ctext tag remove found 1.0 end
3360 startdiff [list $oldid $newid]
3364 global rowmenuid currentid commitinfo patchtop patchnum
3366 if {![info exists currentid]} return
3367 set oldid $currentid
3368 set oldhead [lindex $commitinfo($oldid) 0]
3369 set newid $rowmenuid
3370 set newhead [lindex $commitinfo($newid) 0]
3373 catch {destroy $top}
3375 label $top.title -text "Generate patch"
3376 grid $top.title - -pady 10
3377 label $top.from -text "From:"
3378 entry $top.fromsha1 -width 40 -relief flat
3379 $top.fromsha1 insert 0 $oldid
3380 $top.fromsha1 conf -state readonly
3381 grid $top.from $top.fromsha1 -sticky w
3382 entry $top.fromhead -width 60 -relief flat
3383 $top.fromhead insert 0 $oldhead
3384 $top.fromhead conf -state readonly
3385 grid x $top.fromhead -sticky w
3386 label $top.to -text "To:"
3387 entry $top.tosha1 -width 40 -relief flat
3388 $top.tosha1 insert 0 $newid
3389 $top.tosha1 conf -state readonly
3390 grid $top.to $top.tosha1 -sticky w
3391 entry $top.tohead -width 60 -relief flat
3392 $top.tohead insert 0 $newhead
3393 $top.tohead conf -state readonly
3394 grid x $top.tohead -sticky w
3395 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3396 grid $top.rev x -pady 10
3397 label $top.flab -text "Output file:"
3398 entry $top.fname -width 60
3399 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3401 grid $top.flab $top.fname -sticky w
3403 button $top.buts.gen -text "Generate" -command mkpatchgo
3404 button $top.buts.can -text "Cancel" -command mkpatchcan
3405 grid $top.buts.gen $top.buts.can
3406 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3407 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3408 grid $top.buts - -pady 10 -sticky ew
3412 proc mkpatchrev {} {
3415 set oldid [$patchtop.fromsha1 get]
3416 set oldhead [$patchtop.fromhead get]
3417 set newid [$patchtop.tosha1 get]
3418 set newhead [$patchtop.tohead get]
3419 foreach e [list fromsha1 fromhead tosha1 tohead] \
3420 v [list $newid $newhead $oldid $oldhead] {
3421 $patchtop.$e conf -state normal
3422 $patchtop.$e delete 0 end
3423 $patchtop.$e insert 0 $v
3424 $patchtop.$e conf -state readonly
3431 set oldid [$patchtop.fromsha1 get]
3432 set newid [$patchtop.tosha1 get]
3433 set fname [$patchtop.fname get]
3434 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3435 error_popup "Error creating patch: $err"
3437 catch {destroy $patchtop}
3441 proc mkpatchcan {} {
3444 catch {destroy $patchtop}
3449 global rowmenuid mktagtop commitinfo
3453 catch {destroy $top}
3455 label $top.title -text "Create tag"
3456 grid $top.title - -pady 10
3457 label $top.id -text "ID:"
3458 entry $top.sha1 -width 40 -relief flat
3459 $top.sha1 insert 0 $rowmenuid
3460 $top.sha1 conf -state readonly
3461 grid $top.id $top.sha1 -sticky w
3462 entry $top.head -width 60 -relief flat
3463 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3464 $top.head conf -state readonly
3465 grid x $top.head -sticky w
3466 label $top.tlab -text "Tag name:"
3467 entry $top.tag -width 60
3468 grid $top.tlab $top.tag -sticky w
3470 button $top.buts.gen -text "Create" -command mktaggo
3471 button $top.buts.can -text "Cancel" -command mktagcan
3472 grid $top.buts.gen $top.buts.can
3473 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3474 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3475 grid $top.buts - -pady 10 -sticky ew
3480 global mktagtop env tagids idtags
3482 set id [$mktagtop.sha1 get]
3483 set tag [$mktagtop.tag get]
3485 error_popup "No tag name specified"
3488 if {[info exists tagids($tag)]} {
3489 error_popup "Tag \"$tag\" already exists"
3494 set fname [file join $dir "refs/tags" $tag]
3495 set f [open $fname w]
3499 error_popup "Error creating tag: $err"
3503 set tagids($tag) $id
3504 lappend idtags($id) $tag
3508 proc redrawtags {id} {
3509 global canv linehtag idline idpos selectedline
3511 if {![info exists idline($id)]} return
3512 $canv delete tag.$id
3513 set xt [eval drawtags $id $idpos($id)]
3514 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3515 if {[info exists selectedline] && $selectedline == $idline($id)} {
3516 selectline $selectedline 0
3523 catch {destroy $mktagtop}
3532 proc writecommit {} {
3533 global rowmenuid wrcomtop commitinfo wrcomcmd
3535 set top .writecommit
3537 catch {destroy $top}
3539 label $top.title -text "Write commit to file"
3540 grid $top.title - -pady 10
3541 label $top.id -text "ID:"
3542 entry $top.sha1 -width 40 -relief flat
3543 $top.sha1 insert 0 $rowmenuid
3544 $top.sha1 conf -state readonly
3545 grid $top.id $top.sha1 -sticky w
3546 entry $top.head -width 60 -relief flat
3547 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3548 $top.head conf -state readonly
3549 grid x $top.head -sticky w
3550 label $top.clab -text "Command:"
3551 entry $top.cmd -width 60 -textvariable wrcomcmd
3552 grid $top.clab $top.cmd -sticky w -pady 10
3553 label $top.flab -text "Output file:"
3554 entry $top.fname -width 60
3555 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3556 grid $top.flab $top.fname -sticky w
3558 button $top.buts.gen -text "Write" -command wrcomgo
3559 button $top.buts.can -text "Cancel" -command wrcomcan
3560 grid $top.buts.gen $top.buts.can
3561 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3562 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3563 grid $top.buts - -pady 10 -sticky ew
3570 set id [$wrcomtop.sha1 get]
3571 set cmd "echo $id | [$wrcomtop.cmd get]"
3572 set fname [$wrcomtop.fname get]
3573 if {[catch {exec sh -c $cmd >$fname &} err]} {
3574 error_popup "Error writing commit: $err"
3576 catch {destroy $wrcomtop}
3583 catch {destroy $wrcomtop}
3587 proc listrefs {id} {
3588 global idtags idheads idotherrefs
3591 if {[info exists idtags($id)]} {
3595 if {[info exists idheads($id)]} {
3599 if {[info exists idotherrefs($id)]} {
3600 set z $idotherrefs($id)
3602 return [list $x $y $z]
3605 proc rereadrefs {} {
3606 global idtags idheads idotherrefs
3607 global tagids headids otherrefids
3609 set refids [concat [array names idtags] \
3610 [array names idheads] [array names idotherrefs]]
3611 foreach id $refids {
3612 if {![info exists ref($id)]} {
3613 set ref($id) [listrefs $id]
3617 set refids [lsort -unique [concat $refids [array names idtags] \
3618 [array names idheads] [array names idotherrefs]]]
3619 foreach id $refids {
3620 set v [listrefs $id]
3621 if {![info exists ref($id)] || $ref($id) != $v} {
3627 proc updatecommits {rargs} {
3628 global commitlisted commfd phase
3629 global startmsecs nextupdate ncmupdate
3630 global idtags idheads idotherrefs
3633 global canv mainfont
3634 global oldcommits commits
3635 global parents nchildren children ncleft
3637 set old_args $parsed_args
3640 if {$phase == "getcommits" || $phase == "incrdraw"} {
3641 # havent read all the old commits, just start again from scratch
3645 foreach v {children nchildren parents commitlisted commitinfo
3646 selectedline matchinglines treediffs
3647 mergefilelist currentid rowtextx} {
3652 if {$phase == "incrdraw"} {
3654 $canv create text 3 3 -anchor nw -text "Reading commits..." \
3655 -font $mainfont -tags textitems
3656 set phase getcommits
3658 start_rev_list $parsed_args
3662 foreach id $old_args {
3663 if {![regexp {^[0-9a-f]{40}$} $id]} continue
3664 if {[info exists oldref($id)]} continue
3666 lappend ignoreold "^$id"
3668 foreach id $parsed_args {
3669 if {![regexp {^[0-9a-f]{40}$} $id]} continue
3670 if {[info exists ref($id)]} continue
3672 lappend ignorenew "^$id"
3675 foreach a $old_args {
3676 if {![info exists ref($a)]} {
3677 lappend ignorenew $a
3681 set phase updatecommits
3682 set oldcommits $commits
3684 set removed_commits [split [eval exec git-rev-list $ignorenew] "\n" ]
3685 if {[llength $removed_commits] > 0} {
3687 foreach c $removed_commits {
3688 set i [lsearch -exact $oldcommits $c]
3690 set oldcommits [lreplace $oldcommits $i $i]
3691 unset commitlisted($c)
3692 foreach p $parents($c) {
3693 if {[info exists nchildren($p)]} {
3694 set j [lsearch -exact $children($p) $c]
3696 set children($p) [lreplace $children($p) $j $j]
3697 incr nchildren($p) -1
3703 set phase removecommits
3707 foreach a $parsed_args {
3708 if {![info exists oldref($a)]} {
3714 start_rev_list [concat $ignoreold $args]
3717 proc showtag {tag isnew} {
3718 global ctext cflist tagcontents tagids linknum
3721 addtohistory [list showtag $tag 0]
3723 $ctext conf -state normal
3724 $ctext delete 0.0 end
3726 if {[info exists tagcontents($tag)]} {
3727 set text $tagcontents($tag)
3729 set text "Tag: $tag\nId: $tagids($tag)"
3731 appendwithlinks $text
3732 $ctext conf -state disabled
3733 $cflist delete 0 end
3743 global maxwidth maxgraphpct diffopts findmergefiles
3744 global oldprefs prefstop
3748 if {[winfo exists $top]} {
3752 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3753 set oldprefs($v) [set $v]
3756 wm title $top "Gitk preferences"
3757 label $top.ldisp -text "Commit list display options"
3758 grid $top.ldisp - -sticky w -pady 10
3759 label $top.spacer -text " "
3760 label $top.maxwidthl -text "Maximum graph width (lines)" \
3762 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
3763 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
3764 label $top.maxpctl -text "Maximum graph width (% of pane)" \
3766 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
3767 grid x $top.maxpctl $top.maxpct -sticky w
3768 checkbutton $top.findm -variable findmergefiles
3769 label $top.findml -text "Include merges for \"Find\" in \"Files\"" \
3771 grid $top.findm $top.findml - -sticky w
3772 label $top.ddisp -text "Diff display options"
3773 grid $top.ddisp - -sticky w -pady 10
3774 label $top.diffoptl -text "Options for diff program" \
3776 entry $top.diffopt -width 20 -textvariable diffopts
3777 grid x $top.diffoptl $top.diffopt -sticky w
3779 button $top.buts.ok -text "OK" -command prefsok
3780 button $top.buts.can -text "Cancel" -command prefscan
3781 grid $top.buts.ok $top.buts.can
3782 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3783 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3784 grid $top.buts - - -pady 10 -sticky ew
3788 global maxwidth maxgraphpct diffopts findmergefiles
3789 global oldprefs prefstop
3791 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3792 set $v $oldprefs($v)
3794 catch {destroy $prefstop}
3799 global maxwidth maxgraphpct
3800 global oldprefs prefstop
3802 catch {destroy $prefstop}
3804 if {$maxwidth != $oldprefs(maxwidth)
3805 || $maxgraphpct != $oldprefs(maxgraphpct)} {
3810 proc formatdate {d} {
3811 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
3816 set diffopts "-U 5 -p"
3817 set wrcomcmd "git-diff-tree --stdin -p --pretty"
3821 set gitencoding [exec git-repo-config --get i18n.commitencoding]
3823 if {$gitencoding == ""} {
3824 set gitencoding "utf-8"
3827 set mainfont {Helvetica 9}
3828 set textfont {Courier 9}
3829 set findmergefiles 0
3835 set colors {green red blue magenta darkgrey brown orange}
3837 catch {source ~/.gitk}
3839 set namefont $mainfont
3841 font create optionfont -family sans-serif -size -12
3845 switch -regexp -- $arg {
3847 "^-d" { set datemode 1 }
3848 "^-r" { set revlistorder 1 }
3850 lappend revtreeargs $arg
3863 makewindow $revtreeargs
3865 getcommits $revtreeargs