1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
|
Private Declare Function bSHL Lib "bitwise.dll" (ByVal a1 As Long, ByVal a2 As Integer) As Long
Private Declare Function bLongToWord Lib "bitwise.dll" (ByVal a1 As Long) As Integer
Private OutFileName As String
Dim fOut As Integer
Dim PutBitMask As Byte
Dim PutBitByte As Byte
Dim PutBitOffset As Long
Dim bPutBitFixupMode As Boolean
Dim PutBitRecNum As Long
Dim FxLog As Integer
Public FxCRCLog As Integer
Dim LogFileName As String
Public bLogging As Boolean, bCRCLogging As Boolean
Public nErrors As Long
Public Const LOGINFO = 0
Public Const LOGWARN = 1
Public Const LOGV1 = 100
Public Const LOGERROR = 9
Public Const NUMBITSSTRING = -2
Public Const NUMBITSBINARY = -3
Dim crc16 As Integer
Const MTT = &H1021
Const INIT = &HFFFF
Private Type ALengthFixup
Offset As Long
Value As Long
End Type
Private Type ACRCFixup
OffsetStart As Long
OffsetStop As Long
OffsetRewrite As Long
End Type
Private Const MAXLFIXUPTABLE = 500
Private Const MAXCFIXUPTABLE = 500
Private LFixupTable(1 To MAXLFIXUPTABLE) As ALengthFixup
Private CFixupTable(1 To MAXCFIXUPTABLE) As ACRCFixup
Private IxLFixupTable As Integer
Private IxCFixupTable As Integer
Public DepthLFixupTable As Integer
Public OutFile_bHidden As Boolean
Public Const NOTVISIBLESTRING = "<NOT VISIBLE>"
''Output file related functions
Public Function OutFile_Init(FN As String) As Boolean
On Error Resume Next
fOut = FreeFile
Open FN For Binary Access Read Write As #fOut
OutFile_Init = (Err.Number = 0)
PutBitMask = &H80
PutBitByte = 0
PutBitOffset = 0
PutBitRecNum = 1
bPutBitFixupMode = False
IxLFixupTable = 0
IxCFixupTable = 0
DepthLFixupTable = 0
OutFileName = FN
OutFile_bHidden = False
End Function
Public Sub OutFile_Purge()
If PutBitMask <> &H80 Then
Put #fOut, PutBitRecNum, PutBitByte
PutBitByte = 0
PutBitMask = &H80
End If
End Sub
Public Function OutFile_GetPutBitOffset() As String
OutFile_GetPutBitOffset = Format(PutBitOffset, "00000000")
End Function
Public Sub OutFile_PutBit(bitvalue As Byte)
On Error GoTo 0
PutBitOffset = PutBitOffset + 1
If bitvalue = 1 Then PutBitByte = PutBitByte Or PutBitMask Else PutBitByte = PutBitByte And (Not PutBitMask)
If PutBitMask = 1 Then
Put #fOut, PutBitRecNum, PutBitByte
PutBitRecNum = PutBitRecNum + 1
If bPutBitFixupMode Then '' must read previouly written value
Get #fOut, PutBitRecNum, PutBitByte ''read back previous value
Else
PutBitByte = 0
End If
PutBitMask = &H80
Else
PutBitMask = PutBitMask \ 2
End If
End Sub
Public Function OutFile_PutValue(ByVal sv As String, ByVal cResol As Double, ByVal NumberOfBits As Integer, Optional StringSize As Integer) As String
Dim Final As String, Ix As Integer, re As Byte, v As Double
Dim ForLog As String
Dim iSS As Integer
Dim aze As Double
'' Make sure no exceptions are raised
OutFile_PutValue = "?"
If NumberOfBits <> NUMBITSSTRING Then
If NumberOfBits < 1 Then
Exit Function
End If
End If
ForLog = OutFile_GetPutBitOffset
If NumberOfBits = NUMBITSSTRING Then
iSS = Abs(StringSize)
If Len(sv) > iSS Then
If bLogging Then Call AppendLog(LOGERROR, "Length of '" & sv & "' exceeds asked for length (" & iSS & ")")
nErrors = nErrors + 1
End If
sv = Left(sv & Space(iSS), iSS)
OutFile_PutValue = sv
For Ix = 1 To iSS
If StringSize < 0 Then
Call OutFile_PutValue("0", 1, 8)
Call OutFile_PutValue("0", 1, 8)
Call OutFile_PutValue("0", 1, 8)
End If
Call OutFile_PutValue(CStr(Asc(Mid(sv, Ix, 1))), 1, 8)
Next Ix
Exit Function
End If
On Error Resume Next
v = CDbl(sv)
If Err.Number <> 0 Then
v = 0: Err.Clear
End If
If cResol <> 1 Then
If cResol <> 0 Then
v = CDec(v) / CDec(cResol)
End If
End If
Final = String(NumberOfBits, "0")
For Ix = 1 To NumberOfBits
re = CMod(v, 2)
v = Int(CDec(v) / 2)
If re <> 0 Then Mid(Final, NumberOfBits - Ix + 1, 1) = "1"
Next Ix
For Ix = 1 To NumberOfBits
If Mid(Final, Ix, 1) = "1" Then Call OutFile_PutBit(1) Else Call OutFile_PutBit(0)
Next Ix
OutFile_PutValue = Final
If bLogging Then
If OutFile_bHidden Then
If bLogging Then Call AppendLog(LOGINFO, ForLog & " > " & NOTVISIBLESTRING)
Else
If bLogging Then Call AppendLog(LOGINFO, ForLog & " > " & Final)
End If
End If
End Function
Public Sub OutFile_Rewrite32bits(lOffset As Long, lValue As Long)
Dim ldiv As Long, lmod As Integer, bOldMode As Boolean, Ix As Integer
'' Can only be called with a PURGED BinaryFile
bOldMode = bPutBitFixupMode
Call OutFile_Purge
bPutBitFixupMode = True
ldiv = 1 + (lOffset \ 8) '' first byte is offset 1
lmod = lOffset Mod 8
Get #fOut, ldiv, PutBitByte
PutBitMask = &H80
For Ix = 1 To lmod: PutBitMask = PutBitMask \ 2: Next Ix
PutBitOffset = lOffset
PutBitRecNum = ldiv
Call OutFile_PutValue(lValue, 1, 32)
Call OutFile_Purge
bPutBitFixupMode = bOldMode
End Sub
Public Sub OutFile_PatchLength(lOffset As Long, lValue As Long)
Call OutFile_Rewrite32bits(lOffset, lValue)
If bLogging Then Call AppendLog(LOGINFO, "Setting length @" & CStr(lOffset) & " to " & CStr(lValue))
End Sub
Public Function OutFile_OpenLFixup() As Integer
If IxLFixupTable >= MAXLFIXUPTABLE Then
If bLogging Then Call AppendLog(LOGERROR, "too many length fixups defined")
nErrors = nErrors + 1
Else
IxLFixupTable = IxLFixupTable + 1
LFixupTable(IxLFixupTable).Offset = PutBitOffset
End If
DepthLFixupTable = DepthLFixupTable + 1
If bLogging Then Call AppendLog(LOGINFO, "$$$$Remembering Length FIXUP position " & CStr(IxLFixupTable) & " Depth=" & CStr(DepthLFixupTable) & " at " & CStr(PutBitOffset))
OutFile_OpenLFixup = IxLFixupTable
End Function
Public Sub OutFile_CloseLFixup(FixupIndex As Integer)
LFixupTable(FixupIndex).Value = PutBitOffset - LFixupTable(FixupIndex).Offset - 32
If bLogging Then Call AppendLog(LOGINFO, "$$$$Closing Length FIXUP position " & CStr(FixupIndex) & " Depth=" & CStr(DepthLFixupTable) & " at " & CStr(PutBitOffset))
DepthLFixupTable = DepthLFixupTable - 1
End Sub
Public Sub OutFile_ProcessLFixups()
Dim Ix As Integer
If bLogging Then Call AppendLog(LOGINFO, "")
If bLogging Then Call AppendLog(LOGINFO, "$$$$Actual file size is " & CStr(LOF(fOut)))
If bLogging Then Call AppendLog(LOGINFO, "Rewriting " & CStr(IxLFixupTable) & " Length fixup(s)")
Ix = 1
While Ix <= IxLFixupTable
With LFixupTable(Ix)
Call OutFile_PatchLength(.Offset, .Value)
End With
Ix = Ix + 1
Wend
End Sub
Public Sub OutFile_CRC16Init()
crc16 = INIT
If bCRCLogging Then Print #FxCRCLog, ">>> INIT to " & CStr(crc16)
End Sub
Private Function Cut16(l As Long) As Integer
Cut16 = bLongToWord(l)
End Function
Public Sub OutFile_CRC16UpdCRC(ByVal c As Integer)
Dim w As Long, i As Integer
On Error GoTo 0
If bCRCLogging Then Print #FxCRCLog, "Adding " & CStr(c)
w = CLng(c)
w = bSHL(w, 8) '' c <<= 8; (local copy into w)
For i = 0 To 7 '' for (i=0;i<8;i++) {
''&H8000&: the final & is MANDATORY (0.28)
If (Cut16(crc16 Xor w) And &H8000&) <> 0 Then '' if (crc16 ^ w) & 0x8000)
crc16 = Cut16(bSHL(crc16, 1)) Xor MTT '' crc16 = (crc16 << 1) ^^MTT;
Else '' else
crc16 = Cut16(bSHL(crc16, 1)) '' crc16 = crc16 << 1;
End If ''
w = bSHL(w, 1) '' w <<= 1;
Next i
End Sub
Public Function OutFile_CRC16GetCRC() As Long
Dim l As Long
l = CLng(crc16)
If l < 0 Then l = l + 65536
If bCRCLogging Then Print #FxCRCLog, "<<<< GIVES " & CStr(l)
OutFile_CRC16GetCRC = l
End Function
Public Function OutFile_CRC16ComputeOnPartOfFile(lOStart As Long, lOEnd As Long) As Long
'' assume file is open
Dim lIx As Long, b As Byte, Ix As Integer
Dim lmodE As Integer, ldivE As Long, lmodS As Integer, ldivS As Long
Dim mskE As Byte, mskS As Byte
ldivS = 1 + (lOStart \ 8) '' first byte is offset 1
lmodS = lOStart Mod 8
mskS = &HFF
For Ix = 1 To lmodS: mskS = mskS \ 2: Next Ix
ldivE = 1 + (lOEnd \ 8) '' first byte is offset 1
lmodE = lOEnd Mod 8
mskE = &H7F
For Ix = 1 To lmodE: mskE = mskE \ 2: Next Ix
mskE = Not mskE
Call OutFile_CRC16Init
If ldivS = ldivE Then
'' special case if lDivS = ldivE: range is one single byte (maybe part of)
Call OutFile_CRC16Init
Get #fOut, ldivS, b
b = (b And mskS) And mskE
Call OutFile_CRC16UpdCRC(b)
Else
'' first handle first byte
lIx = ldivS
Get #fOut, lIx, b
Call OutFile_CRC16UpdCRC(b And mskS)
lIx = lIx + 1
'' next handle all whole bytes till one BEFORE last byte
While (lIx < ldivE)
Get #fOut, lIx, b
Call OutFile_CRC16UpdCRC(b)
lIx = lIx + 1
Wend
'' finally handle last byte
Get #fOut, lIx, b
Call OutFile_CRC16UpdCRC(b And mskE)
End If
OutFile_CRC16ComputeOnPartOfFile = OutFile_CRC16GetCRC
End Function
Public Function OutFile_OpenCFixup() As Integer
If IxCFixupTable >= MAXCFIXUPTABLE Then
If bLogging Then Call AppendLog(LOGERROR, "too many CRC fixups defined")
nErrors = nErrors + 1
Else
IxCFixupTable = IxCFixupTable + 1
CFixupTable(IxCFixupTable).OffsetStart = PutBitOffset
End If
If bLogging Then Call AppendLog(LOGINFO, "$$$$Remembering CRC FIXUP position " & CStr(IxLFixupTable) & " at " & CStr(PutBitOffset))
OutFile_OpenCFixup = IxCFixupTable
End Function
Public Sub OutFile_CloseCFixup(FixupIndex As Integer)
''parameter is ignored, left to keep symmetry with OpenLFixup & CloseLFixup
CFixupTable(IxCFixupTable).OffsetStop = PutBitOffset - 1
CFixupTable(IxCFixupTable).OffsetRewrite = PutBitOffset
If bLogging Then Call AppendLog(LOGINFO, "$$$$Closing CRC FIXUP position " & CStr(FixupIndex) & " at " & CStr(PutBitOffset - 1))
End Sub
Public Sub OutFile_CRC16ProcessCFixups()
Dim lCRC As Long, Ix As Integer
''to be called AFTER purge and length fixups
If bLogging Then Call AppendLog(LOGINFO, "")
If bLogging Then Call AppendLog(LOGINFO, "$$$$Actual file size is " & CStr(LOF(fOut)))
If bLogging Then Call AppendLog(LOGINFO, "Rewriting " & CStr(IxCFixupTable) & " CRC fixup(s)")
Ix = 1
While Ix <= IxCFixupTable
With CFixupTable(Ix)
'' compute crc for range
If bLogging Then Call AppendLog(LOGINFO, "Computing CRC from " & CStr(.OffsetStart) & " to " & CStr(.OffsetStop))
lCRC = OutFile_CRC16ComputeOnPartOfFile(.OffsetStart, .OffsetStop)
'' seek to correct position and write value
Call OutFile_Rewrite32bits(.OffsetRewrite, lCRC)
If bLogging Then Call AppendLog(LOGINFO, "Setting CRC @" & CStr(.OffsetRewrite) & " to " & CStr(lCRC) & " (hex=" & Hex(lCRC) & ")")
Ix = Ix + 1
End With
Wend
End Sub
Public Function CMod(pVal As Double, pParm As Long) As Double
Dim c As String * 1
Select Case Val(Right$(Str(pVal), 1))
Case 0, 2, 4, 6, 8
CMod = 0
Case Else
CMod = 1
End Select
End Function |
Partager