package require Tk

proc hasworktree {} {

return [expr {[exec git rev-parse --is-bare-repository] == "false" &&

[exec git rev-parse --is-inside-git-dir] == "false"}]

}

proc reponame {} {

global gitdir

set n [file normalize $gitdir]

if {[string match "*/.git" $n]} {

set n [string range $n 0 end-5]

}

return [file tail $n]

}

proc gitworktree {} {

variable _gitworktree

if {[info exists _gitworktree]} {

return $_gitworktree

}

# v1.7.0 introduced --show-toplevel to return the canonical work-tree

if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {

# try to set work tree from environment, core.worktree or use

# cdup to obtain a relative path to the top of the worktree. If

# run from the top, the ./ prefix ensures normalize expands pwd.

if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {

if {[catch {set _gitworktree [exec git config --get core.worktree]}]} {

set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]

}

}

}

return $_gitworktree

}

proc run args {

global isonrunq runq currunq

set script $args

if {[info exists isonrunq($script)]} return

if {$runq eq {} && ![info exists currunq]} {

after idle dorunq

}

lappend runq [list {} $script]

set isonrunq($script) 1

}

proc filerun {fd script} {

fileevent $fd readable [list filereadable $fd $script]

}

proc filereadable {fd script} {

global runq currunq

fileevent $fd readable {}

if {$runq eq {} && ![info exists currunq]} {

after idle dorunq

}

lappend runq [list $fd $script]

}

proc nukefile {fd} {

global runq

for {set i 0} {$i < [llength $runq]} {} {

if {[lindex $runq $i 0] eq $fd} {

set runq [lreplace $runq $i $i]

} else {

incr i

}

}

}

proc dorunq {} {

global isonrunq runq currunq

set tstart [clock clicks -milliseconds]

set t0 $tstart

while {[llength $runq] > 0} {

set fd [lindex $runq 0 0]

set script [lindex $runq 0 1]

set currunq [lindex $runq 0]

set runq [lrange $runq 1 end]

set repeat [eval $script]

unset currunq

set t1 [clock clicks -milliseconds]

set t [expr {$t1 - $t0}]

if {$repeat ne {} && $repeat} {

if {$fd eq {} || $repeat == 2} {

# script returns 1 if it wants to be readded

# file readers return 2 if they could do more straight away

lappend runq [list $fd $script]

} else {

fileevent $fd readable [list filereadable $fd $script]

}

} elseif {$fd eq {}} {

unset isonrunq($script)

}

set t0 $t1

if {$t1 - $tstart >= 80} break

}

if {$runq ne {}} {

after idle dorunq

}

}

proc reg_instance {fd} {

global commfd leftover loginstance

set i [incr loginstance]

set commfd($i) $fd

set leftover($i) {}

return $i

}

proc unmerged_files {files} {

global nr_unmerged

# find the list of unmerged files

set mlist {}

set nr_unmerged 0

if {[catch {

set fd [open "| git ls-files -u" r]

} err]} {

show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"

exit 1

}

while {[gets $fd line] >= 0} {

set i [string first "\t" $line]

if {$i < 0} continue

set fname [string range $line [expr {$i+1}] end]

if {[lsearch -exact $mlist $fname] >= 0} continue

incr nr_unmerged

if {$files eq {} || [path_filter $files $fname]} {

lappend mlist $fname

}

}

catch {close $fd}

return $mlist

}

