vwemirror/TeslaRel410
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
84ea322a18edacb3220007e59a31c06d9944cbf7
TeslaRel410/BORLAND/BDE/EXAMPLES/PASCAL/IDXDBASE.PAS
T
CydandClaude Fable 5 63312e07f9 source410: literal 4.10 source reconstruction + BC++ 4.52 fleet toolchain archived 
- BORLAND/: Borland C++ 4.52 (chosen over 4.5 by byte-match: CODE/RP/CW32.LIB
  is identical to 4.52's install lib). BCC32/TLINK32/TLIB/MAKE run natively on
  Win11; CODE/BT/OPT.MAK is the shipped BTL4OPT.EXE's exact flag recipe
  (extender = Borland PowerPack DPMI32, not Phar Lap TNT).
- restoration/source410/: the literal 1995-form reconstruction of the missing
  BT game source (never mixed into CODE/). Round 1-3 state:
  * 6 of 10 surviving original TUs COMPILE CLEAN under the period toolchain
    (BTMSSN, BTCNSL, BTSCNRL, BTTEAM, BTL4MODE, BTL4ARND) - first builds
    since 1996.
  * BT_L4/BTL4APP.CPP pilot reconstruction: 12/12 functions, Fail() lands on
    its binary-recorded line 400 exactly.
  * BT/BTCNSL.HPP: console wire IDs recovered from the binary's ctors
    (Killed=9, Damaged=10, ScoreUpdate=13, DeathWithoutHonor=15 [T1];
    TeamScore=12 flagged [T4]).
  * MUNGA/: 8 engine-header backfills back-dated from the BT412 WinTesla tree
    (VDATA numbering decomp-verified; AUDREND's OpenAL-era virtual removed -
    the period compiler is the drift detector).
  * Tooling: backdate.py (WinTesla->1995 header transform), compile410.sh
    (per-TU verification sweep under authentic OPT.MAK flags).
  * README: corrected roadmap - MECH.HPP is the capstone grown with the mech
    TU reconstructions; BTREG.CPP green = the header-family milestone.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
2026-07-19 07:33:26 -05:00

527 lines
21 KiB
ObjectPascal
Raw Blame History

{ idxdbase.pas }
program IdxDbase;
{$IfDef VER80}
uses SnipTool, SnipData, SysUtils, WinTypes, WinProcs,
DbiProcs, DbiTypes, DbiErrs;
{$Else}
uses WinTypes, WinCrt, Strings, DbiProcs, DbiTypes, DbiErrs,
SnipTool, SnipData;
{$EndIf}
const
NAMELEN = 10; { Set the length of the name fields; }
PLACELEN = 20; { Set the length of the POB field; }
DATELEN = 11; { Length that a date will be displayed: mm\dd\yyyy; }
szTblName = 'people'; { Name of table to be created. }
szTblType = szDBASE; { Table type to use. }
{ Field Descriptor used in creating a table }
fldDes: array[0..4] of FLDDesc = (
( { Field 1 - First Name }
iFldNum: 1; { Field Number }
szName: 'FirstName'; { Field Name }
iFldType: fldZSTRING; { Field Type }
iSubType: fldUNKNOWN; { Field Subtype }
iUnits1: NAMELEN; { Field Size ( 1 or 0) }
iUnits2: 0; { Decimal places ( 0 ) }
iOffset: 0; { Offset in record ( 0 ) }
iLen: 0; { Length in Bytes ( 0 ) }
iNullOffset: 0; { For Null Bits ( 0 ) }
efldvVchk: fldvNOCHECKS; { Validiy checks ( 0 ) }
efldrRights: fldrREADWRITE { Rights }
),
( { Field 2 - Middle Name }
iFldNum: 2; szName: 'MidName';
iFldType: fldZSTRING; iSubType: fldUNKNOWN;
iUnits1: NAMELEN; iUnits2: 0;
iOffset: 0; iLen: 0;
iNullOffset: 0; efldvVchk: fldvNOCHECKS;
efldrRights: fldrREADWRITE
),
( { Field 3 - Last Name }
iFldNum: 3; szName: 'LName';
iFldType: fldZSTRING; iSubType: fldUNKNOWN;
iUnits1: NAMELEN; iUnits2: 0;
iOffset: 0; iLen: 0;
iNullOffset: 0; efldvVchk: fldvNOCHECKS;
efldrRights: fldrREADWRITE
),
( { Field 4 - Date of Birth }
iFldNum: 4; szName: 'DOB';
iFldType: fldDATE; iSubType: fldUNKNOWN;
iUnits1: 0; iUnits2: 0;
iOffset: 0; iLen: 0;
iNullOffset: 0; efldvVchk: fldvNOCHECKS;
efldrRights: fldrREADWRITE
),
( { Field 5 - Place of Birth }
iFldNum: 5; szName: 'POB';
iFldType: fldZSTRING; iSubType: fldUNKNOWN;
iUnits1: PLACELEN; iUnits2: 0;
iOffset: 0; iLen: 0;
iNullOffset: 0; efldvVchk: fldvNOCHECKS;
efldrRights: fldrREADWRITE
)
); { Array of field descriptors }
{ Index Descriptor - describes the Indexe associated with the
table. }
idxDes: array[0..2] of IDXDesc = (
( { Multi-Field Production Index }
szName: ''; { Name }
iIndexId: 0; { Number }
szTagName: 'FNAME'; { Tag Name ( for dBASE ) }
szFormat: ''; { Optional Format }
bPrimary: FALSE; { Primary? }
bUnique: FALSE; { Unique? }
bDescending: FALSE; { Descending? }
bMaintained: TRUE; { Maintained? }
bSubset: FALSE; { SubSet? }
bExpIdx: TRUE; { Expression index? }
iCost: 0; { for QBE only }
iFldsInKey: 3; { Fields in key }
iKeyLen: 1; { Length in bytes }
bOutofDate: FALSE; { Index out of date? }
iKeyExpType: 0; { Key Type of Expression }
aiKeyFld: (1,2,3,0,0,0,0,0,0,0,0,0,0,0,0,0);
{ Array of field numbers }
szKeyExp: 'FirstName + MidName + LName';{ Key expression }
szKeyCond: ''; { Key Condition }
bCaseInsensitive: FALSE; { Case insensitive }
iBlockSize: 0; { Block size in bytes }
iRestrNum: 0; { Restructure number }
iUnUsed: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
),
( { Single-Field Production index }
szName: ''; iIndexId: 0;
szTagName: 'LNAME'; szFormat: '';
bPrimary: FALSE; bUnique: FALSE;
bDescending: FALSE; bMaintained: TRUE;
bSubset: FALSE; bExpIdx: FALSE;
iCost: 0; iFldsInKey: 1;
iKeyLen: 1; bOutofDate: FALSE;
iKeyExpType: 0;
aiKeyFld: (3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
szKeyExp: ''; szKeyCond: '';
bCaseInsensitive: FALSE; iBlockSize: 0;
iRestrNum: 0;
iUnUsed: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
),
( { Single-Field Production index }
szName: ''; iIndexId: 0;
szTagName: 'POB'; szFormat: '';
bPrimary: FALSE; bUnique: FALSE;
bDescending: FALSE; bMaintained: TRUE;
bSubset: FALSE; bExpIdx: FALSE;
iCost: 0; iFldsInKey: 1;
iKeyLen: 1; bOutofDate: FALSE;
iKeyExpType: 0;
aiKeyFld: (5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
szKeyExp: ''; szKeyCond: '';
bCaseInsensitive: FALSE; iBlockSize: 0;
iRestrNum: 0;
iUnUsed: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
)
);
idxDes1: IDXDesc = (
{ Multi-Field; non-maintained dBASE index }
szName: 'FULLNAME.NDX'; iIndexId: 0;
szTagName: ''; szFormat: '';
bPrimary: FALSE; bUnique: FALSE;
bDescending: FALSE; bMaintained: FALSE;
bSubset: FALSE; bExpIdx: TRUE;
iCost: 0; iFldsInKey: 2;
iKeyLen: 1; bOutofDate: FALSE;
iKeyExpType: 0;
aiKeyFld: (1,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
szKeyExp: 'FirstName + LName'; szKeyCond: '';
bCaseInsensitive: FALSE; iBlockSize: 0;
iRestrNum: 0;
iUnUsed: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
);
{=====================================================================
Code: AddRecord();
Input: pointer to the cursor handle, first name (pCHAR), middle
name (pCHAR), last name (pCHAR), Month of Birth (UINT16), Day
of Birth (UINT16), Year of Birth (UINT16), Place of birth
(pCHAR).
Return: Result of adding the record to the table
Description:
This function will add a record to the given table.
===================================================================== }
Function
AddRecord (hCur: hDBICur; pszFirst: pCHAR; pszMiddle:
pCHAR; pszLast: pCHAR; uMonth: UINT16; uDay: UINT16;
uYear: UINT16; pszPOB: pCHAR): DBIResult;
var
dDate: DATE; { Date structure }
rslt: DBIResult; { Value returned from IDAPI functions }
TblProps: CURProps; { Table Properties }
pRecBuf: pBYTE; { Record Buffer }
begin
{ Allocate a record buffer }
ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
' Error - GetCursorProps.');
GetMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
if not Assigned(pRecBuf) then
begin
AddRecord := DBIERR_NOMEMORY;
exit;
end;
ChkRslt(DbiInitRecord(hCur, pRecBuf), DBIERR_NONE,
' Error - InitRecord.');
{ First Name }
ChkRslt(DbiPutField(hCur, 1, pRecBuf, pBYTE(pszFirst)),
DBIERR_NONE, ' Error - PutField.');
{ Middle Name }
ChkRslt(DbiPutField(hCur, 2, pRecBuf, pBYTE(pszMiddle)),
DBIERR_NONE, ' Error - PutField.');
{ Last Name }
ChkRslt(DbiPutField(hCur, 3, pRecBuf, pBYTE(pszLast)),
DBIERR_NONE, ' Error - PutField.');
{ DOB }
ChkRslt(DbiDateEncode(uMonth, uDay, uYear, dDate),
DBIERR_NONE, ' Error - DateEncode.');
ChkRslt(DbiPutField(hCur, 4, pRecBuf, @dDate),
DBIERR_NONE, ' Error - PutField.');
{ Place fo Birth }
ChkRslt(DbiPutField(hCur, 5, pRecBuf, pBYTE(pszPOB)),
DBIERR_NONE, ' Error - PutField.');
rslt := ChkRslt(DbiInsertRecord(hCur, dbiNOLOCK, pRecBuf),
DBIERR_NONE, ' Error - InsertRecord.');
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
AddRecord := rslt;
end;
{=====================================================================
Code: GoTop()
Input: Handle to the table's cursor.
Return: Nothing.
Description:
This function will move the cursor to the top of the table
that it is set to.
===================================================================== }
procedure GoTop (hCur: hDBICur);
begin
{ This will set the cursor to the top of table(BOF). However, the
cursor is on the crack so one needs to move to the top. }
ChkRslt(DbiSetToBegin(hCur), DBIERR_NONE, ' Error - SetToBegin.');
{ Now get the next record with no lock to move on top of the first
record. }
ChkRslt(DbiGetNextRecord(hCur, dbiNOLOCK, nil, nil), DBIERR_NONE,
' Error - GetNextRecord.');
end;
{=====================================================================
Code: InitTable();
Input: pointer to the database handle.
Return: result of the table initialization.
Description:
This function will create a table and fill the table
with a number of records. The function uses
another function called AddRecord which adds records to
the table.
===================================================================== }
function InitTable (phDb: hDBIDb): DBIResult;
var
rslt: DBIResult; { Value returned from IDAPI functions }
hCur: hDBICur; { Cursor handle for the table that is
created }
crTblDes: CRTblDesc; { Table Descriptor }
MyDesc: pIDXDesc; { Index Descriptor }
uNumFields, uNumIndexes: INT16;
const
bOverWrite: BOOL = TRUE; { Overwrite, yes/no flag }
begin
{ The number of fields in the table }
uNumFields := trunc(sizeof(fldDes) / sizeof (fldDes[0]));
{ Number of indexes to be created when the table is created }
uNumIndexes := trunc(sizeof(idxDes) / sizeof(idxDes[0]));
FillChar(crTblDes, sizeof(CRTblDesc), #0); { Clear the buffer. }
{ Set the name and the type of the table }
StrCopy(crTblDes.szTblName, szTblName) ; { name of the table }
StrCopy(crTblDes.szTblType, szTblType) ; { Type of table }
{ Set the field information for the table }
crTblDes.iFldCount := uNumFields ; { number of fields }
crTblDes.pfldDesc := @fldDes ; { Field descriptor }
{ Set the index information for the table }
crTblDes.iIdxCount := uNumIndexes ; { Number of indexes }
crTblDes.pidxDesc := @idxDes ; { Index descriptor }
{ Create the table using information supplied in the Table
Descrpitor above }
Screen(' Creating table and indexes...');
rslt := ChkRslt(DbiCreateTable(phDb, bOverWrite, crTblDes),
DBIERR_NONE, ' Error - CreateTable.');
if (rslt <> DBIERR_NONE) then
begin
InitTable := rslt;
exit;
end;
ChkRslt(DbiOpenTable(phDb, pCHAR(szTblName), pCHAR(szTblType),
nil, nil, 0, dbiREADWRITE, dbiOPENSHARED,
xltFIELD, FALSE, nil, hCur),
DBIERR_NONE, ' Error - OpenTable.');
{ Add records to the table }
Screen(' Adding Records to the table...');
rslt := AddRecord(hCur, 'Klaus', 'John', 'Lockwood', 7, 28, 1968,
'Chicago');
rslt := AddRecord(hCur, 'Ann', 'Tracy', 'Brown', 12, 27, 1969,
'Hermosa Beach');
rslt := AddRecord(hCur, 'John', 'Boy', 'Krull', 2, 7, 1954,
'Ohmaha');
rslt := AddRecord(hCur, 'Goliath', 'Joel', 'Raccah', 4, 13, 1970,
'Tel Aviv');
{ Close the table so it can be reopened from the calling function. }
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
' Error - CloseCursor.');
InitTable := rslt;
end;
{=====================================================================
Code: IndexDBase();
Input: None.
Return: None.
Description:
This example shows how to setup a dBASE table and dBASE
indexes. This includes expression indexes(multiple field
indexes) and the particular needs of the common dBASE index.
===================================================================== }
var
hDb: hDBIDb; { Database handle }
hCur: hDBICur; { Cursor handle }
MyDesc: pIDXDesc; { Index Descriptor }
begin
Screen('*** dBASE Index Example ***');
Screen('');
Screen(' Initializing IDAPI...');
if (InitAndConnect(hDb) <> DBIERR_NONE) then { Terminate example if }
begin { Initialization fails }
Screen('');
Screen('*** End of Example ***');
exit;
end;
Screen(' Setting the default Database directory...');
ChkRslt(DbiSetDirectory(hDb, pCHAR(szTblDirectory)), DBIERR_NONE,
' Error - SetDirectory.');
{ Create the table and insert four records }
if (InitTable(hDb) <> DBIERR_NONE) then
begin
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
Screen(' Open the table which we just created in exclusive'+
' mode ');
Screen(' (required in order to add an index to a'+
' dBASE table)...');
if (ChkRslt(DbiOpenTable(hDb, pCHAR(szTblName), pCHAR(szTblType),
nil, nil, 0, dbiREADWRITE, dbiOPENEXCL,
xltFIELD, FALSE, nil, hCur),
DBIERR_NONE, ' Error - OpenTable.') <> DBIERR_NONE) then
begin
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
{ Now add the new index to the table. To add an index we must have
an exclusive lock on the table which we acquired when opening the
table. }
Screen(' Adding another Index to the table...');
ChkRslt(DbiAddIndex(hDb, hCur, pCHAR(szTblName), pCHAR(szTblType),
idxDes1, nil), DBIERR_NONE,
' Error - AddIndex.');
{ Close the index. In dBASE, after closing a non-maintained
index will not be kept up-to-date. }
Screen(' Closing the non-maintained index we just added...');
ChkRslt(DbiCloseIndex(hCur, 'FULLNAME.NDX', 0), DBIERR_NONE,
' Error - CloseIndex.');
{ Now add a record to the table to make the index out of date. }
Screen(' Adding a record to invalidate the index...');
ChkRslt(AddRecord(hCur, 'Charlie', 'Joel', 'Waternon', 5, 21, 1983,
'California'), DBIERR_NONE,
' Error - AddRecord.');
{ Open the added index using OpenIndex a function that is DBase
specific. }
Screen(' Open the new index to show that it is out of date...');
ChkRslt(DbiOpenIndex(hCur, 'FULLNAME.NDX', 0), DBIERR_NONE,
' Error - OpenIndex.');
{ Opening the index does not make it the current index. To make the
index current we need to switch to it. For a non maintained .NDX
index, we need to supply the index name. }
Screen(' Switch to the newly created index that is out of date...');
ChkRslt(DbiSwitchToIndex(hCur, 'FULLNAME.NDX', nil, 0, FALSE),
DBIERR_NONE, ' Error - SwitchToIndex.');
Screen(' Display the table...');
Screen('');
Screen(' Note that only 4 entries are displayed even'+
' though there are 5 ');
Screen(' entries in the table'+
' because the index is out of date...');
ChkRslt(DisplayTable(hCur, 0), DBIERR_NONE,
' Error - DisplayTable.');
{ Switch to default order. We cannot regen the index if it is the
currently active index on the cursor. }
Screen('');
Screen(' Switching to default order...');
ChkRslt (DbiSwitchToIndex(hCur, nil, nil, 0, FALSE),
DBIERR_NONE, 'SwitchToIndex');
Screen('');
Screen(' Regenerating the index...');
ChkRslt(DbiRegenIndex(hDb, hCur, pCHAR(szTblName), pCHAR(szTblType),
'FULLNAME.NDX', nil, 0), DBIERR_NONE,
' Error - RegenIndex.');
{ Switch back to the non-maintained index. It should now be up-to-date. }
Screen(' Switch to the newly regenerated index...');
ChkRslt ( DbiSwitchToIndex(hCur, 'FULLNAME.NDX', nil, 0, FALSE),
DBIERR_NONE, 'SwitchToIndex');
Screen(' Display the table according to the new index...');
ChkRslt(DisplayTable(hCur, 0), DBIERR_NONE,
' Error - Display Table.');
{ Now case the index to no index. This is beacuse the default
index for dBASE is no index so passing nil for all three options
will return a cursor that has no order other than the order in
which the records were inserted. }
Screen('');
Screen(' Switching index to show record order...');
ChkRslt(DbiSwitchToIndex(hCur, nil, nil, 0, FALSE),
DBIERR_NONE, ' Error - SwitchToIndex.');
{ Now re - display the table. }
Screen(' This is the order of the table with no index...');
ChkRslt(DisplayTable(hCur, 0), DBIERR_NONE,
' Error - DisplayTable.');
{ Now get memory for the index descriptor. }
GetMem (MyDesc, sizeof(IDXDesc));
if not Assigned(MyDesc) then
begin
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
{ Close the non-maintained index as we are done with this
part of the example. }
Screen('');
Screen(' Closing the non-maintained index.');
ChkRslt (DbiCloseIndex(hCur, 'FULLNAME.NDX', 0), DBIERR_NONE,
'CloseIndex');
{ The only indexes that are open now are maintained indexes since we
have already closed the non-maintained index. }
{ Get any index descriptor (in this case the first one). }
ChkRslt(DbiGetIndexDesc(hCur, 1, MyDesc^), DBIERR_NONE,
' Error - GetIndexDesc.');
Screen('');
Screen(' Switching to a index in the production index... ');
ChkRslt(DbiSwitchToIndex(hCur, MyDesc^.szName, MyDesc^.szTagName, 0,
FALSE), DBIERR_NONE,
' Error - SwitchToIndex.');
Screen(' This is the order of the table using a tag'+
' inside the production');
Screen(' index called '+StrPas(MyDesc^.szTagName)+' ');
ChkRslt(DisplayTable(hCur, 0), DBIERR_NONE,
' Error - DisplayTable.');
{ Delete the table and its related indexes and files from disk. To
do this we first need to delete the NDX and then we close the
table and delete the table. By doing this IDAPI will delete the
MDX file for us. }
Screen('');
Screen(' Must delete the FULLNAME.NDX index separately as it is not');
Screen(' a part of the production index...');
ChkRslt(DbiDeleteIndex(hDb, hCur, pCHAR(szTblName), pCHAR(szTblType),
'FULLNAME.NDX', nil, 0), DBIERR_NONE,
' Error - DeleteIndex.');
Screen(' Close the '+szTblName+' table...');
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
' Error - CloseCursor.');
Screen(' Delete the '+szTblName+' table...');
ChkRslt(DbiDeleteTable(hDb, pCHAR(szTblName), pCHAR(szTblType)),
DBIERR_NONE, ' Error - DeleteTable.');
FreeMem(MyDesc, sizeof(IDXDesc));
Screen(' Close the Database and exit IDAPI...');
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
end.
Reference in New Issue View Git Blame Copy Permalink