vwemirror/TeslaRel410
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
859529d6f20d5ed4dcba1cddef0ec7ca794701de
TeslaRel410/BORLAND/BDE/EXAMPLES/PASCAL/IDXPDOX.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

532 lines
21 KiB
ObjectPascal
Raw Blame History

{ idxpdox.pas }
program IdxPdox;
{$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 = szPARADOX; { 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: 'First Name'; { 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: 'Middle Name';
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: 'Last Name';
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 Descriptors }
idxDes: array[0..2] of IDXDesc = (
( { Primary Index - Full Name }
szName: 'Full Name'; { Name }
iIndexId: 1; { Number }
szTagName: ''; { Tag Name ( for dBase ) }
szFormat: ''; { Optional Format }
bPrimary: TRUE; { Primary? }
bUnique: TRUE; { Unique? }
bDescending: FALSE; { Descending? }
bMaintained: TRUE; { Maintained? }
bSubset: FALSE; { SubSet? }
bExpIdx: FALSE; { 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: ''; { 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)
),
( { Secondary Index 1 - Single-Field - Maintained,
Case insensitive }
szName: 'Last Name'; iIndexId: 2;
szTagName: ''; 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: TRUE; iBlockSize: 0;
iRestrNum: 0;
iUnUsed: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
),
( { Secondary Index 2 - Single Field - Not Maintained }
szName: 'POB'; iIndexId: 3;
szTagName: ''; szFormat: '';
bPrimary: FALSE; bUnique: FALSE;
bDescending: FALSE; bMaintained: FALSE;
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)
)
);
{ Index Descriptor - Describes the indexes associated with the
table. This index will be added to the table after the table
has been created. }
idxDesc1: IDXDesc = (
{ Secondary Index 3 - Multi-Field - Maintained }
szName: 'Name'; iIndexId: 4;
szTagName: ''; szFormat: '';
bPrimary: FALSE; bUnique: FALSE;
bDescending: FALSE; bMaintained: TRUE;
bSubset: FALSE; bExpIdx: FALSE;
iCost: 0; iFldsInKey: 2;
iKeyLen: 1; bOutofDate: FALSE;
iKeyExpType: 0;
aiKeyFld: (3,1,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)
);
{=====================================================================
===================================================================== }
function TrueOrFalse (bTemp: Bool): String;
begin
if (bTemp) then
TrueOrFalse := 'TRUE'
else
TrueOrFalse := 'FALSE';
end;
{=====================================================================
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;
{ Make sure we're starting with a clean record buffer }
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: 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 }
uNumFields, uNumIndexes: INT16;
const
bOverWrite: BOOL = TRUE; { Overwrite, yes/no flag }
begin
{ The number of fields in the table - note that fldDesc is defined
globally }
uNumFields := trunc(sizeof(fldDes) / sizeof (fldDes[0]));
{ Number of indexes to be created when the table is created - note
that idxDesc is defined globally. }
uNumIndexes := trunc(sizeof(idxDes) / sizeof(idxDes[0]));
{ Initialize the table create descriptor. }
FillChar(crTblDes, sizeof(CRTblDesc), #0); { Clear the buffer. }
StrCopy(crTblDes.szTblName, szTblName) ; { name of the table }
StrCopy(crTblDes.szTblType, szTblType) ; { Type of table }
crTblDes.iFldCount := uNumFields ; { number of fields }
crTblDes.pfldDesc := @fldDes ; { Field descriptor }
crTblDes.iIdxCount := uNumIndexes ; { Number of indexes }
crTblDes.pidxDesc := @idxDes ; { Index descriptor }
Screen(' Creating the '+szTblName+' table...');
rslt := ChkRslt(DbiCreateTable(phDb, bOverWrite, crTblDes),
DBIERR_NONE, ' Error - CreateTable.');
if (rslt <> DBIERR_NONE) then
begin
InitTable := rslt;
exit;
end;
rslt := ChkRslt(DbiOpenTable(phDb, pCHAR(szTblName),
pCHAR(szTblType), nil, nil, 0,
dbiREADWRITE, dbiOPENSHARED,
xltFIELD, FALSE, nil, hCur),
DBIERR_NONE, ' Error - OpenTable.');
if (rslt <> DBIERR_NONE) then
begin
InitTable := rslt;
exit;
end;
{ Add records to the table }
Screen(' Add Records to the table...');
AddRecord(hCur, 'Klaus', 'John', 'Lockwood', 7, 28, 1968,
'Chicago');
AddRecord(hCur, 'Tracy', 'Ann', 'Brown', 12, 27, 1969,
'Hermosa Beach');
AddRecord(hCur, 'John', 'Boy', 'Krull', 2, 7, 1954,
'Ohmaha');
AddRecord(hCur, 'Goliath', 'Joel', 'Raccah', 4, 13, 1970,
'Tel Aviv');
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
' Error - CloseCursor.');
InitTable := rslt;
end;
{=====================================================================
Code: IndexPDox();
Input: None.
Return: None.
Description:
This example shows how to craete and add Paradox indexes.
This encludes creating primary indexes and maintaining
secondary indexes (if needed).
===================================================================== }
var
hDb: hDBIDb; { Database handle }
hCur: hDBICur; { Cursor handle }
TblProps: CURProps; { Table Properties }
MyDesc: pIDXDesc; { Index Descriptor }
i: UINT16; { Loop variable }
szTemp: PChar;
begin
Screen('*** Index Manipulation Example ***');
Screen(' Initializing IDAPI...');
if (InitAndConnect(hDb) <> DBIERR_NONE) then
begin
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 fill with data }
if (InitTable(hDb) <> DBIERR_NONE) then
begin
Screen(' Clean up IDAPI...');
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
{ Add an index to the table. Note that the index is added to the
table before the table is opened - the table must either be closed
or opened in exclusive mode in order to an an Index. }
Screen(' Add an Index to the table...');
ChkRslt(DbiAddIndex(hDb, nil, pCHAR(szTblName),
pCHAR(szTblType), idxDesc1, nil), DBIERR_NONE,
' Error - AddIndex.');
Screen(' Open the '+szTblName+' table...');
if (ChkRslt(DbiOpenTable(hDb, pCHAR(szTblName), pCHAR(szTblType),
nil, nil, 0, dbiREADWRITE, dbiOPENSHARED,
xltFIELD, FALSE, nil, hCur),
DBIERR_NONE, ' Error - OpenTable.') <> DBIERR_NONE) then
begin
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
Screen(' Get the number of indexes on the '+szTblName+'table...');
ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
' Error - GetCursorProps.');
Screen(' There are '+IntToStr(TblProps.iIndexes)+' indexes on the table');
{ Allocate space for the index descriptor. }
GetMem(MyDesc, sizeof(IDXDesc) * TblProps.iIndexes);
if not Assigned(MyDesc) then
begin
Screen(' Error - Out of Memory.');
CloseDbAndExit(hDb);
Screen('');
Screen('*** End of Example ***');
exit;
end;
Screen(' Get and display information about the indexes');
Screen('');
Screen(' Name ID Primary Maintained '+
'Fields Case_Insensitive');
Screen(' =================================================='+
'==========');
GetMem(szTemp, 50);
for i := 1 to TblProps.iIndexes do
begin
ChkRslt(DbiGetIndexDesc(hCur, i, MyDesc^),
DBIERR_NONE, ' Error - GetIndexDesc.');
if (StrComp(MyDesc^.szName, '') = 0) then
{ Primary index don't have names }
StrCopy(szTemp, '*Primary Index*')
else
StrCopy(szTemp, RightPad(szTemp, MyDesc^.szName, 13 ));
Screen(' '+StrPas(szTemp)+' '+IntToStr(MyDesc^.iIndexId)+' '+
''+TrueOrFalse(MyDesc^.bPrimary)+' '+
''+TrueOrFalse(MyDesc^.bMaintained)+' '+
''+IntToStr(MyDesc^.iFldsInKey)+' '+
''+TrueOrFalse(MyDesc^.bCaseInsensitive)+' ');
Inc(MyDesc);
end;
Dec(MyDesc, TblProps.iIndexes);
ChkRslt(DbiSetToBegin(hCur), DBIERR_NONE,
' Error - SetToBegin.');
{ Display the records in the table. The order of the records depends
on the active index - in this case, it is the primary Index. }
Screen('');
Screen(' Display the records in the table in the order of the'+
' primary');
Screen(' index - First, Middle, Last.');
DisplayTable(hCur, 0);
{ Switch the index which the table is opened on - only need to
provide one of the following: IndexName, TagName, or IndexId. }
Screen('');
Screen(' Change the table to be opened on the "Last Name"'+
' index...');
ChkRslt(DbiSwitchToIndex(hCur, 'Last Name', nil, 0, FALSE),
DBIERR_NONE, ' Error - SwitchToIndex.');
ChkRslt(DbiSetToBegin(hCur), DBIERR_NONE,
' Error - SetToBegin.');
Screen(' Display the records in the table in the order of the '+
'"Last Name" index...');
DisplayTable(hCur, 0);
Screen('');
Screen(' Add a record to the table in order to invalidate...'+
' non-maintained indexes');
AddRecord(hCur, 'Jerry', 'Joel', 'Raccah', 5, 22, 1958,
'Lake Tahoe');
{ Switch the index which the table is opened on - only need to
provide one of the following: IndexName, TagName, or IndexId.
This function here is passed an ID of 5 which is the
id of the single field that it is indexing on. }
Screen('');
Screen(' Change the table to be opened on the "POB"'+
' index (which is non-maintained)...');
Screen(' Note that we expect an error - the "POB" index is' +
' not maintained');
Screen('');
ChkRslt(DbiSwitchToIndex(hCur, nil, nil, 5, FALSE),
DBIERR_NONE, ' Error - SwitchToIndex.');
Screen('');
Screen(' Steps to regenerate the "POB" index...');
Screen(' Close the Table - the table must be open in' +
' Exclusive mode to Regenerate');
Screen(' the indexes...');
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
' Error - CloseCursor.');
Screen(' Open the table in Exclusive mode...');
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;
Screen(' Regenerate the index...');
ChkRslt(DbiRegenIndex(hDb, hCur, pCHAR(szTblName),
pCHAR(szTblType), 'POB', nil, 5),
DBIERR_NONE, ' Error - RegenIndexes.');
{ Switch the index which the table is opened on - only need to
provide one of the following: IndexName, TagName, or IndexId
(parameter 2, 3, or 4 to DbiSwitchToIndex). }
Screen('');
Screen(' Change the table to be opened on the "POB"' +
' index (which is non-maintained)...');
ChkRslt(DbiSwitchToIndex(hCur, 'POB', nil, 0, FALSE),
DBIERR_NONE, ' Error - SwitchToIndex.');
ChkRslt(DbiSetToBegin(hCur), DBIERR_NONE,
' Error - SetToBegin.');
Screen(' Display the records in the table in the order of the'+
'"POB" (Place of Birth)');
Screen(' index...');
DisplayTable(hCur, 0);
{ Note that the table has to be opened either in Exclusive
Mode or closed to delete an index. }
Screen('');
Screen(' Delete the "Last Name" index...');
ChkRslt(DbiDeleteIndex(hDb, nil, pCHAR(szTblName),
pCHAR(szTblType), 'Last Name', '', 0),
DBIERR_NONE, ' Error - DeleteIndex.');
Screen(' Close the '+szTblName+' Table...');
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
' Error - CloseCursor.');
Screen(' Delete the '+szTblName+' table and remaining indexes...');
ChkRslt(DbiDeleteTable(hDb, pCHAR(szTblName), pCHAR(szTblType)),
DBIERR_NONE, ' Error - DeleteTable.');
FreeMem(MyDesc, sizeof(IDXDesc) * TblProps.iIndexes);
Screen(' Close the Database and exit IDAPI...');
CloseDbAndExit(hDb);
Screen('*** End of Example ***');
end.
Reference in New Issue View Git Blame Copy Permalink