proc parseviewargs {n arglist} {

global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env

global vinlinediff

global worddiff git_version

set vdatemode($n) 0

set vmergeonly($n) 0

set vinlinediff($n) 0

set glflags {}

set diffargs {}

set nextisval 0

set revargs {}

set origargs $arglist

set allknown 1

set filtered 0

set i -1

foreach arg $arglist {

incr i

if {$nextisval} {

lappend glflags $arg

set nextisval 0

continue

}

switch -glob -- $arg {

"-d" -

"--date-order" {

set vdatemode($n) 1

# remove from origargs in case we hit an unknown option

set origargs [lreplace $origargs $i $i]

incr i -1

}

"-[puabwcrRBMC]" -

"--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -

"--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -

"--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -

"-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -

"--ignore-space-change" - "-U*" - "--unified=*" {

# These request or affect diff output, which we don't want.

# Some could be used to set our defaults for diff display.

lappend diffargs $arg

}

"--raw" - "--patch-with-raw" - "--patch-with-stat" -

"--name-only" - "--name-status" - "--color" -

"--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -

"--cc" - "-z" - "--header" - "--parents" - "--boundary" -

"--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -

"--timestamp" - "relative-date" - "--date=*" - "--stdin" -

"--objects" - "--objects-edge" - "--reverse" {

# These cause our parsing of git log's output to fail, or else

# they're options we want to set ourselves, so ignore them.

}

"--color-words*" - "--word-diff=color" {

# These trigger a word diff in the console interface,

# so help the user by enabling our own support

if {[package vcompare $git_version "1.7.2"] >= 0} {

set worddiff [mc "Color words"]

}

}

"--word-diff*" {

if {[package vcompare $git_version "1.7.2"] >= 0} {

set worddiff [mc "Markup words"]

}

}

"--stat=*" - "--numstat" - "--shortstat" - "--summary" -

"--check" - "--exit-code" - "--quiet" - "--topo-order" -

"--full-history" - "--dense" - "--sparse" -

"--follow" - "--left-right" - "--encoding=*" {

# These are harmless, and some are even useful

lappend glflags $arg

}

"--diff-filter=*" - "--no-merges" - "--unpacked" -

"--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -

"--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -

"--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -

"--remove-empty" - "--first-parent" - "--cherry-pick" -

"-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -

"--simplify-by-decoration" {

# These mean that we get a subset of the commits

set filtered 1

lappend glflags $arg

}

"-L*" {

# Line-log with 'stuck' argument (unstuck form is

# not supported)

set filtered 1

set vinlinediff($n) 1

set allknown 0

lappend glflags $arg

}

"-n" {

# This appears to be the only one that has a value as a

# separate word following it

set filtered 1

set nextisval 1

lappend glflags $arg

}

"--not" - "--all" {

lappend revargs $arg

}

"--merge" {

set vmergeonly($n) 1

# git rev-parse doesn't understand --merge

lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD

}

"--no-replace-objects" {

set env(GIT_NO_REPLACE_OBJECTS) "1"

}

"-*" {

# Other flag arguments including -<n>

if {[string is digit -strict [string range $arg 1 end]]} {

set filtered 1

} else {

# a flag argument that we don't recognize;

# that means we can't optimize

set allknown 0

}

lappend glflags $arg

}

default {

# Non-flag arguments specify commits or ranges of commits

if {[string match "*...*" $arg]} {

lappend revargs --gitk-symmetric-diff-marker

}

lappend revargs $arg

}

}

}

set vdflags($n) $diffargs

set vflags($n) $glflags

set vrevs($n) $revargs

set vfiltered($n) $filtered

set vorigargs($n) $origargs

return $allknown

}

proc parseviewrevs {view revs} {

global vposids vnegids

if {$revs eq {}} {

set revs HEAD

} elseif {[lsearch -exact $revs --all] >= 0} {

lappend revs HEAD

}

if {[catch {set ids [eval exec git rev-parse $revs]} err]} {

# we get stdout followed by stderr in $err

# for an unknown rev, git rev-parse echoes it and then errors out

set errlines [split $err "\n"]

set badrev {}

for {set l 0} {$l < [llength $errlines]} {incr l} {

set line [lindex $errlines $l]

if {!([string length $line] == 40 && [string is xdigit $line])} {

if {[string match "fatal:*" $line]} {

if {[string match "fatal: ambiguous argument*" $line]

&& $badrev ne {}} {

if {[llength $badrev] == 1} {

set err "unknown revision $badrev"

} else {

set err "unknown revisions: [join $badrev ", "]"

}

} else {

set err [join [lrange $errlines $l end] "\n"]

}

break

}

lappend badrev $line

}

}

error_popup "[mc "Error parsing revisions:"] $err"

return {}

}

set ret {}

set pos {}

set neg {}

set sdm 0

foreach id [split $ids "\n"] {

if {$id eq "--gitk-symmetric-diff-marker"} {

set sdm 4

} elseif {[string match "^*" $id]} {

if {$sdm != 1} {

lappend ret $id

if {$sdm == 3} {

set sdm 0

}

}

lappend neg [string range $id 1 end]

} else {

if {$sdm != 2} {

lappend ret $id

} else {

lset ret end $id...[lindex $ret end]

}

lappend pos $id

}

incr sdm -1

}

set vposids($view) $pos

set vnegids($view) $neg

return $ret

}

