@ -12,30 +12,31 @@ exec wish "$0" -- "${1+$@}"
@@ -12,30 +12,31 @@ exec wish "$0" -- "${1+$@}"
proc getcommits {rargs} {
global commits commfd phase canv mainfont
global startmsecs nextupdate
global ctext maincursor textcursor nlines
global ctext maincursor textcursor leftover
set commits {}
set phase getcommits
set startmsecs [clock clicks -milliseconds]
set nextupdate [expr $startmsecs + 100]
if [catch {
set parse_args [concat --default HEAD --merge-order $rargs]
set parse_args [concat --default HEAD $rargs]
set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
}] {
# if git-rev-parse failed for some reason...
if {$rargs == {}} {
set rargs HEAD
}
set parsed_args [concat --merge-order $rargs]
set parsed_args $rargs
}
if [catch {
set commfd [open "|git-rev-list $parsed_args" r]
set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
} err] {
puts stderr "Error executing git-rev-list: $err"
exit 1
}
set nlines 0
fconfigure $commfd -blocking 0
fileevent $commfd readable "getcommitline $commfd"
set leftover {}
fconfigure $commfd -blocking 0 -translation binary
fileevent $commfd readable "getcommitlines $commfd"
$canv delete all
$canv create text 3 3 -anchor nw -text "Reading commits..." \
-font $mainfont -tags textitems
@ -43,13 +44,13 @@ proc getcommits {rargs} {
@@ -43,13 +44,13 @@ proc getcommits {rargs} {
$ctext config -cursor watch
}
proc getcommitline {commfd} {
proc getcommitlines {commfd} {
global commits parents cdate children nchildren
global commitlisted phase commitinfo nextupdate
global stopped redisplaying nlines
global stopped redisplaying leftover
set n [gets $commfd line]
if {$n < 0} {
set stuff [read $commfd]
if {$stuff == {}} {
if {![eof $commfd]} return
# this works around what is apparently a bug in Tcl...
fconfigure $commfd -blocking 1
@ -68,35 +69,41 @@ to allow selection of commits to be displayed.)}
@@ -68,35 +69,41 @@ to allow selection of commits to be displayed.)}
error_popup $err
exit 1
}
incr nlines
if {![regexp {^[0-9a-f]{40}$} $line id]} {
error_popup "Can't parse git-rev-list output: {$line}"
exit 1
}
lappend commits $id
set commitlisted($id) 1
if {![info exists commitinfo($id)]} {
readcommit $id
}
foreach p $parents($id) {
if {[info exists commitlisted($p)]} {
puts "oops, parent $p before child $id"
set start 0
while 1 {
set i [string first "\0" $stuff $start]
if {$i < 0} {
set leftover [string range $stuff $start end]
return
}
}
drawcommit $id
if {[clock clicks -milliseconds] >= $nextupdate} {
doupdate
}
while {$redisplaying} {
set redisplaying 0
if {$stopped == 1} {
set stopped 0
set phase "getcommits"
foreach id $commits {
drawcommit $id
if {$stopped} break
if {[clock clicks -milliseconds] >= $nextupdate} {
doupdate
set cmit [string range $stuff $start [expr {$i - 1}]]
if {$start == 0} {
set cmit "$leftover$cmit"
}
set start [expr {$i + 1}]
if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
error_popup "Can't parse git-rev-list output: {$cmit}"
exit 1
}
set cmit [string range $cmit 41 end]
lappend commits $id
set commitlisted($id) 1
parsecommit $id $cmit 1
drawcommit $id
if {[clock clicks -milliseconds] >= $nextupdate} {
doupdate
}
while {$redisplaying} {
set redisplaying 0
if {$stopped == 1} {
set stopped 0
set phase "getcommits"
foreach id $commits {
drawcommit $id
if {$stopped} break
if {[clock clicks -milliseconds] >= $nextupdate} {
doupdate
}
}
}
}
@ -109,12 +116,16 @@ proc doupdate {} {
@@ -109,12 +116,16 @@ proc doupdate {} {
incr nextupdate 100
fileevent $commfd readable {}
update
fileevent $commfd readable "getcommitline $commfd"
fileevent $commfd readable "getcommitlines $commfd"
}
proc readcommit {id} {
if [catch {set contents [exec git-cat-file commit $id]}] return
parsecommit $id $contents 0
}
proc parsecommit {id contents listed} {
global commitinfo children nchildren parents nparents cdate ncleft
global noreadobj
set inhdr 1
set comment {}
@ -130,13 +141,6 @@ proc readcommit {id} {
@@ -130,13 +141,6 @@ proc readcommit {id} {
}
set parents($id) {}
set nparents($id) 0
if {$noreadobj} {
if [catch {set contents [exec git-cat-file commit $id]}] return
} else {
if [catch {set x [readobj $id]}] return
if {[lindex $x 0] != "commit"} return
set contents [lindex $x 1]
}
foreach line [split $contents "\n"] {
if {$inhdr} {
if {$line == {}} {
@ -153,7 +157,7 @@ proc readcommit {id} {
@@ -153,7 +157,7 @@ proc readcommit {id} {
lappend parents($id) $p
incr nparents($id)
# sometimes we get a commit that lists a parent twice...
if {[lsearch -exact $children($p) $id] < 0} {
if {$listed && [lsearch -exact $children($p) $id] < 0} {
lappend children($p) $id
incr nchildren($p)
incr ncleft($p)
@ -545,7 +549,7 @@ proc assigncolor {id} {
@@ -545,7 +549,7 @@ proc assigncolor {id} {
global parents nparents children nchildren
if [info exists colormap($id)] return
set ncolors [llength $colors]
if {$nparents($id) == 1 && $nchildren($id) == 1} {
if {$nparents($id) <= 1 && $nchildren($id) == 1} {
set child [lindex $children($id) 0]
if {[info exists colormap($child)]
&& $nparents($child) == 1} {
@ -583,7 +587,7 @@ proc assigncolor {id} {
@@ -583,7 +587,7 @@ proc assigncolor {id} {
proc initgraph {} {
global canvy canvy0 lineno numcommits lthickness nextcolor linespc
global glines
global mainline sidelines
global nchildren ncleft
allcanvs delete all
@ -592,7 +596,8 @@ proc initgraph {} {
@@ -592,7 +596,8 @@ proc initgraph {} {
set lineno -1
set numcommits 0
set lthickness [expr {int($linespc / 9) + 1}]
catch {unset glines}
catch {unset mainline}
catch {unset sidelines}
foreach id [array names nchildren] {
set ncleft($id) $nchildren($id)
}
@ -610,12 +615,11 @@ proc bindline {t id} {
@@ -610,12 +615,11 @@ proc bindline {t id} {
proc drawcommitline {level} {
global parents children nparents nchildren todo
global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
global datemode cdate
global lineid linehtag linentag linedtag commitinfo
global colormap numcommits currentparents dupparents
global oldlevel oldnlines oldtodo
global idtags idline idheads
global lineno lthickness glines
global lineno lthickness mainline sidelines
global commitlisted
incr numcommits
@ -631,6 +635,7 @@ proc drawcommitline {level} {
@@ -631,6 +635,7 @@ proc drawcommitline {level} {
set nparents($id) 0
}
}
assigncolor $id
set currentparents {}
set dupparents {}
if {[info exists commitlisted($id)] && [info exists parents($id)]} {
@ -648,21 +653,31 @@ proc drawcommitline {level} {
@@ -648,21 +653,31 @@ proc drawcommitline {level} {
set canvy [expr $canvy + $linespc]
allcanvs conf -scrollregion \
[list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
if {[info exists glines($id)]} {
lappend glines($id) $x $y1
set t [$canv create line $glines($id) \
if {[info exists mainline($id)]} {
lappend mainline($id) $x $y1
set t [$canv create line $mainline($id) \
-width $lthickness -fill $colormap($id)]
$canv lower $t
bindline $t $id
}
if {[info exists sidelines($id)]} {
foreach ls $sidelines($id) {
set coords [lindex $ls 0]
set thick [lindex $ls 1]
set t [$canv create line $coords -fill $colormap($id) \
-width [expr {$thick * $lthickness}]]
$canv lower $t
bindline $t $id
}
}
set orad [expr {$linespc / 3}]
set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
[expr $x + $orad - 1] [expr $y1 + $orad - 1] \
-fill $ofill -outline black -width 1]
$canv raise $t
set xt [expr $canvx0 + [llength $todo] * $linespc]
if {$nparents($id) > 2} {
set xt [expr {$xt + ($nparents($id) - 2) * $linespc}]
if {[llength $currentparents] > 2} {
set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
}
set marks {}
set ntags 0
@ -718,38 +733,32 @@ proc drawcommitline {level} {
@@ -718,38 +733,32 @@ proc drawcommitline {level} {
}
proc updatetodo {level noshortcut} {
global datemode currentparents ncleft todo
global glines oldlevel oldtodo oldnlines
global canvx0 canvy linespc glines
global currentparents ncleft todo
global mainline oldlevel oldtodo oldnlines
global canvx0 canvy linespc mainline
global commitinfo
foreach p $currentparents {
if {![info exists commitinfo($p)]} {
readcommit $p
}
}
set x [expr $canvx0 + $level * $linespc]
set y [expr $canvy - $linespc]
set oldlevel $level
set oldtodo $todo
set oldnlines [llength $todo]
if {!$noshortcut && [llength $currentparents] == 1} {
set p [lindex $currentparents 0]
if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} {
assigncolor $p
set glines($p) [list $x $y]
if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
set ncleft($p) 0
set x [expr $canvx0 + $level * $linespc]
set y [expr $canvy - $linespc]
set mainline($p) [list $x $y]
set todo [lreplace $todo $level $level $p]
return 0
}
}
set oldlevel $level
set oldtodo $todo
set oldnlines [llength $todo]
set todo [lreplace $todo $level $level]
set i $level
foreach p $currentparents {
incr ncleft($p) -1
set k [lsearch -exact $todo $p]
if {$k < 0} {
assigncolor $p
set todo [linsert $todo $i $p]
incr i
}
@ -758,7 +767,7 @@ proc updatetodo {level noshortcut} {
@@ -758,7 +767,7 @@ proc updatetodo {level noshortcut} {
}
proc drawslants {} {
global canv glines canvx0 canvy linespc
global canv mainline sidelines canvx0 canvy linespc
global oldlevel oldtodo todo currentparents dupparents
global lthickness linespc canvy colormap
@ -782,33 +791,27 @@ proc drawslants {} {
@@ -782,33 +791,27 @@ proc drawslants {} {
if {[lsearch -exact $dupparents $p] >= 0} {
# draw a double-width line to indicate the doubled parent
lappend coords $xj $y2
set t [$canv create line $coords \
-width [expr 2*$lthickness] -fill $colormap($p)]
$canv lower $t
bindline $t $p
if {![info exists glines($p)]} {
set glines($p) [list $xj $y2]
lappend sidelines($p) [list $coords 2]
if {![info exists mainline($p)]} {
set mainline($p) [list $xj $y2]
}
} else {
# normal case, no parent duplicated
if {![info exists glines($p)]} {
if {![info exists mainline($p)]} {
if {$i != $j} {
lappend coords $xj $y2
}
set glines($p) $coords
set mainline($p) $coords
} else {
lappend coords $xj $y2
set t [$canv create line $coords \
-width $lthickness -fill $colormap($p)]
$canv lower $t
bindline $t $p
lappend sidelines($p) [list $coords 1]
}
}
}
} elseif {[lindex $todo $i] != $id} {
set j [lsearch -exact $todo $id]
set xj [expr {$canvx0 + $j * $linespc}]
lappend glines($id) $xi $y1 $xj $y2
lappend mainline($id) $xi $y1 $xj $y2
}
}
}
@ -849,7 +852,7 @@ proc decidenext {} {
@@ -849,7 +852,7 @@ proc decidenext {} {
if {$todo != {}} {
puts "ERROR: none of the pending commits can be done yet:"
foreach p $todo {
puts " $p"
puts " $p ($ncleft($p))"
}
}
return -1
@ -888,14 +891,12 @@ proc drawcommit {id} {
@@ -888,14 +891,12 @@ proc drawcommit {id} {
set todo $id
set startcommits $id
initgraph
assigncolor $id
drawcommitline 0
updatetodo 0 $datemode
} else {
if {$nchildren($id) == 0} {
lappend todo $id
lappend startcommits $id
assigncolor $id
}
set level [decidenext]
if {$id != [lindex $todo $level]} {
@ -1636,7 +1637,6 @@ foreach arg $argv {
@@ -1636,7 +1637,6 @@ foreach arg $argv {
}
}
set noreadobj [catch {load libreadobj.so.0.0}]
set stopped 0
set redisplaying 0
set stuffsaved 0