a0d74d160f
* git://git.kernel.org/pub/scm/gitk/gitk: gitk: Allow safely calling nukefile from a run queue handler
9997 lines
268 KiB
Tcl
9997 lines
268 KiB
Tcl
#!/bin/sh
|
|
# Tcl ignores the next line -*- tcl -*- \
|
|
exec wish "$0" -- "$@"
|
|
|
|
# Copyright © 2005-2008 Paul Mackerras. All rights reserved.
|
|
# This program is free software; it may be used, copied, modified
|
|
# and distributed under the terms of the GNU General Public Licence,
|
|
# either version 2, or (at your option) any later version.
|
|
|
|
proc gitdir {} {
|
|
global env
|
|
if {[info exists env(GIT_DIR)]} {
|
|
return $env(GIT_DIR)
|
|
} else {
|
|
return [exec git rev-parse --git-dir]
|
|
}
|
|
}
|
|
|
|
# A simple scheduler for compute-intensive stuff.
|
|
# The aim is to make sure that event handlers for GUI actions can
|
|
# run at least every 50-100 ms. Unfortunately fileevent handlers are
|
|
# run before X event handlers, so reading from a fast source can
|
|
# make the GUI completely unresponsive.
|
|
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
|
|
|
|
set vdatemode($n) 0
|
|
set vmergeonly($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
|
|
}
|
|
# These request or affect diff output, which we don't want.
|
|
# Some could be used to set our defaults for diff display.
|
|
"-[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=*" {
|
|
lappend diffargs $arg
|
|
}
|
|
# These cause our parsing of git log's output to fail, or else
|
|
# they're options we want to set ourselves, so ignore them.
|
|
"--raw" - "--patch-with-raw" - "--patch-with-stat" -
|
|
"--name-only" - "--name-status" - "--color" - "--color-words" -
|
|
"--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 are harmless, and some are even useful
|
|
"--stat=*" - "--numstat" - "--shortstat" - "--summary" -
|
|
"--check" - "--exit-code" - "--quiet" - "--topo-order" -
|
|
"--full-history" - "--dense" - "--sparse" -
|
|
"--follow" - "--left-right" - "--encoding=*" {
|
|
lappend glflags $arg
|
|
}
|
|
# These mean that we get a subset of the commits
|
|
"--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*" - "--pickaxe-all" - "--pickaxe-regex" - {
|
|
set filtered 1
|
|
lappend glflags $arg
|
|
}
|
|
# This appears to be the only one that has a value as a
|
|
# separate word following it
|
|
"-n" {
|
|
set filtered 1
|
|
set nextisval 1
|
|
lappend glflags $arg
|
|
}
|
|
"--not" {
|
|
set notflag [expr {!$notflag}]
|
|
lappend revargs $arg
|
|
}
|
|
"--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
|
|
}
|
|
# 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
|
|
}
|
|
# Non-flag arguments specify commits or ranges of commits
|
|
default {
|
|
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
|
|
}
|
|
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 "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 [lindex $ret end]...$id
|
|
}
|
|
lappend pos $id
|
|
}
|
|
incr sdm -1
|
|
}
|
|
set vposids($view) $pos
|
|
set vnegids($view) $neg
|
|
return $ret
|
|
}
|
|
|
|
# Start off a git log process and arrange to read its output
|
|
proc start_rev_list {view} {
|
|
global startmsecs commitidx viewcomplete curview
|
|
global tclencoding
|
|
global viewargs viewargscmd viewfiles vfilelimit
|
|
global showlocalchanges commitinterest
|
|
global viewactive viewinstances vmergeonly
|
|
global mainheadid
|
|
global vcanopt vflags vrevs vorigargs
|
|
|
|
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 "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 [concat $vflags($view) $revs]
|
|
} else {
|
|
set args $vorigargs($view)
|
|
}
|
|
|
|
if {[catch {
|
|
set fd [open [concat | git log --no-color -z --pretty=raw --parents \
|
|
--boundary $args "--" $files] r]
|
|
} err]} {
|
|
error_popup "[mc "Error executing git log:"] $err"
|
|
return 0
|
|
}
|
|
set i [reg_instance $fd]
|
|
set viewinstances($view) [list $i]
|
|
if {$showlocalchanges && $mainheadid ne {}} {
|
|
lappend commitinterest($mainheadid) {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 kill -f $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
|
|
|
|
if {$selid ne {}} {
|
|
set pending_select $selid
|
|
} 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 pending_select
|
|
global isworktree
|
|
global varcid vposids vnegids vflags vrevs
|
|
|
|
set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
|
|
set oldmainid $mainheadid
|
|
rereadrefs
|
|
if {$showlocalchanges} {
|
|
if {$mainheadid ne $oldmainid} {
|
|
dohidelocalchanges
|
|
}
|
|
if {[commitinview $mainheadid $curview]} {
|
|
dodiffindex
|
|
}
|
|
}
|
|
set view $curview
|
|
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 [concat $vflags($view) $revs --not $oldpos]
|
|
} else {
|
|
set args $vorigargs($view)
|
|
}
|
|
if {[catch {
|
|
set fd [open [concat | git log --no-color -z --pretty=raw --parents \
|
|
--boundary $args "--" $vfilelimit($view)] r]
|
|
} err]} {
|
|
error_popup "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 "Reading"
|
|
if {$showneartags} {
|
|
getallcommits
|
|
}
|
|
}
|
|
|
|
proc reloadcommits {} {
|
|
global curview viewcomplete selectedline currentid thickerline
|
|
global showneartags treediffs commitinterest cached_commitrow
|
|
global targetid
|
|
|
|
set selid {}
|
|
if {$selectedline ne {}} {
|
|
set selid $currentid
|
|
}
|
|
|
|
if {!$viewcomplete($curview)} {
|
|
stop_rev_list $curview
|
|
}
|
|
resetvarcs $curview
|
|
set selectedline {}
|
|
catch {unset currentid}
|
|
catch {unset thickerline}
|
|
catch {unset treediffs}
|
|
readrefs
|
|
changedrefs
|
|
if {$showneartags} {
|
|
getallcommits
|
|
}
|
|
clear_display
|
|
catch {unset commitinterest}
|
|
catch {unset cached_commitrow}
|
|
catch {unset targetid}
|
|
setcanvscroll
|
|
getcommits $selid
|
|
return 0
|
|
}
|
|
|
|
# This makes a string representation of a positive integer which
|
|
# sorts as a string in numerical order
|
|
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]
|
|
}
|
|
|
|
# Procedures used in reordering commits from git log (without
|
|
# --topo-order) into the order for display.
|
|
|
|
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
|
|
|
|
foreach vid [array names varcid $view,*] {
|
|
unset varcid($vid)
|
|
unset children($vid)
|
|
unset parents($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)
|
|
}
|
|
catch {unset ordertok}
|
|
}
|
|
|
|
# returns a list of the commits with no children
|
|
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 $commitinfo($id) 4]
|
|
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
|
|
global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
|
|
|
|
set oa $varcid($v,$p)
|
|
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 "[lindex $varctok($v) $oa]%[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
|
|
}
|
|
}
|
|
|
|
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"
|
|
}
|
|
|
|
# Fix up the graph after we have found out that in view $v,
|
|
# $p (a commit that we have already seen) is actually the parent
|
|
# of the last commit in arc $a.
|
|
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
|
|
|
|
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
|
|
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)]
|
|
catch {unset 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
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc insertfakerow {id p} {
|
|
global varcid varccommits parents children cmitlisted
|
|
global commitidx varctok vtokmod targetid targetrow curview numcommits
|
|
|
|
set v $curview
|
|
set a $varcid($v,$p)
|
|
set i [lsearch -exact $varccommits($v,$a) $p]
|
|
if {$i < 0} {
|
|
puts "oops: insertfakerow can't find [shortids $p] on arc $a"
|
|
return
|
|
}
|
|
set children($v,$id) {}
|
|
set parents($v,$id) [list $p]
|
|
set varcid($v,$id) $a
|
|
lappend children($v,$p) $id
|
|
set cmitlisted($v,$id) 1
|
|
set numcommits [incr commitidx($v)]
|
|
# note we deliberately don't update varcstart($v) even if $i == 0
|
|
set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
|
|
modify_arc $v $a $i
|
|
if {[info exists targetid]} {
|
|
if {![comes_before $targetid $p]} {
|
|
incr targetrow
|
|
}
|
|
}
|
|
setcanvscroll
|
|
drawvisible
|
|
}
|
|
|
|
proc removefakerow {id} {
|
|
global varcid varccommits parents children commitidx
|
|
global varctok vtokmod cmitlisted currentid selectedline
|
|
global targetid curview numcommits
|
|
|
|
set v $curview
|
|
if {[llength $parents($v,$id)] != 1} {
|
|
puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
|
|
return
|
|
}
|
|
set p [lindex $parents($v,$id) 0]
|
|
set a $varcid($v,$id)
|
|
set i [lsearch -exact $varccommits($v,$a) $id]
|
|
if {$i < 0} {
|
|
puts "oops: removefakerow can't find [shortids $id] on arc $a"
|
|
return
|
|
}
|
|
unset varcid($v,$id)
|
|
set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
|
|
unset parents($v,$id)
|
|
unset children($v,$id)
|
|
unset cmitlisted($v,$id)
|
|
set numcommits [incr commitidx($v) -1]
|
|
set j [lsearch -exact $children($v,$p) $id]
|
|
if {$j >= 0} {
|
|
set children($v,$p) [lreplace $children($v,$p) $j $j]
|
|
}
|
|
modify_arc $v $a $i
|
|
if {[info exist currentid] && $id eq $currentid} {
|
|
unset currentid
|
|
set selectedline {}
|
|
}
|
|
if {[info exists targetid] && $targetid eq $id} {
|
|
set targetid $p
|
|
}
|
|
setcanvscroll
|
|
drawvisible
|
|
}
|
|
|
|
proc first_real_child {vp} {
|
|
global children nullid nullid2
|
|
|
|
foreach id $children($vp) {
|
|
if {$id ne $nullid && $id ne $nullid2} {
|
|
return $id
|
|
}
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc last_real_child {vp} {
|
|
global children nullid nullid2
|
|
|
|
set kids $children($vp)
|
|
for {set i [llength $kids]} {[incr i -1] >= 0} {} {
|
|
set id [lindex $kids $i]
|
|
if {$id ne $nullid && $id ne $nullid2} {
|
|
return $id
|
|
}
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc vtokcmp {v a b} {
|
|
global varctok varcid
|
|
|
|
return [string compare [lindex $varctok($v) $varcid($v,$a)] \
|
|
[lindex $varctok($v) $varcid($v,$b)]]
|
|
}
|
|
|
|
# This assumes that if lim is not given, the caller has checked that
|
|
# arc a's token is less than $vtokmod($v)
|
|
proc modify_arc {v a {lim {}}} {
|
|
global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
|
|
|
|
if {$lim ne {}} {
|
|
set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
|
|
if {$c > 0} return
|
|
if {$c == 0} {
|
|
set r [lindex $varcrow($v) $a]
|
|
if {$r ne {} && $vrowmod($v) <= $r + $lim} return
|
|
}
|
|
}
|
|
set vtokmod($v) [lindex $varctok($v) $a]
|
|
set varcmod($v) $a
|
|
if {$v == $curview} {
|
|
while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
|
|
set a [lindex $vupptr($v) $a]
|
|
set lim {}
|
|
}
|
|
set r 0
|
|
if {$a != 0} {
|
|
if {$lim eq {}} {
|
|
set lim [llength $varccommits($v,$a)]
|
|
}
|
|
set r [expr {[lindex $varcrow($v) $a] + $lim}]
|
|
}
|
|
set vrowmod($v) $r
|
|
undolayout $r
|
|
}
|
|
}
|
|
|
|
proc update_arcrows {v} {
|
|
global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
|
|
global varcid vrownum varcorder varcix varccommits
|
|
global vupptr vdownptr vleftptr varctok
|
|
global displayorder parentlist curview cached_commitrow
|
|
|
|
if {$vrowmod($v) == $commitidx($v)} return
|
|
if {$v == $curview} {
|
|
if {[llength $displayorder] > $vrowmod($v)} {
|
|
set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
|
|
set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
|
|
}
|
|
catch {unset cached_commitrow}
|
|
}
|
|
set narctot [expr {[llength $varctok($v)] - 1}]
|
|
set a $varcmod($v)
|
|
while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
|
|
# go up the tree until we find something that has a row number,
|
|
# or we get to a seed
|
|
set a [lindex $vupptr($v) $a]
|
|
}
|
|
if {$a == 0} {
|
|
set a [lindex $vdownptr($v) 0]
|
|
if {$a == 0} return
|
|
set vrownum($v) {0}
|
|
set varcorder($v) [list $a]
|
|
lset varcix($v) $a 0
|
|
lset varcrow($v) $a 0
|
|
set arcn 0
|
|
set row 0
|
|
} else {
|
|
set arcn [lindex $varcix($v) $a]
|
|
if {[llength $vrownum($v)] > $arcn + 1} {
|
|
set vrownum($v) [lrange $vrownum($v) 0 $arcn]
|
|
set varcorder($v) [lrange $varcorder($v) 0 $arcn]
|
|
}
|
|
set row [lindex $varcrow($v) $a]
|
|
}
|
|
while {1} {
|
|
set p $a
|
|
incr row [llength $varccommits($v,$a)]
|
|
# go down if possible
|
|
set b [lindex $vdownptr($v) $a]
|
|
if {$b == 0} {
|
|
# if not, go left, or go up until we can go left
|
|
while {$a != 0} {
|
|
set b [lindex $vleftptr($v) $a]
|
|
if {$b != 0} break
|
|
set a [lindex $vupptr($v) $a]
|
|
}
|
|
if {$a == 0} break
|
|
}
|
|
set a $b
|
|
incr arcn
|
|
lappend vrownum($v) $row
|
|
lappend varcorder($v) $a
|
|
lset varcix($v) $a $arcn
|
|
lset varcrow($v) $a $row
|
|
}
|
|
set vtokmod($v) [lindex $varctok($v) $p]
|
|
set varcmod($v) $p
|
|
set vrowmod($v) $row
|
|
if {[info exists currentid]} {
|
|
set selectedline [rowofcommit $currentid]
|
|
}
|
|
}
|
|
|
|
# Test whether view $v contains commit $id
|
|
proc commitinview {id v} {
|
|
global varcid
|
|
|
|
return [info exists varcid($v,$id)]
|
|
}
|
|
|
|
# Return the row number for commit $id in the current view
|
|
proc rowofcommit {id} {
|
|
global varcid varccommits varcrow curview cached_commitrow
|
|
global varctok vtokmod
|
|
|
|
set v $curview
|
|
if {![info exists varcid($v,$id)]} {
|
|
puts "oops rowofcommit no arc for [shortids $id]"
|
|
return {}
|
|
}
|
|
set a $varcid($v,$id)
|
|
if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
|
|
update_arcrows $v
|
|
}
|
|
if {[info exists cached_commitrow($id)]} {
|
|
return $cached_commitrow($id)
|
|
}
|
|
set i [lsearch -exact $varccommits($v,$a) $id]
|
|
if {$i < 0} {
|
|
puts "oops didn't find commit [shortids $id] in arc $a"
|
|
return {}
|
|
}
|
|
incr i [lindex $varcrow($v) $a]
|
|
set cached_commitrow($id) $i
|
|
return $i
|
|
}
|
|
|
|
# Returns 1 if a is on an earlier row than b, otherwise 0
|
|
proc comes_before {a b} {
|
|
global varcid varctok curview
|
|
|
|
set v $curview
|
|
if {$a eq $b || ![info exists varcid($v,$a)] || \
|
|
![info exists varcid($v,$b)]} {
|
|
return 0
|
|
}
|
|
if {$varcid($v,$a) != $varcid($v,$b)} {
|
|
return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
|
|
[lindex $varctok($v) $varcid($v,$b)]] < 0}]
|
|
}
|
|
return [expr {[rowofcommit $a] < [rowofcommit $b]}]
|
|
}
|
|
|
|
proc bsearch {l elt} {
|
|
if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
|
|
return 0
|
|
}
|
|
set lo 0
|
|
set hi [llength $l]
|
|
while {$hi - $lo > 1} {
|
|
set mid [expr {int(($lo + $hi) / 2)}]
|
|
set t [lindex $l $mid]
|
|
if {$elt < $t} {
|
|
set hi $mid
|
|
} elseif {$elt > $t} {
|
|
set lo $mid
|
|
} else {
|
|
return $mid
|
|
}
|
|
}
|
|
return $lo
|
|
}
|
|
|
|
# Make sure rows $start..$end-1 are valid in displayorder and parentlist
|
|
proc make_disporder {start end} {
|
|
global vrownum curview commitidx displayorder parentlist
|
|
global varccommits varcorder parents vrowmod varcrow
|
|
global d_valid_start d_valid_end
|
|
|
|
if {$end > $vrowmod($curview)} {
|
|
update_arcrows $curview
|
|
}
|
|
set ai [bsearch $vrownum($curview) $start]
|
|
set start [lindex $vrownum($curview) $ai]
|
|
set narc [llength $vrownum($curview)]
|
|
for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
|
|
set a [lindex $varcorder($curview) $ai]
|
|
set l [llength $displayorder]
|
|
set al [llength $varccommits($curview,$a)]
|
|
if {$l < $r + $al} {
|
|
if {$l < $r} {
|
|
set pad [ntimes [expr {$r - $l}] {}]
|
|
set displayorder [concat $displayorder $pad]
|
|
set parentlist [concat $parentlist $pad]
|
|
} elseif {$l > $r} {
|
|
set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
|
|
set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
|
|
}
|
|
foreach id $varccommits($curview,$a) {
|
|
lappend displayorder $id
|
|
lappend parentlist $parents($curview,$id)
|
|
}
|
|
} elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
|
|
set i $r
|
|
foreach id $varccommits($curview,$a) {
|
|
lset displayorder $i $id
|
|
lset parentlist $i $parents($curview,$id)
|
|
incr i
|
|
}
|
|
}
|
|
incr r $al
|
|
}
|
|
}
|
|
|
|
proc commitonrow {row} {
|
|
global displayorder
|
|
|
|
set id [lindex $displayorder $row]
|
|
if {$id eq {}} {
|
|
make_disporder $row [expr {$row + 1}]
|
|
set id [lindex $displayorder $row]
|
|
}
|
|
return $id
|
|
}
|
|
|
|
proc closevarcs {v} {
|
|
global varctok varccommits varcid parents children
|
|
global cmitlisted commitidx commitinterest vtokmod
|
|
|
|
set missing_parents 0
|
|
set scripts {}
|
|
set narcs [llength $varctok($v)]
|
|
for {set a 1} {$a < $narcs} {incr a} {
|
|
set id [lindex $varccommits($v,$a) end]
|
|
foreach p $parents($v,$id) {
|
|
if {[info exists varcid($v,$p)]} continue
|
|
# add p as a new commit
|
|
incr missing_parents
|
|
set cmitlisted($v,$p) 0
|
|
set parents($v,$p) {}
|
|
if {[llength $children($v,$p)] == 1 &&
|
|
[llength $parents($v,$id)] == 1} {
|
|
set b $a
|
|
} else {
|
|
set b [newvarc $v $p]
|
|
}
|
|
set varcid($v,$p) $b
|
|
if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
|
|
modify_arc $v $b
|
|
}
|
|
lappend varccommits($v,$b) $p
|
|
incr commitidx($v)
|
|
if {[info exists commitinterest($p)]} {
|
|
foreach script $commitinterest($p) {
|
|
lappend scripts [string map [list "%I" $p] $script]
|
|
}
|
|
unset commitinterest($id)
|
|
}
|
|
}
|
|
}
|
|
if {$missing_parents > 0} {
|
|
foreach s $scripts {
|
|
eval $s
|
|
}
|
|
}
|
|
}
|
|
|
|
# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
|
|
# Assumes we already have an arc for $rwid.
|
|
proc rewrite_commit {v id rwid} {
|
|
global children parents varcid varctok vtokmod varccommits
|
|
|
|
foreach ch $children($v,$id) {
|
|
# make $rwid be $ch's parent in place of $id
|
|
set i [lsearch -exact $parents($v,$ch) $id]
|
|
if {$i < 0} {
|
|
puts "oops rewrite_commit didn't find $id in parent list for $ch"
|
|
}
|
|
set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
|
|
# add $ch to $rwid's children and sort the list if necessary
|
|
if {[llength [lappend children($v,$rwid) $ch]] > 1} {
|
|
set children($v,$rwid) [lsort -command [list vtokcmp $v] \
|
|
$children($v,$rwid)]
|
|
}
|
|
# fix the graph after joining $id to $rwid
|
|
set a $varcid($v,$ch)
|
|
fix_reversal $rwid $a $v
|
|
# parentlist is wrong for the last element of arc $a
|
|
# even if displayorder is right, hence the 3rd arg here
|
|
modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
|
|
}
|
|
}
|
|
|
|
proc getcommitlines {fd inst view updating} {
|
|
global cmitlisted commitinterest leftover
|
|
global commitidx commitdata vdatemode
|
|
global parents children curview hlview
|
|
global idpending ordertok
|
|
global varccommits varcid varctok vtokmod vfilelimit
|
|
|
|
set stuff [read $fd 500000]
|
|
# git log doesn't terminate the last commit with a null...
|
|
if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
|
|
set stuff "\0"
|
|
}
|
|
if {$stuff == {}} {
|
|
if {![eof $fd]} {
|
|
return 1
|
|
}
|
|
global commfd viewcomplete viewactive viewname
|
|
global viewinstances
|
|
unset commfd($inst)
|
|
set i [lsearch -exact $viewinstances($view) $inst]
|
|
if {$i >= 0} {
|
|
set viewinstances($view) [lreplace $viewinstances($view) $i $i]
|
|
}
|
|
# set it blocking so we wait for the process to terminate
|
|
fconfigure $fd -blocking 1
|
|
if {[catch {close $fd} err]} {
|
|
set fv {}
|
|
if {$view != $curview} {
|
|
set fv " for the \"$viewname($view)\" view"
|
|
}
|
|
if {[string range $err 0 4] == "usage"} {
|
|
set err "Gitk: error reading commits$fv:\
|
|
bad arguments to git log."
|
|
if {$viewname($view) eq "Command line"} {
|
|
append err \
|
|
" (Note: arguments to gitk are passed to git log\
|
|
to allow selection of commits to be displayed.)"
|
|
}
|
|
} else {
|
|
set err "Error reading commits$fv: $err"
|
|
}
|
|
error_popup $err
|
|
}
|
|
if {[incr viewactive($view) -1] <= 0} {
|
|
set viewcomplete($view) 1
|
|
# Check if we have seen any ids listed as parents that haven't
|
|
# appeared in the list
|
|
closevarcs $view
|
|
notbusy $view
|
|
}
|
|
if {$view == $curview} {
|
|
run chewcommits
|
|
}
|
|
return 0
|
|
}
|
|
set start 0
|
|
set gotsome 0
|
|
set scripts {}
|
|
while 1 {
|
|
set i [string first "\0" $stuff $start]
|
|
if {$i < 0} {
|
|
append leftover($inst) [string range $stuff $start end]
|
|
break
|
|
}
|
|
if {$start == 0} {
|
|
set cmit $leftover($inst)
|
|
append cmit [string range $stuff 0 [expr {$i - 1}]]
|
|
set leftover($inst) {}
|
|
} else {
|
|
set cmit [string range $stuff $start [expr {$i - 1}]]
|
|
}
|
|
set start [expr {$i + 1}]
|
|
set j [string first "\n" $cmit]
|
|
set ok 0
|
|
set listed 1
|
|
if {$j >= 0 && [string match "commit *" $cmit]} {
|
|
set ids [string range $cmit 7 [expr {$j - 1}]]
|
|
if {[string match {[-^<>]*} $ids]} {
|
|
switch -- [string index $ids 0] {
|
|
"-" {set listed 0}
|
|
"^" {set listed 2}
|
|
"<" {set listed 3}
|
|
">" {set listed 4}
|
|
}
|
|
set ids [string range $ids 1 end]
|
|
}
|
|
set ok 1
|
|
foreach id $ids {
|
|
if {[string length $id] != 40} {
|
|
set ok 0
|
|
break
|
|
}
|
|
}
|
|
}
|
|
if {!$ok} {
|
|
set shortcmit $cmit
|
|
if {[string length $shortcmit] > 80} {
|
|
set shortcmit "[string range $shortcmit 0 80]..."
|
|
}
|
|
error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
|
|
exit 1
|
|
}
|
|
set id [lindex $ids 0]
|
|
set vid $view,$id
|
|
|
|
if {!$listed && $updating && ![info exists varcid($vid)] &&
|
|
$vfilelimit($view) ne {}} {
|
|
# git log doesn't rewrite parents for unlisted commits
|
|
# when doing path limiting, so work around that here
|
|
# by working out the rewritten parent with git rev-list
|
|
# and if we already know about it, using the rewritten
|
|
# parent as a substitute parent for $id's children.
|
|
if {![catch {
|
|
set rwid [exec git rev-list --first-parent --max-count=1 \
|
|
$id -- $vfilelimit($view)]
|
|
}]} {
|
|
if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
|
|
# use $rwid in place of $id
|
|
rewrite_commit $view $id $rwid
|
|
continue
|
|
}
|
|
}
|
|
}
|
|
|
|
set a 0
|
|
if {[info exists varcid($vid)]} {
|
|
if {$cmitlisted($vid) || !$listed} continue
|
|
set a $varcid($vid)
|
|
}
|
|
if {$listed} {
|
|
set olds [lrange $ids 1 end]
|
|
} else {
|
|
set olds {}
|
|
}
|
|
set commitdata($id) [string range $cmit [expr {$j + 1}] end]
|
|
set cmitlisted($vid) $listed
|
|
set parents($vid) $olds
|
|
if {![info exists children($vid)]} {
|
|
set children($vid) {}
|
|
} elseif {$a == 0 && [llength $children($vid)] == 1} {
|
|
set k [lindex $children($vid) 0]
|
|
if {[llength $parents($view,$k)] == 1 &&
|
|
(!$vdatemode($view) ||
|
|
$varcid($view,$k) == [llength $varctok($view)] - 1)} {
|
|
set a $varcid($view,$k)
|
|
}
|
|
}
|
|
if {$a == 0} {
|
|
# new arc
|
|
set a [newvarc $view $id]
|
|
}
|
|
if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
|
|
modify_arc $view $a
|
|
}
|
|
if {![info exists varcid($vid)]} {
|
|
set varcid($vid) $a
|
|
lappend varccommits($view,$a) $id
|
|
incr commitidx($view)
|
|
}
|
|
|
|
set i 0
|
|
foreach p $olds {
|
|
if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
|
|
set vp $view,$p
|
|
if {[llength [lappend children($vp) $id]] > 1 &&
|
|
[vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
|
|
set children($vp) [lsort -command [list vtokcmp $view] \
|
|
$children($vp)]
|
|
catch {unset ordertok}
|
|
}
|
|
if {[info exists varcid($view,$p)]} {
|
|
fix_reversal $p $a $view
|
|
}
|
|
}
|
|
incr i
|
|
}
|
|
|
|
if {[info exists commitinterest($id)]} {
|
|
foreach script $commitinterest($id) {
|
|
lappend scripts [string map [list "%I" $id] $script]
|
|
}
|
|
unset commitinterest($id)
|
|
}
|
|
set gotsome 1
|
|
}
|
|
if {$gotsome} {
|
|
global numcommits hlview
|
|
|
|
if {$view == $curview} {
|
|
set numcommits $commitidx($view)
|
|
run chewcommits
|
|
}
|
|
if {[info exists hlview] && $view == $hlview} {
|
|
# we never actually get here...
|
|
run vhighlightmore
|
|
}
|
|
foreach s $scripts {
|
|
eval $s
|
|
}
|
|
}
|
|
return 2
|
|
}
|
|
|
|
proc chewcommits {} {
|
|
global curview hlview viewcomplete
|
|
global pending_select
|
|
|
|
layoutmore
|
|
if {$viewcomplete($curview)} {
|
|
global commitidx varctok
|
|
global numcommits startmsecs
|
|
|
|
if {[info exists pending_select]} {
|
|
update
|
|
reset_pending_select {}
|
|
|
|
if {[commitinview $pending_select $curview]} {
|
|
selectline [rowofcommit $pending_select] 1
|
|
} else {
|
|
set row [first_real_row]
|
|
selectline $row 1
|
|
}
|
|
}
|
|
if {$commitidx($curview) > 0} {
|
|
#set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
|
|
#puts "overall $ms ms for $numcommits commits"
|
|
#puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
|
|
} else {
|
|
show_status [mc "No commits selected"]
|
|
}
|
|
notbusy layout
|
|
}
|
|
return 0
|
|
}
|
|
|
|
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 cdate
|
|
|
|
set inhdr 1
|
|
set comment {}
|
|
set headline {}
|
|
set auname {}
|
|
set audate {}
|
|
set comname {}
|
|
set comdate {}
|
|
set hdrend [string first "\n\n" $contents]
|
|
if {$hdrend < 0} {
|
|
# should never happen...
|
|
set hdrend [string length $contents]
|
|
}
|
|
set header [string range $contents 0 [expr {$hdrend - 1}]]
|
|
set comment [string range $contents [expr {$hdrend + 2}] end]
|
|
foreach line [split $header "\n"] {
|
|
set tag [lindex $line 0]
|
|
if {$tag == "author"} {
|
|
set audate [lindex $line end-1]
|
|
set auname [lrange $line 1 end-2]
|
|
} elseif {$tag == "committer"} {
|
|
set comdate [lindex $line end-1]
|
|
set comname [lrange $line 1 end-2]
|
|
}
|
|
}
|
|
set headline {}
|
|
# take the first non-blank line of the comment as the headline
|
|
set headline [string trimleft $comment]
|
|
set i [string first "\n" $headline]
|
|
if {$i >= 0} {
|
|
set headline [string range $headline 0 $i]
|
|
}
|
|
set headline [string trimright $headline]
|
|
set i [string first "\r" $headline]
|
|
if {$i >= 0} {
|
|
set headline [string trimright [string range $headline 0 $i]]
|
|
}
|
|
if {!$listed} {
|
|
# git log indents the comment by 4 spaces;
|
|
# if we got this via git cat-file, add the indentation
|
|
set newcomment {}
|
|
foreach line [split $comment "\n"] {
|
|
append newcomment " "
|
|
append newcomment $line
|
|
append newcomment "\n"
|
|
}
|
|
set comment $newcomment
|
|
}
|
|
if {$comdate != {}} {
|
|
set cdate($id) $comdate
|
|
}
|
|
set commitinfo($id) [list $headline $auname $audate \
|
|
$comname $comdate $comment]
|
|
}
|
|
|
|
proc getcommit {id} {
|
|
global commitdata commitinfo
|
|
|
|
if {[info exists commitdata($id)]} {
|
|
parsecommit $id $commitdata($id) 1
|
|
} else {
|
|
readcommit $id
|
|
if {![info exists commitinfo($id)]} {
|
|
set commitinfo($id) [list [mc "No commit information available"]]
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
|
|
proc readrefs {} {
|
|
global tagids idtags headids idheads tagobjid
|
|
global otherrefids idotherrefs mainhead mainheadid
|
|
|
|
foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
|
|
catch {unset $v}
|
|
}
|
|
set refd [open [list | git show-ref -d] r]
|
|
while {[gets $refd line] >= 0} {
|
|
if {[string index $line 40] ne " "} continue
|
|
set id [string range $line 0 39]
|
|
set ref [string range $line 41 end]
|
|
if {![string match "refs/*" $ref]} continue
|
|
set name [string range $ref 5 end]
|
|
if {[string match "remotes/*" $name]} {
|
|
if {![string match "*/HEAD" $name]} {
|
|
set headids($name) $id
|
|
lappend idheads($id) $name
|
|
}
|
|
} elseif {[string match "heads/* |