proc escape_filter_paths {paths} {

set escaped [list]

foreach path $paths {

lappend escaped [string map {\\ \\\\ "\ " "\\\ "} $path]

}

return $escaped

}

proc start_rev_list {view} {

global startmsecs commitidx viewcomplete curview

global tclencoding

global viewargs viewargscmd viewfiles vfilelimit

global showlocalchanges

global viewactive viewinstances vmergeonly

global mainheadid viewmainheadid viewmainheadid_orig

global vcanopt vflags vrevs vorigargs

global show_notes

set startmsecs [clock clicks -milliseconds]

set commitidx($view) 0

# these are set this way for the error exits

set viewcomplete($view) 1

set viewactive($view) 0

varcinit $view

set args $viewargs($view)

if {$viewargscmd($view) ne {}} {

if {[catch {

set str [exec sh -c $viewargscmd($view)]

} err]} {

error_popup "[mc "Error executing --argscmd command:"] $err"

return 0

}

set args [concat $args [split $str "\n"]]

}

set vcanopt($view) [parseviewargs $view $args]

set files $viewfiles($view)

if {$vmergeonly($view)} {

set files [unmerged_files $files]

if {$files eq {}} {

global nr_unmerged

if {$nr_unmerged == 0} {

error_popup [mc "No files selected: --merge specified but\

no files are unmerged."]

} else {

error_popup [mc "No files selected: --merge specified but\

no unmerged files are within file limit."]

}

return 0

}

}

set vfilelimit($view) $files

if {$vcanopt($view)} {

set revs [parseviewrevs $view $vrevs($view)]

if {$revs eq {}} {

return 0

}

set args $vflags($view)

} else {

set revs {}

set args $vorigargs($view)

}

if {[catch {

set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \

--parents --boundary $args --stdin \

"<<[join [concat $revs "--" \

[escape_filter_paths $files]] "\\n"]"] r]

} err]} {

error_popup "[mc "Error executing git log:"] $err"

return 0

}

set i [reg_instance $fd]

set viewinstances($view) [list $i]

set viewmainheadid($view) $mainheadid

set viewmainheadid_orig($view) $mainheadid

if {$files ne {} && $mainheadid ne {}} {

get_viewmainhead $view

}

if {$showlocalchanges && $viewmainheadid($view) ne {}} {

interestedin $viewmainheadid($view) dodiffindex

}

fconfigure $fd -blocking 0 -translation lf -eofchar {}

if {$tclencoding != {}} {

fconfigure $fd -encoding $tclencoding

}

filerun $fd [list getcommitlines $fd $i $view 0]

nowbusy $view [mc "Reading"]

set viewcomplete($view) 0

set viewactive($view) 1

return 1

}

proc stop_instance {inst} {

global commfd leftover

set fd $commfd($inst)

catch {

set pid [pid $fd]

if {$::tcl_platform(platform) eq {windows}} {

exec taskkill /pid $pid

} else {

exec kill $pid

}

}

catch {close $fd}

nukefile $fd

unset commfd($inst)

unset leftover($inst)

}

proc stop_backends {} {

global commfd

foreach inst [array names commfd] {

stop_instance $inst

}

}

proc stop_rev_list {view} {

global viewinstances

foreach inst $viewinstances($view) {

stop_instance $inst

}

set viewinstances($view) {}

}

proc reset_pending_select {selid} {

global pending_select mainheadid selectheadid

if {$selid ne {}} {

set pending_select $selid

} elseif {$selectheadid ne {}} {

set pending_select $selectheadid

} else {

set pending_select $mainheadid

}

}

proc getcommits {selid} {

global canv curview need_redisplay viewactive

initlayout

if {[start_rev_list $curview]} {

reset_pending_select $selid

show_status [mc "Reading commits..."]

set need_redisplay 1

} else {

show_status [mc "No commits selected"]

}

}

