B-Tree (code source) | Sujet: B-Tree (code source) par Anonyme sur 15/6/2006 20:24:56
'+--------------------------------------------------------------------------+
'| |
'| DVBTREE |
'| |
'| *** ASCIIZ VERSION *** |
'| |
'| Multi-user |
'| |
'| Subroutines written for the PowerBASIC 32-bit compilers PB/CC, PBDLL. |
'| |
'+--------------------------------------------------------------------------+
'| |
'| Author Patrice TERRIER |
'| 8 Domaine de Rochagnon. 38800 Champagnier FRANCE |
'| |
'| copyright (c) 2002 Patrice TERRIER |
'| |
'| E-mail: pterrier@zapsolution.com |
'| |
'+--------------------------------------------------------------------------+
'| ZAP Image solution |
'| http://www.zapsolution.com |
'+--------------------------------------------------------------------------+
'| |
'| Version 2.06 from 06-22-2002 |
'| |
'+--------------------------------------------------------------------------+
'
#COMPILE DLL "DVBTREE.DLL"
'-----------------------------------------------------------------
' Equates: 24
'-----------------------------------------------------------------
%WINAPI = 1
%FALSE = 0
%NULL = 0
%GENERIC_READ = &H80000000&
%GENERIC_WRITE = &H40000000&
%FILE_SHARE_READ = &H00000001
%FILE_SHARE_WRITE = &H00000002
%FILE_ATTRIBUTE_READONLY = &H00000001
%FILE_ATTRIBUTE_HIDDEN = &H00000002
%FILE_ATTRIBUTE_SYSTEM = &H00000004
%FILE_ATTRIBUTE_NORMAL = &H00000080
%INVALID_HANDLE_VALUE = -1 ' Patrice the above causes many BUGS in existing code
%FILE_BEGIN = 0
%FILE_CURRENT = 1
%FILE_FLAG_WRITE_THROUGH = &H80000000
%CREATE_ALWAYS = 2
%OPEN_ALWAYS = 4
%DLL_PROCESS_ATTACH = 1
%FILE_TYPE_DISK = &H1
%LOCALE_USER_DEFAULT = &H0000
%LOCALE_SENGLANGUAGE = &H1001 ' English name of language
%MAX_PATH = 260 ' max. length of full pathname
%MB_ICONEXCLAMATION = &H00000030&
%MB_SYSTEMMODAL = &H00001000&
'
'-----------------------------------------------------------------
' TYPE and UNION structures: 4
'-----------------------------------------------------------------
TYPE OVERLAPPED
Internal AS DWORD
InternalHigh AS DWORD
offset AS DWORD
OffsetHigh AS DWORD
hEvent AS DWORD
END TYPE
'
TYPE SECURITY_ATTRIBUTES
nLength AS DWORD
lpSecurityDescriptor AS LONG
bInheritHandle AS LONG
END TYPE
'
TYPE FILETIME
dwLowDateTime AS DWORD
dwHighDateTime AS DWORD
END TYPE
'
TYPE WIN32_FIND_DATA
dwFileAttributes AS DWORD
ftCreationTime AS FILETIME
ftLastAccessTime AS FILETIME
ftLastWriteTime AS FILETIME
nFileSizeHigh AS DWORD
nFileSizeLow AS DWORD
dwReserved0 AS DWORD
dwReserved1 AS DWORD
cFileName AS ASCIIZ * %MAX_PATH
cAlternateFileName AS ASCIIZ * 14
END TYPE
'
'-----------------------------------------------------------------
' Declared Functions: 18
'-----------------------------------------------------------------
DECLARE FUNCTION CloseHandle LIB "KERNEL32.DLL" ALIAS "CloseHandle" (BYVAL hObject AS DWORD) AS LONG
DECLARE FUNCTION CreateFile LIB "KERNEL32.DLL" ALIAS "CreateFileA" (lpFileName AS ASCIIZ, BYVAL dwDesiredAccess AS DWORD, BYVAL dwShareMode AS DWORD, lpSecurityAttributes AS SECURITY_ATTRIBUTES, BYVAL dwCreationDisposition AS DWORD, _
BYVAL dwFlagsAndAttributes AS DWORD, BYVAL hTemplateFile AS DWORD) AS DWORD
DECLARE FUNCTION DeleteFile LIB "KERNEL32.DLL" ALIAS "DeleteFileA" (lpFileName AS ASCIIZ) AS LONG
DECLARE FUNCTION FindClose LIB "KERNEL32.DLL" ALIAS "FindClose" (BYVAL hFindFile AS DWORD) AS LONG
DECLARE FUNCTION FindFirstFile LIB "KERNEL32.DLL" ALIAS "FindFirstFileA" (lpFileName AS ASCIIZ, lpFindFileData AS WIN32_FIND_DATA) AS LONG
DECLARE FUNCTION FlushFileBuffers LIB "KERNEL32.DLL" ALIAS "FlushFileBuffers" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION GetCurrentDirectory LIB "KERNEL32.DLL" ALIAS "GetCurrentDirectoryA" (BYVAL nBufferLength AS LONG, lpBuffer AS ASCIIZ) AS LONG
DECLARE FUNCTION GetFileSize LIB "KERNEL32.DLL" ALIAS "GetFileSize" (BYVAL hFile AS DWORD, lpFileSizeHigh AS LONG) AS LONG
DECLARE FUNCTION GetFileType LIB "KERNEL32.DLL" ALIAS "GetFileType" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION GetLastError LIB "KERNEL32.DLL" ALIAS "GetLastError" () AS LONG
DECLARE FUNCTION GetLocaleInfo LIB "KERNEL32.DLL" ALIAS "GetLocaleInfoA" (BYVAL Locale AS LONG, BYVAL LCType AS LONG, lpLCData AS ASCIIZ, BYVAL cchData AS LONG) AS LONG
DECLARE FUNCTION GetWindowsDirectory LIB "KERNEL32.DLL" ALIAS "GetWindowsDirectoryA" (lpBuffer AS ASCIIZ, BYVAL nSize AS DWORD) AS DWORD
DECLARE FUNCTION LockFile LIB "KERNEL32.DLL" ALIAS "LockFile" (BYVAL hFile AS DWORD, BYVAL dwFileOffsetLow AS DWORD, BYVAL dwFileOffsetHigh AS DWORD, BYVAL nNumberOfBytesToLockLow AS LONG, BYVAL nNumberOfBytesToLockHigh AS LONG) AS LONG
DECLARE FUNCTION ReadFile LIB "KERNEL32.DLL" ALIAS "ReadFile" (BYVAL hFile AS DWORD, lpBuffer AS ANY, BYVAL nNumberOfBytesToRead AS LONG, lpNumberOfBytesRead AS LONG, lpOverlapped AS OVERLAPPED) AS LONG
DECLARE FUNCTION SetEndOfFile LIB "KERNEL32.DLL" ALIAS "SetEndOfFile" (BYVAL hFile AS DWORD) AS LONG
DECLARE FUNCTION SetFilePointer LIB "KERNEL32.DLL" ALIAS "SetFilePointer" (BYVAL hFile AS DWORD, BYVAL lDistanceToMove AS LONG, lpDistanceToMoveHigh AS LONG, BYVAL dwMoveMethod AS DWORD) AS LONG
DECLARE FUNCTION UnlockFile LIB "KERNEL32.DLL" ALIAS "UnlockFile" (BYVAL hFile AS DWORD, BYVAL dwFileOffsetLow AS DWORD, BYVAL dwFileOffsetHigh AS DWORD, BYVAL nNumberOfBytesToUnlockLow AS LONG, BYVAL nNumberOfBytesToUnlockHigh AS LONG) AS LONG
DECLARE FUNCTION WriteFile LIB "KERNEL32.DLL" ALIAS "WriteFile" (BYVAL hFile AS DWORD, lpBuffer AS ANY, BYVAL nNumberOfBytesToWrite AS LONG, lpNumberOfBytesWritten AS LONG, lpOverlapped AS OVERLAPPED) AS LONG
'
#INCLUDE "DVBTREE.INC"
'
DEFLNG A-Z
'
GLOBAL Btr() AS BTRECORD, RecBuf$(), ItmPtr&(), CurRec&(), CurLvl&()
GLOBAL BtBuffer&()
GLOBAL zTmp AS ASCIIZ * %MAX_PATH
GLOBAL LockIsOn&
'
FUNCTION dvMinu$ ALIAS "dvMinu"
FUNCTION = "…ƒ‚Šˆ‰Œ‹”“–—‡„†Ž‘•˜™š ¡¢£¤"
END FUNCTION
'
FUNCTION dvMaju$ ALIAS "dvMaju"
FUNCTION = "AAEEEEIIOOUUUCAAIAAE’OYOUAIOU¥"
END FUNCTION
'
SUB dvBtLockOn ALIAS "dvBtLockOn" () EXPORT
LockIsOn& = -1
END SUB
'
SUB dvBtLockOff ALIAS "dvBtLockOff" () EXPORT
LockIsOn& = 0
END SUB
'
FUNCTION dvExist& ALIAS "dvExist" (zFileSpec AS ASCIIZ) EXPORT
'
LOCAL fd AS WIN32_FIND_DATA
'
IF LEN(zFileSpec) THEN
hFind& = FindFirstFile(zFileSpec, fd)
IF hFind& <> %INVALID_HANDLE_VALUE THEN
CALL FindClose(hFind&)
FUNCTION = -1
END IF
END IF
'
END FUNCTION
'
FUNCTION dvFOpen& ALIAS "dvFOpen" (zFilName AS ASCIIZ, BYVAL AccessMode&, BYVAL ShareMode&, hFile&) EXPORT
'
AccessMode& = MIN(MAX(AccessMode&, 0), 2) ' Coherce between 0-2
IF AccessMode& = 0 THEN ' 0 Open for read only.
AccessIs& = %GENERIC_READ
ELSEIF AccessMode& = 1 THEN ' 1 Open for write only.
AccessIs& = %GENERIC_WRITE
ELSE ' 2 Open for read and write.
AccessIs& = %GENERIC_READ OR %GENERIC_WRITE
END IF
'
ShareMode& = MIN(MAX(ShareMode&, 1), 4) ' Coherce between 1-4
IF ShareMode& = 1 THEN ' 1 Deny read/write access.
ShareIs& = 0
ELSEIF ShareMode& = 2 THEN ' 2 Deny write access.
ShareIs& = %FILE_SHARE_READ
ELSEIF ShareMode& = 3 THEN ' 3 Deny read access.
ShareIs& = %FILE_SHARE_WRITE
ELSE ' 4 Deny none (full share mode).
ShareIs& = %FILE_SHARE_READ OR %FILE_SHARE_WRITE
END IF
IF hFile& = -1 THEN
FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL OR %FILE_FLAG_WRITE_THROUGH
ELSE
FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL
END IF
'
hFile& = CreateFile(zFilName, AccessIs&, ShareIs&, BYVAL %NULL, %OPEN_ALWAYS, FlagAndAttribute&, BYVAL %NULL)
'
IF hFile& = %INVALID_HANDLE_VALUE THEN ' -1 Fail to create the file
FUNCTION = GetLastError ' Set the error code
hFile& = 0 ' Reset handle number
END IF
'
END FUNCTION
'
SUB dvFClose ALIAS "dvFClose" (hFile&) EXPORT
IF hFile& THEN CALL CloseHandle(hFile&)
hFile& = 0
END SUB
'
FUNCTION dvFPut& ALIAS "dvFPut" (BYVAL hFile&, zBuf AS ASCIIZ) EXPORT
IF hFile& THEN
LenBuf& = LEN(zBuf)
IF LenBuf& THEN
IF WriteFile&(hFile&, zBuf, LenBuf&, ByttesWritten&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION dvFSeek& ALIAS "dvFSeek" (hFile&, BYVAL PosByte&) EXPORT
IF SetFilePointer(hFile&, PosByte&, BYVAL %NULL, %FILE_BEGIN) < 0 THEN
FUNCTION = GetLastError
END IF
END FUNCTION
'
FUNCTION dvFLoc& ALIAS "dvFLoc" (hFile&) EXPORT
' Warning this function returns &hFFFFFFFF (-1) in case of error
FUNCTION = SetFilePointer(hFile&, 0&, BYVAL %NULL, %FILE_CURRENT)
END FUNCTION
'
FUNCTION dvFPutAt& ALIAS "dvFPutAt" (BYVAL hFile&, BYVAL PosByte&, zBuf AS ASCIIZ) EXPORT
ErrCode& = dvFSeek&(hFile&, PosByte&)
IF ErrCode& = 0 THEN ErrCode& = dvFPut&(hFile&, zBuf)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFPutR& ALIAS "dvFPutR" (BYVAL hFile&, zBuf AS ASCIIZ, BYVAL Record&) EXPORT
LenBuf& = LEN(zBuf)
Record& = Record& * LenBuf& - LenBuf&
ErrCode& = dvFSeek&(hFile&, Record&)
IF ErrCode& = 0 THEN ErrCode& = dvFPut& (hFile&, zBuf)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION FPut& (BYVAL hFile&, Buf$)
IF hFile& THEN
LenBuf& = LEN(Buf$)
IF LenBuf& THEN
IF WriteFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesWritten&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION FPutR& (BYVAL hFile&, Buf$, BYVAL Record&)
LenBuf& = LEN(Buf$)
Record& = Record& * LenBuf& - LenBuf&
ErrCode& = dvFSeek&(hFile&, Record&)
IF ErrCode& = 0 THEN ErrCode& = FPut& (hFile&, Buf$)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFGet& ALIAS "dvFGet" (BYVAL hFile&, zBuf AS ASCIIZ) EXPORT
IF hFile& THEN
LenBuf& = LEN(zBuf)
IF LenBuf& THEN
IF ReadFile&(hFile&, zBuf, LenBuf&, ByttesReaded&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION dvFGetR& ALIAS "dvFGetR" (BYVAL hFile&, zBuf AS ASCIIZ, BYVAL Record&) EXPORT
LenBuf& = LEN(Buf$)
Record& = Record& * LenBuf& - LenBuf&
ErrCode& = dvFSeek&(hFile&, Record&)
IF ErrCode& = 0 THEN ErrCode& = dvFGet& (hFile&, zBuf)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION FGet& (BYVAL hFile&, Buf$)
IF hFile& THEN
LenBuf& = LEN(Buf$)
IF LenBuf& THEN
IF ReadFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesReaded&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION FGetR& (BYVAL hFile&, Buf$, BYVAL Record&)
LenBuf& = LEN(Buf$)
Record& = Record& * LenBuf& - LenBuf&
ErrCode& = dvFSeek&(hFile&, Record&)
IF ErrCode& = 0 THEN ErrCode& = FGet& (hFile&, Buf$)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFGetAt& ALIAS "dvFGetAt" (BYVAL hFile&, BYVAL PosByte&, zBuf AS ASCIIZ) EXPORT
ErrCode& = dvFSeek&(hFile&, PosByte&)
IF ErrCode& = 0 THEN ErrCode& = dvFGet&(hFile&, zBuf)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFlush& ALIAS "dvFlush" (BYVAL hFile&) EXPORT
IF hFile& THEN
IF FlushFileBuffers(hFile&) = 0 THEN FUNCTION = GetLastError
END IF
END FUNCTION
'
FUNCTION dvFlof& ALIAS "dvFlof" (BYVAL hFile&) EXPORT
IF GetFileType(hFile&) = %FILE_TYPE_DISK THEN
fSize& = GetFileSize(hFile&, BYVAL %NULL)
IF fSize& > -1& THEN FUNCTION = fSize&
END IF
END FUNCTION
'
FUNCTION dvKillFile& ALIAS "dvKillFile" (zFullName AS ASCIIZ) EXPORT
LOCAL zPathName AS ASCIIZ * %MAX_PATH
LOCAL zFilterName AS ASCIIZ * %MAX_PATH
CALL dvSplitN (zFullName, zPathName, zFilterName)
ToKill$ = DIR$(zFullName)
DO WHILE LEN(ToKill$)
zTmp = zPathName + ToKill$
IF DeleteFile(zTmp) = 0 THEN FUNCTION = GetLastError: EXIT DO
ToKill$ = DIR$
LOOP
END FUNCTION
'
FUNCTION dvInstrB& ALIAS "dvInstrB" (BYVAL FromPos&, zItem AS ASCIIZ, zSearch AS ASCIIZ) EXPORT
Item$ = zItem: Search$ = zSearch
' Uses FromPos < 1 TO start search from end of Item$
DIM P1 AS BYTE PTR, P2 AS BYTE PTR
Length& = LEN(Item$)
' Don't search out of the string limit
IF FromPos& < 1 OR FromPos& > Length& THEN FromPos& = Length&
P1 = STRPTR(Item$): P2 = P1 + Length& - 1
' Reverse Item$ string
FOR P& = 1 TO Length& \ 2: SWAP @P1, @P2: INCR P1: DECR P2: NEXT
' Reverse Search$ string
LenS& = LEN(Search$)
P1 = STRPTR(Search$): P2 = P1 + LenS& - 1
FOR P& = 1 TO LenS& \ 2: SWAP @P1, @P2: INCR P1: DECR P2: NEXT
So& = INSTR(Length& - FromPos& + 1, Item$, Search$)
IF So& THEN FUNCTION = Length& - So& + 2 - LenS&
END FUNCTION
'
SUB dvSplitN ALIAS "dvSplitN" (zFullName AS ASCIIZ, zPathName AS ASCIIZ, zFilName AS ASCIIZ) EXPORT
' Split a full path name, and return the current disk and directory
' if fullname$ contents only FilName$
' works with "..\" too
LOCAL zDsk AS ASCIIZ * 3
LOCAL zThisPath AS ASCIIZ * %MAX_PATH
Length& = LEN(zFullName)
IF Length& THEN
So& = INSTR(zFullName, "..\"): IF So& = 1 THEN So& = 4 ELSE So& = 1
L& = Length& - So& + 1
S2& = INSTR(zFullName, " ")
IF S2& THEN L& = LEN(LEFT$(zFullName, S2& - 1)) - So& + 1
CALL dvDskPath(zDsk, zThisPath): zFilName = zFullName
So& = dvInstrB(Length&, zFullName, "\")
IF So& THEN
zPathName = LEFT$(zFullName, So&)
ELSE
So& = INSTR(zFullName, ":")
END IF
IF zPathName = zDsk OR LEN(zPathName) = 0 THEN
zPathName = zDsk + zThisPath
END IF
IF So& THEN zFilName = MID$(zFullName, So& + 1, Length& - So&)
END IF
'
END SUB
'
FUNCTION dvUcase$ ALIAS "dvUcase" (zStringToConvert AS ASCIIZ) EXPORT
StringToConvert$ = zStringToConvert
REPLACE ANY dvMinu$ WITH dvMaju$ IN StringToConvert$
FUNCTION = UCASE$(StringToConvert$)
END FUNCTION
'
SUB dvDskPath ALIAS "dvDskPath" (zDsk AS ASCIIZ, zPath AS ASCIIZ) EXPORT
' Dsk$ and Path$ are ready to be concatened with a filename
' Dsk$ and Paths correspond to the current directory
IF GetCurrentDirectory(BYVAL SIZEOF(zTmp), zTmp) THEN
zDsk = LEFT$(zTmp, 2)
zPath = RTRIM$(MID$(zTmp, 3), ANY CHR$(0,92)) + "\"
END IF
END SUB
'
FUNCTION dvSetEof& ALIAS "dvSetEof" (BYVAL hFile&) EXPORT
IF SetEndOfFile(hFile&) = 0 THEN FUNCTION = GetLastError
END FUNCTION
'
FUNCTION dvSetEofAt& ALIAS "dvSetEofAt" (BYVAL hFile&, BYVAL PosByte&) EXPORT
ErrCode& = dvFSeek&(hFile&, PosByte&)
IF ErrCode& = 0 THEN ErrCode& = dvSetEof&(hFile&)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION dvFSetSize& ALIAS "dvFSetSize" (zFilName AS ASCIIZ, BYVAL PosByte&) EXPORT
'
ErrCode& = dvFOpen(zFilName, 1, 1, hFile&)
IF ErrCode& = 0 THEN ErrCode& = dvSetEofAt& (hFile&, PosByte&)
CALL dvFClose(hFile&)
FUNCTION = ErrCode&
FilName$ = ""
'
END FUNCTION
'
FUNCTION dvFLock& ALIAS "dvFLock" (BYVAL hFile&, BYVAL OffSet&, BYVAL Length&) EXPORT
IF LockFile(hFile&, OffSet&, BYVAL 0&, Length&, BYVAL 0&) = 0 THEN
FUNCTION = GetLastError
END IF
END FUNCTION
'
FUNCTION dvFUnLock& ALIAS "dvFUnLock" (BYVAL hFile&, BYVAL OffSet&, BYVAL Length&) EXPORT
IF UnLockFile(hFile&, OffSet&, BYVAL 0&, Length&, BYVAL 0&) = 0 THEN
FUNCTION = GetLastError
END IF
END FUNCTION
'
FUNCTION LibMain& (BYVAL DllInstance&, BYVAL Reason&, BYVAL Reserved&) EXPORT
REDIM Btr(0) AS BTRECORD, RecBuf$(0), ItmPtr&(0), CurRec&(0), CurLvl&(0)
REDIM BtBuffer&(0)
LockIsOn& = -1 ' Turn it On
FUNCTION = 1
END FUNCTION
'
FUNCTION BtTestBuffer& (BYVAL hFile&)
'
IF LBOUND(BtBuffer&) = 0 THEN bOne& = -1
ARRAY SCAN BtBuffer&(), = hFile&, TO I&
FUNCTION = I& + bOne&
'
END FUNCTION
'
FUNCTION BtGetKeyPl$ (BYVAL Position&, BYVAL uBT&)
FUNCTION = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).Keylen)
END FUNCTION
'
FUNCTION BtGetRec& (BYVAL Position&, BYVAL uBT&)
FUNCTION = CVL(MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).Klen, 4))
END FUNCTION
'
FUNCTION BtGetRecPtr& (BYVAL Position&, BYVAL uBT&)
IF Position& = 0 THEN
Offset& = 2
ELSE
Offset& = 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).KeyLen
END IF
FUNCTION = CVL(MID$(RecBuf$(uBT&), Offset&, 4))
END FUNCTION
'
SUB BtSetRecPtr (BYVAL Position&, BYVAL Dt&, BYVAL uBT&)
IF Position& = 0 THEN
Offset& = 2
ELSE
Offset& = 6 + Btr(uBT&).ItmLen * (Position& - 1) + Btr(uBT&).KeyLen
END IF
MID$(RecBuf$(uBT&), Offset&, 4) = MKL$(Dt&)
END SUB
'
FUNCTION BtGetItm$ (BYVAL Position&, BYVAL uBT&)
FUNCTION = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).ItmLen)
END FUNCTION
'
SUB BtSetItm (BYVAL Position&, BYVAL Dt$, BYVAL uBT&)
MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Position& - 1), Btr(uBT&).ItmLen) = Dt$
END SUB
'
FUNCTION Bt& (BYVAL hBtFile&, BYVAL UsrAct&, zRKey AS ASCIIZ, Record&, BtErr&)
'
uBT& = BtTestBuffer&(hBtFile&)
IF uBT& < 1 THEN ' No Btree handle available
Bterr& = 9: EXIT FUNCTION
END IF
'
DIM Stk&(53, 0 TO 1)
'
DtaIn& = Record&: Record& = 0
'
Ky$ = SPACE$(Btr(uBT&).Klen)
WasKey$ = dvUcase(zRKey): LenWasKey& = LEN(WasKey$)
LSET Ky$ = WasKey$: zRKey = ""
'
BtErr& = 0
BtStart:
IF BtErr& = 0 THEN
'
IF LockIsOn& THEN ' Check if the lock flag is turned On or Off
Strt& = TIMER: BtErr& = 3
DO
ErrCode& = dvFLock&(hBtFile&, 0&, 1024&)
IF ErrCode& = 0& THEN BtErr& = 0: EXIT DO
LOOP UNTIL ABS(TIMER - Strt&) > 5
END IF
'
IF BtErr& = 0 THEN
SELECT CASE UsrAct&
CASE 70 ' "F" Get First Key
CurLvl&(uBT&) = 0: GOSUB BtGetNext
CASE 76 ' "L" Get Last Key
CurLvl&(uBT&) = 0: GOSUB BtGetPrev
CASE 71, 83 ' "G" Get exact match
KeyFull$ = Ky$ + MKL$(DtaIn&) ' "S" Search for key
GOSUB BtSearch
IF BtErr& = 1 AND BtGetRec&(ItmPtr&(uBT&), uBT&) > 0 THEN
IF ItmPtr&(uBT&) THEN
FullKey$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&)
IF UsrAct& = 83 AND LenWasKey& THEN
IF LEFT$(FullKey$, LenWasKey&) = WasKey$ THEN BtErr& = 0
ELSEIF LEFT$(KeyFull$, Btr(uBT&).Klen) = LEFT$(FullKey$, Btr(uBT&).Klen) THEN
BtErr& = 0
END IF
END IF
IF BtErr& = 1 THEN ItmPtr&(uBT&) = 0
END IF
CASE 85 ' "U" Add a unique key
KeyFull$ = Ky$ + MKL$(DtaIn&)
' Alias BtAddUnique
Temp& = 1: GOSUB BtNonUniq
IF BtErr& = 0 THEN
BtErr& = 2 ' Means duplicated key
ELSE
GOSUB BtAddAtCur
END IF
CASE 68 ' "D" Delete the key/data given
KeyFull$ = Ky$ + MKL$(DtaIn&)
GOSUB BtSearch
DO UNTIL BtErr& = 1
IF ItmPtr&(uBT&) = 0 THEN BtErr& = 1: EXIT DO
IF KeyFull$ <> BtGetKeyPl$(ItmPtr&(uBT&), uBT&) THEN
BtErr& = 1: EXIT DO
END IF
IF DtaIn& = BtGetRec&(ItmPtr&(uBT&), uBT&) THEN
GOSUB BtDelCur: BtErr& = 0
EXIT DO
ELSE
GOSUB BtGetNext
END IF
LOOP
'
CASE 78, 69 ' "N" Get Next Key ; "E" End
KeyFull$ = Ky$ + MKL$(DtaIn&)
GOSUB BtSearch
GOSUB BtGetNext
'
' This line was added with Pascal on 05-23-1999
IF ItmPtr&(uBT&) = 0 AND Bterr& = 0 THEN Bterr& = 1
'
CASE 80, 66 ' "P" Get Previous Key - "B" begin
KeyFull$ = Ky$ + MKL$(DtaIn&)
GOSUB BtSearch
GOSUB BtGetPrev
CASE ELSE ' Error in Action code
zRKey = "": BtErr& = 8
END SELECT
'
IF LockIsOn& THEN ErrCode& = dvFUnlock&(hBtFile&, 0&, 1024&)
IF ErrCode& THEN BtErr& = 4
END IF
END IF
IF BtErr& < 2 THEN ' IF Lock was effectiv
IF BtErr& = 0 AND INSTR("AUD", CHR$(UsrAct&)) > 0 THEN
LSET RecBuf$(uBT&) = Btr(uBT&)
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), 1&) ' FLUSH (hBtFile&)
END IF
'
IF ItmPtr&(uBT&) THEN
IF UsrAct& = 85 THEN ' Insert
zRKey = WasKey$
Record& = DtaIn&
ELSE
FullKey$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&)
zRKey = LEFT$(FullKey$, Btr(uBT&).Klen)
Record& = CVL(RIGHT$(FullKey$, 4))
END IF
ELSE
zRKey = WasKey$
Record& = 0
END IF
'
' Version 2.02 Search before or after the specified key 03-29-2000
IF INSTR("BE", CHR$(UsrAct&)) THEN
LSET Ky$ = zRKey
DtaIn& = Record&
UsrAct& = 83 ' "S"
GOTO BtStart
END IF
'
ELSE
zRKey = "": Record& = 0
END IF
'
FUNCTION = ErrCode&
'
EXIT FUNCTION
'
BtPop:
CurLvl&(uBT&) = CurLvl&(uBT&) - 1
'
BtGetStackNode:
CurRec&(uBT&) = Stk&(CurLvl&(uBT&), 0)
ItmPtr&(uBT&) = Stk&(CurLvl&(uBT&), 1)
'
BtGetCur:
RecBuf$(uBT&) = STRING$(1024, 0)
IF CurRec&(uBT&) * 1024 > dvFLof&(hBtFile&) THEN
ErrCode& = FPutR(hBtFile&, (RecBuf$(uBT&)), CurRec&(uBT&))
END IF
ErrCode& = FGetR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
RETURN
'
BtPush:
Stk&(CurLvl&(uBT&), 0) = CurRec&(uBT&)
Stk&(CurLvl&(uBT&), 1) = ItmPtr&(uBT&)
RETURN
'
BtSearch: '*** SEARCH FOR FIRST OCCURANCE OF KEY ***
Temp& = 0
BtNonUniq:
BtErr& = 1
CurLvl&(uBT&) = 1
CurRec&(uBT&) = Btr(uBT&).RootNode
BtScanNode:
GOSUB BtGetCur
ItmPtr&(uBT&) = 1
Cnt& = ASC(RecBuf$(uBT&))
BtScanNodeLoop:
WrkHlf& = INT((ItmPtr&(uBT&) + Cnt&) / 2)
IF WrkHlf& = 0 THEN
ItmPtr&(uBT&) = WrkHlf& + 1
ELSE
BGKP$ = BtGetKeyPl$(WrkHlf&, uBT&)
IF KeyFull$ > BGKP$ OR (Temp& < 0 AND KeyFull$ = BGKP$) THEN
ItmPtr&(uBT&) = WrkHlf& + 1
ELSE
Cnt& = WrkHlf& - 1
END IF
END IF
'
IF Cnt& >= ItmPtr&(uBT&) THEN
GOTO BtScanNodeLoop
ELSE
GOSUB BtPush
IF ItmPtr&(uBT&) <= ASC(RecBuf$(uBT&)) THEN
IF KeyFull$ = BtGetKeyPl$(ItmPtr&(uBT&), uBT&) THEN
BtErr& = 0
IF BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&) = 0 THEN RETURN
END IF
END IF
END IF
'
RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
IF RecPtr& > 0 THEN
CurRec&(uBT&) = RecPtr&
CurLvl&(uBT&) = CurLvl&(uBT&) + 1
GOTO BtScanNode
END IF
IF BtErr& = 0 THEN GOTO BtGetNextLeftSon
IF Temp& = 0 THEN GOSUB BtGetNextOk: BtErr& = 1
RETURN
'
BtAddAtCur: '*** ADD KEY AT CURRENT NODE LOCATION ***
TmpAdd$ = KeyFull$ + MKL$(0)
Temp& = 0
BtCheckFull:
IF ASC(RecBuf$(uBT&)) < Btr(uBT&).HlfNode * 2 THEN
Cnt& = ASC(RecBuf$(uBT&)) + 1
ASC(RecBuf$(uBT&), 1) = Cnt&
GOSUB BtInsInNode
CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Temp&, uBT&)
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) + 1
INCR Btr(uBT&).Numkeys
TmpAdd$ = "": Temp$ = "": Emerg$ = ""
BtErr& = 0
RETURN
END IF
IF ItmPtr&(uBT&) > Btr(uBT&).HlfNode + 1 THEN
GOTO BtAddRight
ELSEIF ItmPtr&(uBT&) = Btr(uBT&).HlfNode + 1 THEN
Emerg$ = TmpAdd$
ELSE
Emerg$ = BtGetItm$(Btr(uBT&).HlfNode, uBT&)
Cnt& = Btr(uBT&).HlfNode
GOSUB BtInsInNode
END IF
CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Temp&, uBT&)
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).HlfNode * (Btr(uBT&).ItmLen), Btr(uBT&).HlfNode * Btr(uBT&).ItmLen)
Temp$ = Tmp2$
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
Temp& = CurRec&(uBT&)
GOSUB BtGetAvailableNode
GOSUB BtSetCopy
GOSUB BtSetRightSon
GOTO BtWriteNode
'
BtAddRight:
Tmp2$ = MID$(RecBuf$(uBT&), 2, 4 + Btr(uBT&).HlfNode * (Btr(uBT&).ItmLen))
Temp$ = Tmp2$
ItmPtr&(uBT&) = ItmPtr&(uBT&) - Btr(uBT&).HlfNode
Emerg$ = BtGetItm$(Btr(uBT&).HlfNode + 1, uBT&)
FOR Cnt& = 1 TO ItmPtr&(uBT&) - 2
CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + Btr(uBT&).HlfNode + 1, uBT&), uBT&)
NEXT
CALL BtSetItm(ItmPtr&(uBT&) - 1, TmpAdd$, uBT&)
IF ItmPtr&(uBT&) > Btr(uBT&).HlfNode THEN
GOTO BtSetLeftSon
ELSE
FOR Cnt& = ItmPtr&(uBT&) TO Btr(uBT&).HlfNode
CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + Btr(uBT&).HlfNode, uBT&), uBT&)
NEXT
END IF
'
BtSetLeftSon:
GOSUB BtSetRightSon
CALL BtSetRecPtr(ItmPtr&(uBT&) - 2, Temp&, uBT&)
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetAvailableNode
Tmp2$ = MID$(RecBuf$(uBT&), 2, LEN(Temp$))
LSET Tmp2$ = Temp$
MID$(RecBuf$(uBT&), 2, LEN(Temp$)) = Tmp2$
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
Temp& = CurRec&(uBT&)
BtWriteNode:
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
TmpAdd$ = Emerg$: CurLvl&(uBT&) = CurLvl&(uBT&) - 1
IF CurLvl&(uBT&) = 0 THEN
GOSUB BtGetAvailableNode
ItmPtr&(uBT&) = 1
Btr(uBT&).RootNode = CurRec&(uBT&)
CALL BtSetRecPtr(0, Temp&, uBT&)
GOTO BtCheckFull
ELSE
GOSUB BtGetStackNode
GOTO BtCheckFull
END IF
'
BtInsInNode:
FOR Cnt& = Cnt& TO ItmPtr&(uBT&) + 1 STEP -1
CALL BtSetItm(Cnt&, BtGetItm$(Cnt& - 1, uBT&), uBT&)
NEXT
CALL BtSetItm(ItmPtr&(uBT&), TmpAdd$, uBT&)
RETURN
'
BtGetAvailableNode:
IF Btr(uBT&).LastDel > 0 THEN
CurRec&(uBT&) = Btr(uBT&).LastDel: GOSUB BtGetCur: Btr(uBT&).LastDel = BtGetRecPtr(0, uBT&)
ELSE
CurRec&(uBT&) = Btr(uBT&).NxtNode: GOSUB BtGetCur: Btr(uBT&).NxtNode = Btr(uBT&).NxtNode + 1
END IF
Btr(uBT&).NumAct = Btr(uBT&).NumAct + 1
ASC(RecBuf$(uBT&), 1) = 0
RETURN
'
BtSetRightSon:
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode
CALL BtSetRecPtr(0, CVL(RIGHT$(Emerg$, 4)), uBT&)
MID$(Emerg$, LEN(Emerg$) - 3, 4) = MKL$(CurRec&(uBT&))
RETURN
'
BtSetCopy:
Tmp2$ = MID$(RecBuf$(uBT&), 6, LEN(Temp$))
LSET Tmp2$ = Temp$
MID$(RecBuf$(uBT&), 6, LEN(Temp$)) = Tmp2$
RETURN
'
BtGetNext: '*** Get Next Key in the Index ***
IF CurLvl&(uBT&) = 0 THEN
CurRec&(uBT&) = Btr(uBT&).RootNode: CurLvl&(uBT&) = 1: ItmPtr&(uBT&) = 1
ELSE
ItmPtr&(uBT&) = ItmPtr&(uBT&) + 1
END IF
BtGetNextLeftSon:
GOSUB BtGetCur
RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
IF RecPtr& <> 0 THEN
GOSUB BtPush
CurRec&(uBT&) = RecPtr&
CurLvl&(uBT&) = CurLvl&(uBT&) + 1: ItmPtr&(uBT&) = 1
GOTO BtGetNextLeftSon
END IF
BtGetNextOk:
IF ItmPtr&(uBT&) <= ASC(RecBuf$(uBT&)) THEN
BtErr& = 0
RETURN
ELSEIF CurLvl&(uBT&) = 1 THEN
CurLvl&(uBT&) = 0
BtErr& = 1
RETURN
ELSE
GOSUB BtPop
GOTO BtGetNextOk
END IF
'
BtGetPrev: '*** Get Previous Key in the Index ***
IF CurLvl&(uBT&) = 0 THEN
CurRec&(uBT&) = Btr(uBT&).RootNode
ELSE
GOTO BtGetPreviousRight
END IF
BtDwn1:
CurLvl&(uBT&) = CurLvl&(uBT&) + 1
GOSUB BtGetCur
ItmPtr&(uBT&) = ASC(RecBuf$(uBT&)) + 1
BtGetPreviousRight:
GOSUB BtPush
RecPtr& = BtGetRecPtr(ItmPtr&(uBT&) - 1, uBT&)
IF RecPtr& > 0 THEN
CurRec&(uBT&) = RecPtr&
GOTO BtDwn1
END IF
DO
IF ItmPtr&(uBT&) > 1 THEN
ItmPtr&(uBT&) = ItmPtr&(uBT&) - 1
BtErr& = 0
EXIT DO
ELSEIF CurLvl&(uBT&) = 1 THEN
BtErr& = 1
CurLvl&(uBT&) = 0
EXIT DO
END IF
GOSUB BtPop
LOOP
RETURN
'
BtDelCur: '*** Delete The Key at the Current Place in the Index ***
GOSUB BtPush
IF BtGetRecPtr(ItmPtr&(uBT&), uBT&) > 0 THEN
GOSUB BtGetNext
TmpAdd$ = BtGetItm$(ItmPtr&(uBT&), uBT&)
GOSUB BtGetPrev
GOSUB BtRepFthItem
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetNext
GOTO BtDelCur
ELSE
GOSUB BtDecrNode
IF ItmPtr&(uBT&) - 1 <> ASC(RecBuf$(uBT&)) THEN
GOSUB BtShfFmRht
END IF
END IF
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
IF (CurRec&(uBT&) = Btr(uBT&).RootNode) OR (ASC(RecBuf$(uBT&)) >= Btr(uBT&).HlfNode) THEN
GOTO BtDCDone
END IF
DO
GOSUB BtUnderflow
LOOP UNTIL BtErr& = 1
BtDCDone:
Btr(uBT&).Numkeys = Btr(uBT&).Numkeys - 1
RETURN ' 05-05-2001
'
BtDecrNode:
ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - 1
RETURN
'
BtUnderflow:
BtErr& = 0: GOSUB BtPop
IF ASC(RecBuf$(uBT&)) = ItmPtr&(uBT&) - 1 THEN
GOTO BtUnf2Lft
ELSE
CurRec&(uBT&) = BtGetRecPtr(ItmPtr&(uBT&), uBT&)
GOSUB BtGetMVBL
Emerg$ = MKL$(BtGetRecPtr(0, uBT&))
END IF
IF WrkHlf& <= 0 THEN
GOTO BtMrgRht
ELSE
Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).ItmLen * (WrkHlf& - 1))
Temp$ = Tmp2$
TmpAdd$ = BtGetItm$(WrkHlf&, uBT&)
CALL BtSetRecPtr(0, BtGetRecPtr(WrkHlf&, uBT&), uBT&)
ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - WrkHlf&
IF ASC(RecBuf$(uBT&)) > 0 THEN
FOR Cnt& = 1 TO ASC(RecBuf$(uBT&))
CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + WrkHlf&, uBT&), uBT&)
NEXT
END IF
END IF
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetStackNode
Temp$ = BtGetItm$(ItmPtr&(uBT&), uBT&) + Temp$
GOSUB BtRepFthItem
GOSUB BtWriteFth
Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$))
LSET Tmp2$ = Temp$
MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$)) = Tmp2$
CALL BtSetRecPtr(Btr(uBT&).HlfNode, CVL(Emerg$), uBT&)
GOTO BtAdjCnt
'
BtMrgRht:
Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).HlfNode * Btr(uBT&).ItmLen)
Temp$ = Tmp2$
Tmp2$ = MKL$(BtGetRecptr(0, uBT&))
ASC(RecBuf$(uBT&), 1) = 0
CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
Btr(uBT&).LastDel = CurRec&(uBT&)
Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetStackNode
CALL BtSetRecPtr(ItmPtr&(uBT&), CVL(Tmp2$), uBT&)
Temp$ = BtGetItm$(ItmPtr&(uBT&), uBT&) + Temp$
GOSUB BtDecrNode
IF CurRec&(uBT&) = Btr(uBT&).RootNode AND ASC(RecBuf$(uBT&)) = 0 THEN
Btr(uBT&).RootNode = Stk&(CurLvl&(uBT&) + 1, 0)
CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
Btr(uBT&).LastDel = CurRec&(uBT&)
Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
BtErr& = 1
GOTO BtWriteModFth
END IF
IF (ASC(RecBuf$(uBT&)) >= Btr(uBT&).HlfNode) OR (CurRec&(uBT&) = Btr(uBT&).RootNode) THEN
BtErr& = 1
END IF
IF ASC(RecBuf$(uBT&)) >= ItmPtr&(uBT&) THEN GOSUB BtShfFmRht
'
BtWriteModFth:
GOSUB BtWriteFth
Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$))
LSET Tmp2$ = Temp$
MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (Btr(uBT&).HlfNode - 1), LEN(Temp$)) = Tmp2$
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode * 2
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
IF BtErr& = 0 THEN GOSUB BtPop
RETURN
'
BtUnf2Lft:
CurRec&(uBT&) = BtGetRecPtr(ItmPtr&(uBT&) - 2, uBT&)
GOSUB BtGetMVBL
IF WrkHlf& <= 0 THEN GOTO BtMrgLft
ASC(RecBuf$(uBT&), 1) = ASC(RecBuf$(uBT&)) - WrkHlf&
TmpAdd$ = BtGetItm$(ASC(RecBuf$(uBT&)) + 1, uBT&)
Tmp2$ = MID$(RecBuf$(uBT&), 6 + Btr(uBT&).ItmLen * (ASC(RecBuf$(uBT&)) + 1), Btr(uBT&).ItmLen * (WrkHlf& - 1))
Temp$ = Tmp2$
Emerg$ = MKL$(BtGetRecPtr(ASC(RecBuf$(uBT&)) + 1, uBT&))
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetStackNode
Temp$ = Temp$ + BtGetItm$(ItmPtr&(uBT&) - 1, uBT&)
CALL BtSetItm(ItmPtr&(uBT&) - 1, TmpAdd$, uBT&)
CALL BtSetRecPtr(ItmPtr&(uBT&) - 1, Stk&(CurLvl&(uBT&) + 1, 0), uBT&)
GOSUB BtWriteFth
IF Btr(uBT&).HlfNode > 1 THEN
FOR Cnt& = Btr(uBT&).HlfNode - 1 TO 1 STEP -1
CALL BtSetItm(Cnt& + WrkHlf&, BtGetItm$(Cnt&, uBT&), uBT&)
NEXT
END IF
GOSUB BtSetCopy
CALL BtSetRecPtr(WrkHlf&, BtGetRecPtr(0, uBT&), uBT&)
CALL BtSetRecPtr(0, CVL(Emerg$), uBT&)
BtAdjCnt:
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode - 1 + WrkHlf&
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
BtErr& = 1
RETURN
'
BtMrgLft:
Tmp2$ = MID$(RecBuf$(uBT&), 2, 4 + ASC(RecBuf$(uBT&)) * Btr(uBT&).ItmLen)
Temp$ = Tmp2$
ASC(RecBuf$(uBT&), 1) = 0
CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
Btr(uBT&).LastDel = CurRec&(uBT&)
Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
GOSUB BtGetStackNode
Temp$ = Temp$ + LEFT$(BtGetItm$(ItmPtr&(uBT&) - 1, uBT&), Btr(uBT&).ItmLen - 4) ' 05-20-2001
CALL BtSetRecPtr(ItmPtr&(uBT&) - 2, Stk&(CurLvl&(uBT&) + 1, 0), uBT&)
GOSUB BtDecrNode
BtErr& = 1
IF CurRec&(uBT&) = Btr(uBT&).RootNode AND ASC(RecBuf$(uBT&)) = 0 THEN
Btr(uBT&).RootNode = Stk&(CurLvl&(uBT&) + 1, 0)
CALL BtSetRecPtr(0, Btr(uBT&).LastDel, uBT&)
Btr(uBT&).LastDel = CurRec&(uBT&)
Btr(uBT&).NumAct = Btr(uBT&).NumAct - 1
ELSEIF (CurRec&(uBT&) <> Btr(uBT&).RootNode) AND (ASC(RecBuf$(uBT&)) < Btr(uBT&).HlfNode) THEN
BtErr& = 0
END IF
GOSUB BtWriteFth
Tmp2$ = MID$(RecBuf$(uBT&), 6, Btr(uBT&).ItmLen * ASC(RecBuf$(uBT&)))
Temp$ = Temp$ + MKL$(BtGetRecPtr(0, uBT&)) + Tmp2$
'
Tmp2$ = MID$(RecBuf$(uBT&), 2, LEN(Temp$)) ' 05-05-2001
'
LSET Tmp2$ = Temp$
MID$(RecBuf$(uBT&), 2, LEN(Temp$)) = Tmp2$
ASC(RecBuf$(uBT&), 1) = Btr(uBT&).HlfNode * 2
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
IF BtErr& = 0 THEN GOSUB BtPop
RETURN
'
BtShfFmRht:
FOR Cnt& = ItmPtr&(uBT&) TO ASC(RecBuf$(uBT&))
CALL BtSetItm(Cnt&, BtGetItm$(Cnt& + 1, uBT&), uBT&)
NEXT
RETURN
'
BtWriteFth:
ErrCode& = FPutR(hBtFile&, RecBuf$(uBT&), CurRec&(uBT&))
CurLvl&(uBT&) = CurLvl&(uBT&) + 1
GOSUB BtGetStackNode
RETURN
'
BtGetMVBL:
GOSUB BtGetCur
WrkHlf& = INT((ASC(RecBuf$(uBT&)) - Btr(uBT&).HlfNode + 1) / 2)
RETURN
'
BtRepFthItem:
Tmp2$ = MKL$(BtGetRecPtr(ItmPtr&(uBT&), uBT&))
CALL BtSetItm(ItmPtr&(uBT&), TmpAdd$, uBT&)
CALL BtSetRecPtr(ItmPtr&(uBT&), CVL(Tmp2$), uBT&)
RETURN
'
END FUNCTION'BT
'
FUNCTION dvBtClose& ALIAS "dvBtClose" (BYVAL hBtFile&) EXPORT
'
uBT& = BtTestBuffer(hBtFile&)
' Write the record before closing it
LSET RecBuf$(uBT&) = Btr(uBT&)
FUNCTION = FPutR(hBtFile&, RecBuf$(uBT&), 1)
CALL dvFClose(hBtFile&)
'
BtBuffer&(uBT&) = 0
RecBuf$(uBT&) = ""
ItmPtr&(uBT&) = 0
CurRec&(uBT&) = 0
CurLvl&(uBT&) = 0
'
END FUNCTION
'
FUNCTION dvBtDelete& ALIAS "dvBtDelete" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
WasRecord& = Record&
FUNCTION = Bt&(hBtFile&, 68, zRKey, Record&, BtErr&)
Record& = WasRecord&
END FUNCTION
'
FUNCTION dvBtFirst& ALIAS "dvBtFirst" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
Record& = 0
FUNCTION = Bt&(hBtFile&, 70, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtInsert& ALIAS "dvBtInsert" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
' Add only unique keys
FUNCTION = Bt&(hBtFile&, 85, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtLast& ALIAS "dvBtLast" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
Record& = 0
FUNCTION = Bt&(hBtFile&, 76, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtMatch& ALIAS "dvBtMatch" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
' Must match exactly to the key
Record& = 0
FUNCTION = Bt&(hBtFile&, 71, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtNext& ALIAS "dvBtNext" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
FUNCTION = Bt&(hBtFile&, 78, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtOpen& ALIAS "dvBtOpen" (zFilName AS ASCIIZ, BYVAL Klen&, hBtFile&, BtErr&) EXPORT
'
BtErr& = 0: Pres& = dvExist(zFilName)
'
BTMaxHalfNode& = 25
'
Signature$ = "BT"
CALL dvFClose(hBtFile&)
ErrCode& = dvFOpen(zFilName, 2, 4, hBtFile&)
IF ErrCode& = 0 THEN
'
uBT& = 0
BtMaxHandle& = UBOUND(BtBuffer&)
FOR K& = 1 TO BtMaxHandle&
IF BtBuffer&(K&) = 0 THEN
BtBuffer&(K&) = hBtFile&: uBT& = K&: EXIT FOR
END IF
NEXT
IF uBT& = 0 THEN
uBT& = BtMaxHandle& + 1
REDIM PRESERVE BtBuffer&(uBT&)
REDIM PRESERVE RecBuf$(uBT&)
REDIM PRESERVE Btr(uBT&) AS Btrecord
REDIM PRESERVE ItmPtr&(uBT&)
REDIM PRESERVE CurRec&(uBT&)
REDIM PRESERVE CurLvl&(uBT&)
BtBuffer&(uBT&) = hBtFile&
END IF
'
RecBuf$(uBT&) = SPACE$(1024) ' Warning this one is global and its size
' must be always 1024 !
'
IF NOT Pres& THEN ' Create and init a new index
' data passed in is ALWAYS a 4 byte record pointer
' key passed MUST be full length
' Data Length + Key Pointer Length = 8
' how many keys will fit inside a half page
'
Btr(uBT&).Klen = Klen&
Btr(uBT&).KeyLen = Klen& + 4
'
Btr(uBT&).HlfNode = (1019 \ (Btr(uBT&).Klen + 8)) \ 2
'
IF Btr(uBT&).HlfNode < 1 THEN ' Key is too long
BtErr& = 7 ' max Length = 501
ELSE
IF Btr(uBT&).HlfNode > BTMaxHalfNode& THEN
Btr(uBT&).HlfNode = BTMaxHalfNode&
END IF
Btr(uBT&).DtaLen = 4
Btr(uBT&).ItmLen = Btr(uBT&).KeyLen + 4
Btr(uBT&).IDCode = Signature$
Btr(uBT&).RootNode = 2
Btr(uBT&).NxtNode = 3
Btr(uBT&).LastDel = 0
Btr(uBT&).NumAct = 1
Btr(uBT&).NumKeys = 0
LSET RecBuf$(uBT&) = Btr(uBT&)
CALL FPutR(hBtFile&, RecBuf$(uBT&), 1)
END IF
'
ELSE
CALL FGetR(hBtFile&, RecBuf$(uBT&), 1)
'
Btr(uBT&).HlfNode = CVI(MID$(RecBuf$(uBT&), 1, 2))
Btr(uBT&).Klen = CVI(MID$(RecBuf$(uBT&), 3, 2))
Btr(uBT&).DtaLen = CVI(MID$(RecBuf$(uBT&), 5, 2))
Btr(uBT&).ItmLen = CVI(MID$(RecBuf$(uBT&), 7, 2))
Btr(uBT&).IDCode = MID$(RecBuf$(uBT&), 9, 2)
Btr(uBT&).RootNode = CVL(MID$(RecBuf$(uBT&), 11, 4))
Btr(uBT&).NxtNode = CVL(MID$(RecBuf$(uBT&), 15, 4))
Btr(uBT&).LastDel = CVL(MID$(RecBuf$(uBT&), 19, 4))
Btr(uBT&).NumAct = CVI(MID$(RecBuf$(uBT&), 23, 2))
Btr(uBT&).NumKeys = CVL(MID$(RecBuf$(uBT&), 25, 4))
Btr(uBT&).Filler = MID$(RecBuf$(uBT&), 29, 994)
Btr(uBT&).KeyLen = CVI(MID$(RecBuf$(uBT&), 1023, 2))
'
' if no header info in memory then close file
IF Btr(uBT&).IDCode <> Signature$ THEN
BtErr& = 5 ' Not a valid Btree index
END IF
END IF
ELSE
BtErr& = 6
END IF
IF BtErr& THEN CALL dvFClose(hBtFile&)
FUNCTION = ErrCode&
'
END FUNCTION
'
FUNCTION dvBtPrev& ALIAS "dvBtPrev" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
FUNCTION = Bt&(hBtFile&, 80&, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtSearch& ALIAS "dvBtSearch" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
' Perform a radical search
Record& = 0
FUNCTION = Bt&(hBtFile&, 83, zRKey, Record&, BtErr&)
END FUNCTION
'
FUNCTION dvBtKeyNbr& ALIAS "dvBtKeyNbr" (BYVAL hBtFile&) EXPORT
' Returns the number of keys in the index.
uBT& = BtTestBuffer&(hBtFile&)
FUNCTION = Btr(uBT&).NumKeys
END FUNCTION
'
' Version 2.02 ----------------------------------------------------
FUNCTION dvBtBefore& ALIAS "dvBtBefore" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
KeyIn$ = zRKey
FUNCTION = Bt&(hBtFile&, 66&, zRKey, Record&, BtErr&)
IF LEN(zRKey) AND zRKey > KeyIn$ THEN
Record& = 0: zRKey = "": IF Bterr& = 0 THEN Bterr& = 1
END IF
END FUNCTION
'
FUNCTION dvBtAfter& ALIAS "dvBtAfter" (BYVAL hBtFile&, zRKey AS ASCIIZ, Record&, BtErr&) EXPORT
'
KeyIn$ = zRKey
'
' 06-26-2002 Jean-Pierre LEROY
IF Bt&(hBtFile&, 70, zRKey, FirstRecord&, BtErrFirst&) = 0 THEN FirstKey$ = zRKey
zRKey = KeyIn$
FUNCTION = Bt&(hBtFile&, 66&, zRKey, Record&, BtErr&)
IF LEN(zRKey) AND zRKey < KeyIn$ THEN
FUNCTION = dvBtNext(hBtFile&, zRKey, Record&, BtErr&)
ELSE
IF LEN(FirstKey$) AND KeyIn$ < FirstKey$ THEN ' 06-26-2002 Jean-Pierre LEROY
Record& = FirstRecord&
zRKey = FirstKey$
BtErr& = BtErrFirst&
EXIT FUNCTION
END IF
FUNCTION = Bt&(hBtFile&, 69&, zRKey, Record&, BtErr&)
END IF
END FUNCTION
|
|
Connexion
Menu
Chercher WDForge
Chercher Web
Partenaires
|