SEH tdelta.tcl:
Produce an rdiff-style delta signature of one file with respect to another, and re-create one file by applying the delta to the other.
Strong md5 checksums of file segments are stored in the delta signature, which reduces efficiency but enhances security.
# Usage:
# tdelta <reference file> <target file>
# Returns a delta of the target file with respect to the reference file.
# i.e., using patch to apply the delta to the target file will re-create the reference file.
# patch <target file> <delta signature> <output file (duplicate of reference file)>
# Reconstitute original reference file by applying delta to target file.
# global variable: blockSize
# Size of file segments to compare.
# Smaller blockSize tends to create smaller delta.
# Larger blockSize tends to take more time to compute delta.
if ![info exists blockSize] {variable blockSize 100}
if ![info exists Mod] {variable Mod [expr pow(2,16)]}
variable temp
if ![info exists temp] {
catch {set temp $env(TMP)}
catch {set temp $env(TEMP)}
catch {set temp $env(TRSYNC_TEMP)}
if [catch {file mkdir $temp}] {set temp [pwd]}
}
if ![file writable $temp] {error "temp location not writable"}
proc Backup {args} {
return
}
proc ConstructFile {copyinstructions {eolNative 0} {backup {}}} {
package require md5 1
set fileToConstruct [lindex $copyinstructions 0]
set existingFile [lindex $copyinstructions 1]
set blockSize [lindex $copyinstructions 2]
array set fileStats [lindex $copyinstructions 3]
array set digestInstructionArray [lindex $copyinstructions 4]
array set dataInstructionArray [lindex $copyinstructions 5]
unset copyinstructions
set existingFile [FileNameNormalize $existingFile]
if {$fileToConstruct == {}} {file delete -force $existingFile ; return}
set fileToConstruct [FileNameNormalize $fileToConstruct]
if $eolNative {set eolNative [string is ascii -strict [array get dataInstructionArray]]}
set temp $::temp
set constructTag "trsync.[md5::md5 "[clock seconds] [clock clicks]"]"
catch {
set existingID [open $existingFile r]
fconfigure $existingID -translation binary
}
set constructID [open $temp/$constructTag w]
fconfigure $constructID -translation binary
set filePointer 1
while {$filePointer <= $fileStats(size)} {
if {[array names dataInstructionArray $filePointer] != {}} {
puts -nonewline $constructID $dataInstructionArray($filePointer)
set segmentLength [string length $dataInstructionArray($filePointer)]
array unset dataInstructionArray $filePointer
set filePointer [expr $filePointer + $segmentLength]
} elseif {[array names digestInstructionArray $filePointer] != {}} {
if ![info exists existingID] {error "Corrupt copy instructions."}
set blockNumber [lindex $digestInstructionArray($filePointer) 0]
set blockMd5Sum [lindex $digestInstructionArray($filePointer) 1]
seek $existingID [expr $blockNumber * $blockSize]
set existingBlock [read $existingID $blockSize]
set existingBlockMd5Sum [md5::md5 $existingBlock]
if ![string equal -nocase $blockMd5Sum $existingBlockMd5Sum] {error "digest file contents mismatch"}
puts -nonewline $constructID $existingBlock
if $eolNative {set eolNative [string is ascii -strict $existingBlock]}
unset existingBlock
set filePointer [expr $filePointer + $blockSize]
} else {
error "Corrupt copy instructions."
}
}
close $constructID
catch {close $existingID}
if $eolNative {
fcopy [set fin [open $temp/$constructTag r]] [set fout [open $temp/${constructTag}fcopy w]]
close $fin
close $fout
file delete -force $temp/$constructTag
set constructTag "${constructTag}fcopy"
}
catch {file attributes $temp/$constructTag -readonly 0} result
catch {file attributes $temp/$constructTag -permissions rw-rw-rw-} result
catch {file attributes $temp/$constructTag -owner $fileStats(uid)} result
catch {file attributes $temp/$constructTag -group $fileStats(gid)} result
catch {file mtime $temp/$constructTag $fileStats(mtime)} result
catch {file atime $temp/$constructTag $fileStats(atime)} result
catch {file attributes $existingFile -readonly 0} result
catch {file attributes $existingFile -permissions rw-rw-rw-} result
Backup $backup $fileToConstruct
file mkdir [file dirname $fileToConstruct]
file rename -force $temp/$constructTag $fileToConstruct
array set attributes $fileStats(attributes)
foreach attr [array names attributes] {
catch {file attributes $fileToConstruct $attr $attributes($attr)} result
}
catch {file attributes $fileToConstruct -permissions $fileStats(mode)} result
return
}
proc CopyInstructions {filename digest} {
package require md5 1
set filename [FileNameNormalize $filename]
file stat $filename fileStats
array set fileAttributes [file attributes $filename]
set arrayadd attributes ; lappend arrayadd [array get fileAttributes] ; array set fileStats $arrayadd
set fileSize $fileStats(size)
set digestFileName [lindex $digest 0]
set blockSize [lindex $digest 1]
set digest [lrange $digest 2 end]
if {[lsearch -exact $digest fingerprints] > -1} {
set fingerPrints [lindex $digest end]
set digest [lrange $digest 0 end-2]
set f [open $filename r]
fconfigure $f -translation binary
set fileContents [read $f]
set matchCount 0
foreach fP $fingerPrints {
if {[string first $fP $fileContents] > -1} {incr matchCount}
if {$matchCount > 3} {break}
}
unset fileContents
close $f
if {$matchCount < 3} {set digest {}}
}
set digestLength [llength $digest]
for {set i 0} {$i < $digestLength} {incr i} {
set arrayadd [lindex [lindex $digest $i] 1]
lappend arrayadd $i
array set Checksums $arrayadd
}
set f [open $filename r]
fconfigure $f -translation binary
set digestInstructions {}
set dataInstructions {}
set weakChecksum {}
set startBlockPointer 0
set endBlockPointer 0
if ![array exists Checksums] {
set dataInstructions 1
lappend dataInstructions [read $f]
set endBlockPointer $fileSize
}
while {$endBlockPointer < $fileSize} {
set endBlockPointer [expr $startBlockPointer + $blockSize]
incr startBlockPointer
if {$weakChecksum == {}} {
set blockContents [read $f $blockSize]
set blockNumberSequence [SequenceBlock $blockContents]
set weakChecksumInfo [WeakChecksum $blockNumberSequence]
set weakChecksum [format %.0f [lindex $weakChecksumInfo 0]]
set startDataPointer $startBlockPointer
set endDataPointer $startDataPointer
set dataBuffer {}
}
if {[array names Checksums $weakChecksum] != {}} {
set md5Sum [md5::md5 $blockContents]
set blockIndex $Checksums($weakChecksum)
set digestmd5Sum [lindex [lindex $digest $blockIndex] 0]
if [string equal -nocase $digestmd5Sum $md5Sum] {
if {$endDataPointer > $startDataPointer} {
lappend dataInstructions $startDataPointer
lappend dataInstructions $dataBuffer
}
lappend digestInstructions $startBlockPointer
lappend digestInstructions "$blockIndex $md5Sum"
set weakChecksum {}
set startBlockPointer $endBlockPointer
continue
}
}
if {$endBlockPointer >= $fileSize} {
lappend dataInstructions $startDataPointer
lappend dataInstructions $dataBuffer$blockContents
break
}
set rollChar [read $f 1]
binary scan $rollChar c* rollNumber
set rollNumber [expr ($rollNumber + 0x100)%0x100]
lappend blockNumberSequence $rollNumber
set blockNumberSequence [lrange $blockNumberSequence 1 end]
binary scan $blockContents a1a* rollOffChar blockContents
set blockContents $blockContents$rollChar
set dataBuffer $dataBuffer$rollOffChar
incr endDataPointer
set weakChecksumInfo "[eval RollChecksum [lrange $weakChecksumInfo 1 5] $rollNumber] [lindex $blockNumberSequence 0]"
set weakChecksum [format %.0f [lindex $weakChecksumInfo 0]]
}
close $f
lappend copyInstructions $filename
lappend copyInstructions $digestFileName
lappend copyInstructions $blockSize
lappend copyInstructions [array get fileStats]
lappend copyInstructions $digestInstructions
lappend copyInstructions $dataInstructions
return $copyInstructions
}
proc Digest {filename blockSize {sizecheck 0} {fingerprint 0}} {
package require md5 1
set filename [FileNameNormalize $filename]
set digest "[list $filename] $blockSize"
if {!([file isfile $filename] && [file readable $filename])} {return $digest}
set fileSize [file size $filename]
if {$sizecheck && ($fileSize < [expr $blockSize * 5])} {return $digest}
set charsRead 0
set f [open $filename r]
fconfigure $f -translation binary
while {$charsRead < $fileSize} {
set blockContents [read $f $blockSize]
set charsRead [expr $charsRead + $blockSize]
set md5Sum [md5::md5 $blockContents]
set blockNumberSequence [SequenceBlock $blockContents]
set weakChecksum [lindex [WeakChecksum $blockNumberSequence] 0]
lappend digest "$md5Sum [format %.0f $weakChecksum]"
}
if $fingerprint {
set fileIncrement [expr $fileSize/10]
set fpLocation [expr $fileSize - 21]
set i 0
while {$i < 10} {
if {$fpLocation < 0} {set fpLocation 0}
seek $f $fpLocation
lappend fingerPrints [read $f 20]
set fpLocation [expr $fpLocation - $fileIncrement]
incr i
}
lappend digest fingerprints
lappend digest [lsort -unique $fingerPrints]
}
close $f
return $digest
}
proc FileNameNormalize {filename} {
file normalize $filename
}
proc RollChecksum {a(k,l)_ b(k,l)_ k l Xsub_k Xsub_l+1 } {
set Mod $trsync::Mod
set a(k+1,l+1)_ [expr ${a(k,l)_} - $Xsub_k + ${Xsub_l+1}]
set b(k+1,l+1)_ [expr ${b(k,l)_} - (($l - $k + 1) * $Xsub_k) + ${a(k+1,l+1)_}]
set a(k+1,l+1)_ [expr fmod(${a(k+1,l+1)_},$Mod)]
set b(k+1,l+1)_ [expr fmod(${b(k+1,l+1)_},$Mod)]
set s(k+1,l+1)_ [expr ${a(k+1,l+1)_} + ($Mod * ${b(k+1,l+1)_})]
return "${s(k+1,l+1)_} ${a(k+1,l+1)_} ${b(k+1,l+1)_} [incr k] [incr l]"
}
proc SequenceBlock {blockcontents} {
binary scan $blockcontents c* blockNumberSequence
set blockNumberSequenceLength [llength $blockNumberSequence]
for {set i 0} {$i < $blockNumberSequenceLength} {incr i} {
set blockNumberSequence [lreplace $blockNumberSequence $i $i [expr ([lindex $blockNumberSequence $i] + 0x100)%0x100]]
}
return $blockNumberSequence
}
proc WeakChecksum {Xsub_k...Xsub_l} {
set a(k,i)_ 0
set b(k,i)_ 0
set Mod $trsync::Mod
set k 1
set l [llength ${Xsub_k...Xsub_l}]
for {set i $k} {$i <= $l} {incr i} {
set Xsub_i [lindex ${Xsub_k...Xsub_l} [expr $i - 1]]
set a(k,i)_ [expr ${a(k,i)_} + $Xsub_i]
set b(k,i)_ [expr ${b(k,i)_} + (($l - $i + 1) * $Xsub_i)]
}
set a(k,l)_ [expr fmod(${a(k,i)_},$Mod)]
set b(k,l)_ [expr fmod(${b(k,i)_},$Mod)]
set s(k,l)_ [expr ${a(k,l)_} + ($Mod * ${b(k,l)_})]
return "${s(k,l)_} ${a(k,l)_} ${b(k,l)_} $k $l [lindex ${Xsub_k...Xsub_l} 0]"
}
proc tdelta {referenceFile targetFile blockSize} {
set signature [Digest $targetFile $blockSize]
return [CopyInstructions $referenceFile $signature]
}
proc patch {targetFile copyInstructions fileToConstruct} {
set copyInstructions [lreplace $copyInstructions 0 1 $fileToConstruct $targetFile]
return [ConstructFile $copyInstructions]
}
set trsync::Mod $Mod