proc updatecommits {} {

global curview vcanopt vorigargs vfilelimit viewinstances

global viewactive viewcomplete tclencoding

global startmsecs showneartags showlocalchanges

global mainheadid viewmainheadid viewmainheadid_orig pending_select

global hasworktree

global varcid vposids vnegids vflags vrevs

global show_notes

set hasworktree [hasworktree]

rereadrefs

set view $curview

if {$mainheadid ne $viewmainheadid_orig($view)} {

if {$showlocalchanges} {

dohidelocalchanges

}

set viewmainheadid($view) $mainheadid

set viewmainheadid_orig($view) $mainheadid

if {$vfilelimit($view) ne {}} {

get_viewmainhead $view

}

}

if {$showlocalchanges} {

doshowlocalchanges

}

if {$vcanopt($view)} {

set oldpos $vposids($view)

set oldneg $vnegids($view)

set revs [parseviewrevs $view $vrevs($view)]

if {$revs eq {}} {

return

}

# note: getting the delta when negative refs change is hard,

# and could require multiple git log invocations, so in that

# case we ask git log for all the commits (not just the delta)

if {$oldneg eq $vnegids($view)} {

set newrevs {}

set npos 0

# take out positive refs that we asked for before or

# that we have already seen

foreach rev $revs {

if {[string length $rev] == 40} {

if {[lsearch -exact $oldpos $rev] < 0

&& ![info exists varcid($view,$rev)]} {

lappend newrevs $rev

incr npos

}

} else {

lappend $newrevs $rev

}

}

if {$npos == 0} return

set revs $newrevs

set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]

}

set args $vflags($view)

foreach r $oldpos {

lappend revs "^$r"

}

} else {

set revs {}

set args $vorigargs($view)

}

if {[catch {

set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \

--parents --boundary $args --stdin \

"<<[join [concat $revs "--" \

$vfilelimit($view)]] "\\n"]"] r]

} err]} {

error_popup "[mc "Error executing git log:"] $err"

return

}

if {$viewactive($view) == 0} {

set startmsecs [clock clicks -milliseconds]

}

set i [reg_instance $fd]

lappend viewinstances($view) $i

fconfigure $fd -blocking 0 -translation lf -eofchar {}

if {$tclencoding != {}} {

fconfigure $fd -encoding $tclencoding

}

filerun $fd [list getcommitlines $fd $i $view 1]

incr viewactive($view)

set viewcomplete($view) 0

reset_pending_select {}

nowbusy $view [mc "Reading"]

if {$showneartags} {

getallcommits

}

}

proc reloadcommits {} {

global curview viewcomplete selectedline currentid thickerline

global showneartags treediffs commitinterest cached_commitrow

global targetid commitinfo

set selid {}

if {$selectedline ne {}} {

set selid $currentid

}

if {!$viewcomplete($curview)} {

stop_rev_list $curview

}

resetvarcs $curview

set selectedline {}

unset -nocomplain currentid

unset -nocomplain thickerline

unset -nocomplain treediffs

readrefs

changedrefs

if {$showneartags} {

getallcommits

}

clear_display

unset -nocomplain commitinfo

unset -nocomplain commitinterest

unset -nocomplain cached_commitrow

unset -nocomplain targetid

setcanvscroll

getcommits $selid

return 0

}

proc strrep {n} {

if {$n < 16} {

return [format "%x" $n]

} elseif {$n < 256} {

return [format "x%.2x" $n]

} elseif {$n < 65536} {

return [format "y%.4x" $n]

}

return [format "z%.8x" $n]

}

proc varcinit {view} {

global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow

global vtokmod varcmod vrowmod varcix vlastins

set varcstart($view) {{}}

set vupptr($view) {0}

set vdownptr($view) {0}

set vleftptr($view) {0}

set vbackptr($view) {0}

set varctok($view) {{}}

set varcrow($view) {{}}

set vtokmod($view) {}

set varcmod($view) 0

set vrowmod($view) 0

set varcix($view) {{}}

set vlastins($view) {0}

}

proc resetvarcs {view} {

global varcid varccommits parents children vseedcount ordertok

global vshortids

foreach vid [array names varcid $view,*] {

unset varcid($vid)

unset children($vid)

unset parents($vid)

}

foreach vid [array names vshortids $view,*] {

unset vshortids($vid)

}

# some commits might have children but haven't been seen yet

foreach vid [array names children $view,*] {

unset children($vid)

}

foreach va [array names varccommits $view,*] {

unset varccommits($va)

}

foreach vd [array names vseedcount $view,*] {

unset vseedcount($vd)

}

unset -nocomplain ordertok

}

proc seeds {v} {

global vdownptr vleftptr varcstart

set ret {}

set a [lindex $vdownptr($v) 0]

while {$a != 0} {

lappend ret [lindex $varcstart($v) $a]

set a [lindex $vleftptr($v) $a]

}

return $ret

}

proc newvarc {view id} {

global varcid varctok parents children vdatemode

global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart

global commitdata commitinfo vseedcount varccommits vlastins

set a [llength $varctok($view)]

set vid $view,$id

if {[llength $children($vid)] == 0 || $vdatemode($view)} {

if {![info exists commitinfo($id)]} {

parsecommit $id $commitdata($id) 1

}

set cdate [lindex [lindex $commitinfo($id) 4] 0]

if {![string is integer -strict $cdate]} {

set cdate 0

}

if {![info exists vseedcount($view,$cdate)]} {

set vseedcount($view,$cdate) -1

}

set c [incr vseedcount($view,$cdate)]

set cdate [expr {$cdate ^ 0xffffffff}]

set tok "s[strrep $cdate][strrep $c]"

} else {

set tok {}

}

set ka 0

if {[llength $children($vid)] > 0} {

set kid [lindex $children($vid) end]

set k $varcid($view,$kid)

if {[string compare [lindex $varctok($view) $k] $tok] > 0} {

set ki $kid

set ka $k

set tok [lindex $varctok($view) $k]

}

}

if {$ka != 0} {

set i [lsearch -exact $parents($view,$ki) $id]

set j [expr {[llength $parents($view,$ki)] - 1 - $i}]

append tok [strrep $j]

}

set c [lindex $vlastins($view) $ka]

if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {

set c $ka

set b [lindex $vdownptr($view) $ka]

} else {

set b [lindex $vleftptr($view) $c]

}

while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {

set c $b

set b [lindex $vleftptr($view) $c]

}

if {$c == $ka} {

lset vdownptr($view) $ka $a

lappend vbackptr($view) 0

} else {

lset vleftptr($view) $c $a

lappend vbackptr($view) $c

}

lset vlastins($view) $ka $a

lappend vupptr($view) $ka

lappend vleftptr($view) $b

if {$b != 0} {

lset vbackptr($view) $b $a

}

lappend varctok($view) $tok

lappend varcstart($view) $id

lappend vdownptr($view) 0

lappend varcrow($view) {}

lappend varcix($view) {}

set varccommits($view,$a) {}

lappend vlastins($view) 0

return $a

}

proc splitvarc {p v} {

global varcid varcstart varccommits varctok vtokmod

global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins

set oa $varcid($v,$p)

set otok [lindex $varctok($v) $oa]

set ac $varccommits($v,$oa)

set i [lsearch -exact $varccommits($v,$oa) $p]

if {$i <= 0} return

set na [llength $varctok($v)]

# "%" sorts before "0"...

set tok "$otok%[strrep $i]"

lappend varctok($v) $tok

lappend varcrow($v) {}

lappend varcix($v) {}

set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]

set varccommits($v,$na) [lrange $ac $i end]

lappend varcstart($v) $p

foreach id $varccommits($v,$na) {

set varcid($v,$id) $na

}

lappend vdownptr($v) [lindex $vdownptr($v) $oa]

lappend vlastins($v) [lindex $vlastins($v) $oa]

lset vdownptr($v) $oa $na

lset vlastins($v) $oa 0

lappend vupptr($v) $oa

lappend vleftptr($v) 0

lappend vbackptr($v) 0

for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {

lset vupptr($v) $b $na

}

if {[string compare $otok $vtokmod($v)] <= 0} {

modify_arc $v $oa

}

}

proc renumbervarc {a v} {

global parents children varctok varcstart varccommits

global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode

set t1 [clock clicks -milliseconds]

set todo {}

set isrelated($a) 1

set kidchanged($a) 1

set ntot 0

while {$a != 0} {

if {[info exists isrelated($a)]} {

lappend todo $a

set id [lindex $varccommits($v,$a) end]

foreach p $parents($v,$id) {

if {[info exists varcid($v,$p)]} {

set isrelated($varcid($v,$p)) 1

}

}

}

incr ntot

set b [lindex $vdownptr($v) $a]

if {$b == 0} {

while {$a != 0} {

set b [lindex $vleftptr($v) $a]

if {$b != 0} break

set a [lindex $vupptr($v) $a]

}

}

set a $b

}

foreach a $todo {

if {![info exists kidchanged($a)]} continue

set id [lindex $varcstart($v) $a]

if {[llength $children($v,$id)] > 1} {

set children($v,$id) [lsort -command [list vtokcmp $v] \

$children($v,$id)]

}

set oldtok [lindex $varctok($v) $a]

if {!$vdatemode($v)} {

set tok {}

} else {

set tok $oldtok

}

set ka 0

set kid [last_real_child $v,$id]

if {$kid ne {}} {

set k $varcid($v,$kid)

if {[string compare [lindex $varctok($v) $k] $tok] > 0} {

set ki $kid

set ka $k

set tok [lindex $varctok($v) $k]

}

}

if {$ka != 0} {

set i [lsearch -exact $parents($v,$ki) $id]

set j [expr {[llength $parents($v,$ki)] - 1 - $i}]

append tok [strrep $j]

}

if {$tok eq $oldtok} {

continue

}

set id [lindex $varccommits($v,$a) end]

foreach p $parents($v,$id) {

if {[info exists varcid($v,$p)]} {

set kidchanged($varcid($v,$p)) 1

} else {

set sortkids($p) 1

}

}

lset varctok($v) $a $tok

set b [lindex $vupptr($v) $a]

if {$b != $ka} {

if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {

modify_arc $v $ka

}

if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {

modify_arc $v $b

}

set c [lindex $vbackptr($v) $a]

set d [lindex $vleftptr($v) $a]

if {$c == 0} {

lset vdownptr($v) $b $d

} else {

lset vleftptr($v) $c $d

}

if {$d != 0} {

lset vbackptr($v) $d $c

}

if {[lindex $vlastins($v) $b] == $a} {

lset vlastins($v) $b $c

}

lset vupptr($v) $a $ka

set c [lindex $vlastins($v) $ka]

if {$c == 0 || \

[string compare $tok [lindex $varctok($v) $c]] < 0} {

set c $ka

set b [lindex $vdownptr($v) $ka]

} else {

set b [lindex $vleftptr($v) $c]

}

while {$b != 0 && \

[string compare $tok [lindex $varctok($v) $b]] >= 0} {

set c $b

set b [lindex $vleftptr($v) $c]

}

if {$c == $ka} {

lset vdownptr($v) $ka $a

lset vbackptr($v) $a 0

} else {

lset vleftptr($v) $c $a

lset vbackptr($v) $a $c

}

lset vleftptr($v) $a $b

if {$b != 0} {

lset vbackptr($v) $b $a

}

lset vlastins($v) $ka $a

}

}

foreach id [array names sortkids] {

if {[llength $children($v,$id)] > 1} {

set children($v,$id) [lsort -command [list vtokcmp $v] \

$children($v,$id)]

}

}

set t2 [clock clicks -milliseconds]

#puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"

}

proc fix_reversal {p a v} {

global varcid varcstart varctok vupptr

set pa $varcid($v,$p)

if {$p ne [lindex $varcstart($v) $pa]} {

splitvarc $p $v

set pa $varcid($v,$p)

}

# seeds always need to be renumbered

if {[lindex $vupptr($v) $pa] == 0 ||

[string compare [lindex $varctok($v) $a] \

[lindex $varctok($v) $pa]] > 0} {

renumbervarc $pa $v

}

}

proc insertrow {id p v} {

global cmitlisted children parents varcid varctok vtokmod

global varccommits ordertok commitidx numcommits curview

global targetid targetrow vshortids

readcommit $id

set vid $v,$id

set cmitlisted($vid) 1

set children($vid) {}

set parents($vid) [list $p]

set a [newvarc $v $id]

set varcid($vid) $a

lappend vshortids($v,[string range $id 0 3]) $id

if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {

modify_arc $v $a

}

lappend varccommits($v,$a) $id

set vp $v,$p

if {[llength [lappend children($vp) $id]] > 1} {

set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]

unset -nocomplain ordertok

}

fix_reversal $p $a $v

incr commitidx($v)

if {$v == $curview} {

set numcommits $commitidx($v)

setcanvscroll

if {[info exists targetid]} {

if {![comes_before $targetid $p]} {

incr targetrow

}

}